diff options
228 files changed, 9106 insertions, 5050 deletions
diff --git a/.gitignore b/.gitignore index 39ef20970d..05869e2a0c 100644 --- a/.gitignore +++ b/.gitignore @@ -101,7 +101,6 @@ doc/faq/axioms.pdf_t doc/faq/axioms.png doc/sphinx/index.rst doc/sphinx/zebibliography.rst -doc/sphinx/credits.rst doc/stdlib/Library.out doc/stdlib/Library.ps doc/stdlib/Library.coqdoc.tex diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 948e4f0a37..1669145d9b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -130,6 +130,7 @@ after_script: # careful with the ending / - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ + - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - make -j "$NJOBS" BIN="$BIN" LIB="$LIB" all artifacts: name: "$CI_JOB_NAME.logs" @@ -320,6 +321,19 @@ test-suite:edge+flambda: OPAM_SWITCH: edge OPAM_VARIANT: "+flambda" +test-suite:egde:dune:dev: + stage: test + dependencies: + - build:egde:dune:dev + script: make -f Makefile.dune test-suite + variables: + OPAM_SWITCH: edge + artifacts: + name: "$CI_JOB_NAME.logs" + when: on_failure + paths: + - _build/default/test-suite/logs + validate:base: <<: *validate-template dependencies: @@ -352,6 +366,7 @@ ci-aac-tactics: ci-bedrock2: <<: *ci-template + allow_failure: true ci-bignums: <<: *ci-template diff --git a/CHANGES.md b/CHANGES.md index 67e0e06caa..865e1eeb95 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -20,6 +20,11 @@ Tactics the same section. For example, the following is no longer accepted: `Ltac foo := idtac. Section S. Ltac foo := fail. End S.` +- The tactics 'lia','nia','lra','nra' are now using a novel + Simplex-based proof engine. In case of regression, 'Unset Simplex' + to get the venerable Fourier-based engine. + + Changes from 8.8.2 to 8.9+beta1 =============================== @@ -37,6 +42,14 @@ Notations `Bind Scope`, `Delimit Scope`, `Undelimit Scope`, or `Notation` is deprecated. +- Deprecated compatibility notations will actually be removed in the + next version of Coq. Uses of these notations are generally easy to + fix thanks to the hint contained in the deprecation warnings. For + projects that require more than a handful of such fixes, there is [a + script](https://gist.github.com/JasonGross/9770653967de3679d131c59d42de6d17#file-replace-notations-py) + that will do it automatically, using the output of coqc. The script + contains documentation on its usage in a comment at the top. + Tactics - Added toplevel goal selector `!` which expects a single focused goal. diff --git a/Makefile.build b/Makefile.build index ee758fcc5f..4d19f9a2e1 100644 --- a/Makefile.build +++ b/Makefile.build @@ -685,6 +685,8 @@ plugins/nsatz/%.cmi: plugins/nsatz/%.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< +kernel/%.cmi: COND_BYTEFLAGS+=-w +a-4-44-50 + %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -697,6 +699,8 @@ plugins/nsatz/%.cmo: plugins/nsatz/%.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< +kernel/%.cmo: COND_BYTEFLAGS+=-w +a-4-44-50 + %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -742,6 +746,8 @@ plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< +kernel/%.cmx: COND_OPTFLAGS+=-w +a-4-44-50 + %.cmx: %.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< diff --git a/Makefile.doc b/Makefile.doc index 1184cc186b..9e6ec4955a 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -10,7 +10,7 @@ # Makefile for the Coq documentation -# Read INSTALL.doc to learn about the dependencies +# Read doc/README.md to learn about the dependencies # The main entry point : diff --git a/Makefile.dune b/Makefile.dune index 6733c485fa..298a27c93e 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -1,7 +1,7 @@ # -*- mode: makefile -*- # Dune Makefile for Coq -.PHONY: voboot states world watch release apidoc ocheck clean help +.PHONY: help voboot states world watch test-suite release apidoc ocheck ireport clean # use DUNEOPT=--display=short for a more verbose build # DUNEOPT=--display=short @@ -13,9 +13,11 @@ help: @echo " - states: build a minimal functional coqtop" @echo " - world: build all binaries and libraries" @echo " - watch: build all binaries and libraries [continuous build]" + @echo " - test-suite: run Coq's test suite" @echo " - release: build Coq in release mode" @echo " - apidoc: build ML API documentation" @echo " - ocheck: build for all supported OCaml versions [requires OPAM]" + @echo " - ireport: build with optimized flambda settings and emit an inline report" @echo " - clean: remove build directory and autogenerated files" @echo " - help: show this message" @@ -32,6 +34,9 @@ world: voboot watch: voboot dune build $(DUNEOPT) @install -w +test-suite: voboot + dune $(DUNEOPT) runtest + release: voboot dune build $(DUNEOPT) -p coq @@ -41,6 +46,12 @@ apidoc: voboot ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all +ireport: + dune clean + dune build $(DUNEOPT) @vodeps --profile=ireport + dune exec coq_dune $(BUILD_CONTEXT)/.vfiles.d --profile=ireport + dune build $(DUNEOPT) @install --profile=ireport + clean: dune clean diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 0478765a81..50e65ef587 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -310,25 +310,31 @@ let failwith_non_pos_list n ntypes l = List.iter (failwith_non_pos n ntypes) l; anomaly ~label:"failwith_non_pos_list" (Pp.str "some k in [n;n+ntypes-1] should occur.") -(* Conclusion of constructors: check the inductive type is called with - the expected parameters *) -let check_correct_par (env,n,ntypes,_) hyps l largs = - let nparams = rel_context_nhyps hyps in - let largs = Array.of_list largs in - if Array.length largs < nparams then - raise (IllFormedInd (LocalNotEnoughArgs l)); - let (lpar,largs') = Array.chop nparams largs in - let nhyps = List.length hyps in - let rec check k index = function +(* Check the inductive type is called with the expected parameters *) +(* [n] is the index of the last inductive type in [env] *) +let check_correct_par (env,n,ntypes,_) paramdecls ind_index args = + let nparams = rel_context_nhyps paramdecls in + let args = Array.of_list args in + if Array.length args < nparams then + raise (IllFormedInd (LocalNotEnoughArgs ind_index)); + let (params,realargs) = Array.chop nparams args in + let nparamdecls = List.length paramdecls in + let rec check param_index paramdecl_index = function | [] -> () - | LocalDef _ :: hyps -> check k (index+1) hyps - | _::hyps -> - match whd_all env lpar.(k) with - | Rel w when w = index -> check (k-1) (index+1) hyps - | _ -> raise (IllFormedInd (LocalNonPar (k+1,index,l))) - in check (nparams-1) (n-nhyps) hyps; - if not (Array.for_all (noccur_between n ntypes) largs') then - failwith_non_pos_vect n ntypes largs' + | LocalDef _ :: paramdecls -> + check param_index (paramdecl_index+1) paramdecls + | _::paramdecls -> + match whd_all env params.(param_index) with + | Rel w when Int.equal w paramdecl_index -> + check (param_index-1) (paramdecl_index+1) paramdecls + | _ -> + let paramdecl_index_in_env = paramdecl_index-n+nparamdecls+1 in + let err = + LocalNonPar (param_index+1, paramdecl_index_in_env, ind_index) in + raise (IllFormedInd err) + in check (nparams-1) (n-nparamdecls) paramdecls; + if not (Array.for_all (noccur_between n ntypes) realargs) then + failwith_non_pos_vect n ntypes realargs (* Arguments of constructor: check the number of recursive parameters nrecp. the first parameters which are constant in recursive arguments @@ -412,8 +418,8 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps nrecp (_,i as ind) indlc | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) d) | Rel k -> - (try - let (ra,rarg) = List.nth ra_env (k-1) in + (try let (ra,rarg) = List.nth ra_env (k-1) in + let largs = List.map (whd_all env) largs in (match ra with Mrec _ -> check_rec_par ienv hyps nrecp largs | _ -> ()); diff --git a/checker/inductive.ml b/checker/inductive.ml index d15380643f..5e34f04f51 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -282,6 +282,11 @@ let get_instantiated_arity (ind,u) (mib,mip) params = let elim_sorts (_,mip) = mip.mind_kelim +let is_primitive_record (mib,_) = + match mib.mind_record with + | PrimRecord _ -> true + | NotRecord | FakeRecord -> false + let extended_rel_list n hyps = let rec reln l p = function | LocalAssum _ :: hyps -> reln (Rel (n+p) :: l) (p+1) hyps @@ -381,12 +386,13 @@ let type_case_branches env (pind,largs) (p,pj) c = (* Checking the case annotation is relevant *) let check_case_info env indsp ci = - let (mib,mip) = lookup_mind_specif env indsp in + let mib, mip as spec = lookup_mind_specif env indsp in if not (eq_ind_chk indsp ci.ci_ind) || (mib.mind_nparams <> ci.ci_npar) || (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls) || - (mip.mind_consnrealargs <> ci.ci_cstr_nargs) + (mip.mind_consnrealargs <> ci.ci_cstr_nargs) || + is_primitive_record spec then raise (TypeError(env,WrongCaseInfo(indsp,ci))) (************************************************************************) @@ -801,10 +807,23 @@ let rec subterm_specif renv stack t = subterm_specif (push_var renv (x,a,spec)) stack' b (* Metas and evars are considered OK *) - | (Meta _|Evar _) -> Dead_code - - (* Other terms are not subterms *) - | _ -> Not_subterm + | (Meta _|Evar _) -> Dead_code + + | Proj (p, c) -> + let subt = subterm_specif renv stack c in + (match subt with + | Subterm (_s, wf) -> + (* We take the subterm specs of the constructor of the record *) + let wf_args = (dest_subterms wf).(0) in + (* We extract the tree of the projected argument *) + let n = Projection.arg p in + spec_of_tree (List.nth wf_args n) + | Dead_code -> Dead_code + | Not_subterm -> Not_subterm) + + (* Other terms are not subterms *) + | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ + | Construct _ | CoFix _ -> Not_subterm and lazy_subterm_specif renv stack t = lazy (subterm_specif renv stack t) @@ -856,6 +875,8 @@ let filter_stack_domain env p stack = match stack, t with | elt :: stack', Prod (n,a,c0) -> let d = LocalAssum (n,a) in + let ctx, a = dest_prod_assum env a in + let env = push_rel_context ctx env in let ty, args = decompose_app (whd_all env a) in let elt = match ty with | Ind ind -> diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 0916d98ddf..e2c605dde8 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -198,9 +198,11 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= assert (Array.length mib2.mind_packets = 1); assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1); assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1); - check - (fun l1 l2 -> List.equal Name.equal l1 l2) - (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0)); + check (List.equal Name.equal) + (fun mib -> + let nparamdecls = List.length mib.mind_params_ctxt in + let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in + snd (List.chop nparamdecls names)) end; (* we first check simple things *) Array.iter2 check_packet mib1.mind_packets mib2.mind_packets; diff --git a/config/dune b/config/dune index ce87a7816d..cc993b97c9 100644 --- a/config/dune +++ b/config/dune @@ -7,7 +7,7 @@ ; Dune doesn't use configure's output, but it is still necessary for ; some Coq files to work; will be fixed in the future. (rule - (targets coq_config.ml) + (targets coq_config.ml Makefile) (mode fallback) (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/configure.ml b/configure.ml index 7cc58a3506..f884a7de5c 100644 --- a/configure.ml +++ b/configure.ml @@ -1038,7 +1038,7 @@ let do_one_instdir (var,msg,uservalue,selfcontainedlayout,unixlayout,locallayout try Some (Sys.getenv "COQ_CONFIGURE_PREFIX") with | Not_found when !prefs.interactive -> None - | Not_found -> Some "_build/install/default" + | Not_found -> Some Sys.(getcwd () ^ "/../install/default") end | p -> p in match uservalue, env_prefix with diff --git a/coqpp/coqpp_ast.mli b/coqpp/coqpp_ast.mli index 956a916792..93a07cff9d 100644 --- a/coqpp/coqpp_ast.mli +++ b/coqpp/coqpp_ast.mli @@ -60,6 +60,17 @@ and gram_prod = { gprod_body : code; } +type symb = +| SymbToken of string * string option +| SymbEntry of string * string option +| SymbSelf +| SymbNext +| SymbList0 of symb * symb option +| SymbList1 of symb * symb option +| SymbOpt of symb +| SymbRules of ((string option * symb) list * code) list +| SymbQuote of string (** Not used by GRAMMAR EXTEND *) + type gram_rule = { grule_label : string option; grule_assoc : assoc option; @@ -85,12 +96,57 @@ type tactic_ext = { tacext_rules : tactic_rule list; } +type classification = +| ClassifDefault +| ClassifCode of code +| ClassifName of string + +type vernac_rule = { + vernac_toks : ext_token list; + vernac_class : code option; + vernac_depr : bool; + vernac_body : code; +} + +type vernac_ext = { + vernacext_name : string; + vernacext_entry : code option; + vernacext_class : classification; + vernacext_rules : vernac_rule list; +} + +type vernac_argument_ext = { + vernacargext_name : string; + vernacargext_printer : code option; + vernacargext_rules : tactic_rule list; +} + +type argument_type = +| ListArgType of argument_type +| OptArgType of argument_type +| PairArgType of argument_type * argument_type +| ExtraArgType of string + +type argument_ext = { + argext_name : string; + argext_rules : tactic_rule list; + argext_type : argument_type option; + argext_interp : code option; + argext_glob : code option; + argext_subst : code option; + argext_rprinter : code option; + argext_gprinter : code option; + argext_tprinter : code option; +} + type node = | Code of code | Comment of string | DeclarePlugin of string | GramExt of grammar_ext -| VernacExt +| VernacExt of vernac_ext +| VernacArgumentExt of vernac_argument_ext | TacticExt of tactic_ext +| ArgumentExt of argument_ext type t = node list diff --git a/coqpp/coqpp_lex.mll b/coqpp/coqpp_lex.mll index 81a53e887b..cdea4b99ef 100644 --- a/coqpp/coqpp_lex.mll +++ b/coqpp/coqpp_lex.mll @@ -95,12 +95,24 @@ rule extend = parse | "{" { start_ocaml lexbuf; ocaml lexbuf } | "GRAMMAR" { GRAMMAR } | "VERNAC" { VERNAC } +| "COMMAND" { COMMAND } | "TACTIC" { TACTIC } | "EXTEND" { EXTEND } | "END" { END } | "DECLARE" { DECLARE } | "PLUGIN" { PLUGIN } | "DEPRECATED" { DEPRECATED } +| "CLASSIFIED" { CLASSIFIED } +| "PRINTED" { PRINTED } +| "TYPED" { TYPED } +| "INTERPRETED" { INTERPRETED } +| "GLOBALIZED" { GLOBALIZED } +| "SUBSTITUTED" { SUBSTITUTED } +| "ARGUMENT" { ARGUMENT } +| "RAW_PRINTED" { RAW_PRINTED } +| "GLOB_PRINTED" { GLOB_PRINTED } +| "BY" { BY } +| "AS" { AS } (** Camlp5 specific keywords *) | "GLOBAL" { GLOBAL } | "FIRST" { FIRST } @@ -122,12 +134,14 @@ rule extend = parse | ']' { RBRACKET } | '|' { PIPE } | "->" { ARROW } +| "=>" { FUN } | ',' { COMMA } | ':' { COLON } | ';' { SEMICOLON } | '(' { LPAREN } | ')' { RPAREN } | '=' { EQUAL } +| '*' { STAR } | _ { lex_error lexbuf "syntax error" } | eof { EOF } diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index d9fff46d88..5314806c24 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -14,6 +14,9 @@ let fatal msg = let () = Format.eprintf "Error: %s@\n%!" msg in exit 1 +let dummy_loc = { loc_start = Lexing.dummy_pos; loc_end = Lexing.dummy_pos } +let mk_code s = { code = s; loc = dummy_loc } + let pr_loc loc = let file = loc.loc_start.pos_fname in let line = loc.loc_start.pos_lnum in @@ -64,9 +67,49 @@ let string_split s = let plugin_name = "__coq_plugin_name" +let print_list fmt pr l = + let rec prl fmt = function + | [] -> () + | [x] -> fprintf fmt "%a" pr x + | x :: l -> fprintf fmt "%a;@ %a" pr x prl l + in + fprintf fmt "@[<hv>[%a]@]" prl l + +let rec print_binders fmt = function +| [] -> () +| ExtTerminal _ :: rem -> print_binders fmt rem +| ExtNonTerminal (_, TokNone) :: rem -> + fprintf fmt "_@ %a" print_binders rem +| ExtNonTerminal (_, TokName id) :: rem -> + fprintf fmt "%s@ %a" id print_binders rem + +let rec print_symbol fmt = function +| Ulist1 s -> + fprintf fmt "@[Extend.TUlist1 (%a)@]" print_symbol s +| Ulist1sep (s, sep) -> + fprintf fmt "@[Extend.TUlist1sep (%a, \"%s\")@]" print_symbol s sep +| Ulist0 s -> + fprintf fmt "@[Extend.TUlist0 (%a)@]" print_symbol s +| Ulist0sep (s, sep) -> + fprintf fmt "@[Extend.TUlist0sep (%a, \"%s\")@]" print_symbol s sep +| Uopt s -> + fprintf fmt "@[Extend.TUopt (%a)@]" print_symbol s +| Uentry e -> + fprintf fmt "@[Extend.TUentry (Genarg.get_arg_tag wit_%s)@]" e +| Uentryl (e, l) -> + assert (e = "tactic"); + fprintf fmt "@[Extend.TUentryl (Genarg.get_arg_tag wit_%s, %i)@]" e l + +let print_string fmt s = fprintf fmt "\"%s\"" s + +let print_opt fmt pr = function +| None -> fprintf fmt "None" +| Some x -> fprintf fmt "Some@ @[(%a)@]" pr x + module GramExt : sig +val print_extrule : Format.formatter -> (symb list * string option list * code) -> unit val print_ast : Format.formatter -> grammar_ext -> unit end = @@ -102,20 +145,6 @@ let print_local fmt ext = let () = List.iter iter locals in fprintf fmt "in@ " -let print_string fmt s = fprintf fmt "\"%s\"" s - -let print_list fmt pr l = - let rec prl fmt = function - | [] -> () - | [x] -> fprintf fmt "%a" pr x - | x :: l -> fprintf fmt "%a;@ %a" pr x prl l - in - fprintf fmt "@[<hv>[%a]@]" prl l - -let print_opt fmt pr = function -| None -> fprintf fmt "None" -| Some x -> fprintf fmt "Some@ (%a)" pr x - let print_position fmt pos = match pos with | First -> fprintf fmt "Extend.First" | Last -> fprintf fmt "Extend.Last" @@ -128,16 +157,6 @@ let print_assoc fmt = function | RightA -> fprintf fmt "Extend.RightA" | NonA -> fprintf fmt "Extend.NonA" -type symb = -| SymbToken of string * string option -| SymbEntry of string * string option -| SymbSelf -| SymbNext -| SymbList0 of symb * symb option -| SymbList1 of symb * symb option -| SymbOpt of symb -| SymbRules of ((string option * symb) list * code) list - let is_token s = match string_split s with | [s] -> is_uident s | _ -> false @@ -207,9 +226,12 @@ let print_tok fmt = function let rec print_prod fmt p = let (vars, tkns) = List.split p.gprod_symbs in - let f = (vars, p.gprod_body) in - let tkn = List.rev_map parse_tokens tkns in - fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" print_symbols tkn print_fun f + let tkn = List.map parse_tokens tkns in + print_extrule fmt (tkn, vars, p.gprod_body) + +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) and print_symbols fmt = function | [] -> fprintf fmt "Extend.Stop" @@ -246,6 +268,8 @@ and print_symbol fmt tkn = match tkn with in let pr fmt rules = print_list fmt pr rules in fprintf fmt "(Extend.Arules %a)" pr (List.rev rules) +| SymbQuote c -> + fprintf fmt "(%s)" c let print_rule fmt r = let pr_lvl fmt lvl = print_opt fmt print_string lvl in @@ -268,6 +292,66 @@ let print_ast fmt ext = end +module VernacExt : +sig + +val print_ast : Format.formatter -> vernac_ext -> unit + +end = +struct + +let print_rule_classifier fmt r = match r.vernac_class with +| None -> fprintf fmt "None" +| Some f -> + let no_binder = function ExtTerminal _ -> true | ExtNonTerminal _ -> false in + if List.for_all no_binder r.vernac_toks then + fprintf fmt "Some @[%a@]" print_code f + else + fprintf fmt "Some @[(fun %a-> %a)@]" print_binders r.vernac_toks print_code f + +let print_body fmt r = + fprintf fmt "@[(fun %a~atts@ ~st@ -> let () = %a in st)@]" + print_binders r.vernac_toks print_code r.vernac_body + +let rec print_sig fmt = function +| [] -> fprintf fmt "@[Vernacentries.TyNil@]" +| ExtTerminal s :: rem -> + fprintf fmt "@[Vernacentries.TyTerminal (\"%s\", %a)@]" s print_sig rem +| ExtNonTerminal (symb, _) :: rem -> + fprintf fmt "@[Vernacentries.TyNonTerminal (%a, %a)@]" + print_symbol symb print_sig rem + +let print_rule fmt r = + fprintf fmt "Vernacentries.TyML (%b, %a, %a, %a)" + r.vernac_depr print_sig r.vernac_toks print_body r print_rule_classifier r + +let print_rules fmt rules = + print_list fmt (fun fmt r -> fprintf fmt "(%a)" print_rule r) rules + +let print_classifier fmt = function +| ClassifDefault -> fprintf fmt "" +| ClassifName "QUERY" -> + fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_query)" +| ClassifName "SIDEFF" -> + fprintf fmt "~classifier:(fun _ -> Vernac_classifier.classify_as_sideeff)" +| ClassifName s -> fatal (Printf.sprintf "Unknown classifier %s" s) +| ClassifCode c -> fprintf fmt "~classifier:(%s)" c.code + +let print_entry fmt = function +| None -> fprintf fmt "None" +| Some e -> fprintf fmt "(Some (%s))" e.code + +let print_ast fmt ext = + let pr fmt () = + fprintf fmt "Vernacentries.vernac_extend ~command:\"%s\" %a ?entry:%a %a" + ext.vernacext_name print_classifier ext.vernacext_class + print_entry ext.vernacext_entry print_rules ext.vernacext_rules + in + let () = fprintf fmt "let () = @[%a@]@\n" pr () in + () + +end + module TacticExt : sig @@ -276,50 +360,19 @@ val print_ast : Format.formatter -> tactic_ext -> unit end = struct -let rec print_symbol fmt = function -| Ulist1 s -> - fprintf fmt "@[Extend.TUlist1 (%a)@]" print_symbol s -| Ulist1sep (s, sep) -> - fprintf fmt "@[Extend.TUlist1sep (%a, \"%s\")@]" print_symbol s sep -| Ulist0 s -> - fprintf fmt "@[Extend.TUlist0 (%a)@]" print_symbol s -| Ulist0sep (s, sep) -> - fprintf fmt "@[Extend.TUlist0sep (%a, \"%s\")@]" print_symbol s sep -| Uopt s -> - fprintf fmt "@[Extend.TUopt (%a)@]" print_symbol s -| Uentry e -> - fprintf fmt "@[Extend.TUentry (Genarg.get_arg_tag wit_%s)@]" e -| Uentryl (e, l) -> - assert (e = "tactic"); - fprintf fmt "@[Extend.TUentryl (Genarg.get_arg_tag wit_%s, %i)@]" e l - let rec print_clause fmt = function -| [] -> fprintf fmt "@[TyNil@]" -| ExtTerminal s :: cl -> fprintf fmt "@[TyIdent (\"%s\", %a)@]" s print_clause cl -| ExtNonTerminal (g, TokNone) :: cl -> - fprintf fmt "@[TyAnonArg (%a, %a)@]" +| [] -> fprintf fmt "@[Tacentries.TyNil@]" +| ExtTerminal s :: cl -> fprintf fmt "@[Tacentries.TyIdent (\"%s\", %a)@]" s print_clause cl +| ExtNonTerminal (g, _) :: cl -> + fprintf fmt "@[Tacentries.TyArg (%a, %a)@]" print_symbol g print_clause cl -| ExtNonTerminal (g, TokName id) :: cl -> - fprintf fmt "@[TyArg (%a, \"%s\", %a)@]" - print_symbol g id print_clause cl - -let rec print_binders fmt = function -| [] -> fprintf fmt "ist@ " -| (ExtTerminal _ | ExtNonTerminal (_, TokNone)) :: rem -> print_binders fmt rem -| (ExtNonTerminal (_, TokName id)) :: rem -> - fprintf fmt "%s@ %a" id print_binders rem let print_rule fmt r = - fprintf fmt "@[TyML (%a, @[fun %a -> %a@])@]" + fprintf fmt "@[Tacentries.TyML (%a, @[(fun %aist@ -> %a)@])@]" print_clause r.tac_toks print_binders r.tac_toks print_code r.tac_body -let rec print_rules fmt = function -| [] -> () -| [r] -> fprintf fmt "(%a)@\n" print_rule r -| r :: rem -> fprintf fmt "(%a);@\n%a" print_rule r print_rules rem - let print_rules fmt rules = - fprintf fmt "Tacentries.([@[<v>%a@]])" print_rules rules + print_list fmt (fun fmt r -> fprintf fmt "(%a)" print_rule r) rules let print_ast fmt ext = let deprecation fmt = @@ -339,6 +392,161 @@ let print_ast fmt ext = end +module VernacArgumentExt : +sig + +val print_ast : Format.formatter -> vernac_argument_ext -> unit +val print_rules : Format.formatter -> string * tactic_rule list -> unit + +end = +struct + +let terminal s = + let c = Printf.sprintf "Extend.Atoken (CLexer.terminal \"%s\")" s in + SymbQuote c + +let rec parse_symb self = function +| Ulist1 s -> SymbList1 (parse_symb self s, None) +| Ulist1sep (s, sep) -> SymbList1 (parse_symb self s, Some (terminal sep)) +| Ulist0 s -> SymbList0 (parse_symb self s, None) +| Ulist0sep (s, sep) -> SymbList0 (parse_symb self s, Some (terminal sep)) +| Uopt s -> SymbOpt (parse_symb self s) +| Uentry e -> if e = self then SymbSelf else SymbEntry (e, None) +| Uentryl (e, l) -> + assert (e = "tactic"); + if l = 5 then SymbEntry ("Pltac.binder_tactic", None) + else SymbEntry ("Pltac.tactic_expr", Some (string_of_int l)) + +let parse_token self = function +| ExtTerminal s -> (terminal s, None) +| ExtNonTerminal (e, TokNone) -> (parse_symb self e, None) +| ExtNonTerminal (e, TokName s) -> (parse_symb self e, Some s) + +let parse_rule self r = + let symbs = List.map (fun t -> parse_token self t) r.tac_toks in + let symbs, vars = List.split symbs in + (symbs, vars, r.tac_body) + +let print_rules fmt (name, rules) = + (** Rules are reversed. *) + let rules = List.rev rules in + let rules = List.map (fun r -> parse_rule name r) rules in + let pr fmt l = print_list fmt (fun fmt r -> fprintf fmt "(%a)" GramExt.print_extrule r) l in + match rules with + | [([SymbEntry (e, None)], [Some s], { code = c } )] when String.trim c = s -> + (** This is a horrible hack to work aroud limitations of camlp5 regarding + factorization of parsing rules. It allows to recognize rules of the + form [ entry(x) ] -> [ x ] so as not to generate a proxy entry and + reuse the same entry directly. *) + fprintf fmt "@[Vernacentries.Arg_alias (%s)@]" e + | _ -> fprintf fmt "@[Vernacentries.Arg_rules (%a)@]" pr rules + +let print_printer fmt = function +| None -> fprintf fmt "@[fun _ -> Pp.str \"missing printer\"@]" +| Some f -> print_code fmt f + +let print_ast fmt arg = + let name = arg.vernacargext_name in + let pr fmt () = + fprintf fmt "Vernacentries.vernac_argument_extend ~name:%a @[{@\n\ + Vernacentries.arg_parsing = %a;@\n\ + Vernacentries.arg_printer = %a;@\n}@]" + print_string name print_rules (name, arg.vernacargext_rules) + print_printer arg.vernacargext_printer + in + fprintf fmt "let (wit_%s, %s) = @[%a@]@\nlet _ = (wit_%s, %s)@\n" + name name pr () name name + +end + +module ArgumentExt : +sig + +val print_ast : Format.formatter -> argument_ext -> unit + +end = +struct + +let rec print_argtype fmt = function +| ExtraArgType s -> + fprintf fmt "Geninterp.val_tag (Genarg.topwit wit_%s)" s +| PairArgType (arg1, arg2) -> + fprintf fmt "Geninterp.Val.Pair (@[(%a)@], @[(%a)@])" print_argtype arg1 print_argtype arg2 +| ListArgType arg -> + fprintf fmt "Geninterp.Val.List @[(%a)@]" print_argtype arg +| OptArgType arg -> + fprintf fmt "Geninterp.Val.Opt @[(%a)@]" print_argtype arg + +let rec print_wit fmt = function +| ExtraArgType s -> + fprintf fmt "wit_%s" s +| PairArgType (arg1, arg2) -> + fprintf fmt "Genarg.PairArg (@[(%a)@], @[(%a)@])" print_wit arg1 print_wit arg2 +| ListArgType arg -> + fprintf fmt "Genarg.ListArg @[(%a)@]" print_wit arg +| OptArgType arg -> + fprintf fmt "Genarg.OptArg @[(%a)@]" print_wit arg + +let print_ast fmt arg = + let name = arg.argext_name in + let pr_tag fmt t = print_opt fmt print_argtype t in + let intern fmt () = match arg.argext_glob, arg.argext_type with + | Some f, (None | Some _) -> + fprintf fmt "@[Tacentries.ArgInternFun ((fun f ist v -> (ist, f ist v)) (%a))@]" print_code f + | None, Some t -> + fprintf fmt "@[Tacentries.ArgInternWit (%a)@]" print_wit t + | None, None -> + fprintf fmt "@[Tacentries.ArgInternFun (fun ist v -> (ist, v))@]" + in + let subst fmt () = match arg.argext_subst, arg.argext_type with + | Some f, (None | Some _) -> + fprintf fmt "@[Tacentries.ArgSubstFun (%a)@]" print_code f + | None, Some t -> + fprintf fmt "@[Tacentries.ArgSubstWit (%a)@]" print_wit t + | None, None -> + fprintf fmt "@[Tacentries.ArgSubstFun (fun s v -> v)@]" + in + let interp fmt () = match arg.argext_interp, arg.argext_type with + | Some f, (None | Some _) -> + fprintf fmt "@[Tacentries.ArgInterpLegacy (%a)@]" print_code f + | None, Some t -> + fprintf fmt "@[Tacentries.ArgInterpWit (%a)@]" print_wit t + | None, None -> + fprintf fmt "@[Tacentries.ArgInterpRet@]" + in + let default_printer = mk_code "fun _ _ _ _ -> Pp.str \"missing printer\"" in + let rpr = match arg.argext_rprinter, arg.argext_tprinter with + | Some f, (None | Some _) -> f + | None, Some f -> f + | None, None -> default_printer + in + let gpr = match arg.argext_gprinter, arg.argext_tprinter with + | Some f, (None | Some _) -> f + | None, Some f -> f + | None, None -> default_printer + in + let tpr = match arg.argext_tprinter with + | Some f -> f + | None -> default_printer + in + let pr fmt () = + fprintf fmt "Tacentries.argument_extend ~name:%a @[{@\n\ + Tacentries.arg_parsing = %a;@\n\ + Tacentries.arg_tag = @[%a@];@\n\ + Tacentries.arg_intern = @[%a@];@\n\ + Tacentries.arg_subst = @[%a@];@\n\ + Tacentries.arg_interp = @[%a@];@\n\ + Tacentries.arg_printer = @[((%a), (%a), (%a))@];@\n}@]" + print_string name + VernacArgumentExt.print_rules (name, arg.argext_rules) + pr_tag arg.argext_type + intern () subst () interp () print_code rpr print_code gpr print_code tpr + in + fprintf fmt "let (wit_%s, %s) = @[%a@]@\nlet _ = (wit_%s, %s)@\n" + name name pr () name name + +end + let declare_plugin fmt name = fprintf fmt "let %s = \"%s\"@\n" plugin_name name; fprintf fmt "let _ = Mltop.add_known_module %s@\n" plugin_name @@ -348,8 +556,10 @@ let pr_ast fmt = function | Comment s -> fprintf fmt "%s@\n" s | DeclarePlugin name -> declare_plugin fmt name | GramExt gram -> fprintf fmt "%a@\n" GramExt.print_ast gram -| VernacExt -> fprintf fmt "VERNACEXT@\n" +| VernacExt vernac -> fprintf fmt "%a@\n" VernacExt.print_ast vernac +| VernacArgumentExt arg -> fprintf fmt "%a@\n" VernacArgumentExt.print_ast arg | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac +| ArgumentExt arg -> fprintf fmt "%a@\n" ArgumentExt.print_ast arg let () = let () = diff --git a/coqpp/coqpp_parse.mly b/coqpp/coqpp_parse.mly index bf435fd247..1fb5461b21 100644 --- a/coqpp/coqpp_parse.mly +++ b/coqpp/coqpp_parse.mly @@ -43,7 +43,7 @@ let parse_user_entry s sep = | [] -> let () = without_sep ignore sep () in begin match starts s "tactic" with - | Some ("0"|"1"|"2"|"3"|"4"|"5") -> Uentryl ("tactic", int_of_string s) + | Some ("0"|"1"|"2"|"3"|"4"|"5" as s) -> Uentryl ("tactic", int_of_string s) | Some _ | None -> Uentry s end | (pat1, pat2, k) :: rem -> @@ -62,8 +62,10 @@ let parse_user_entry s sep = %token <string> IDENT QUALID %token <string> STRING %token <int> INT -%token VERNAC TACTIC GRAMMAR EXTEND END DECLARE PLUGIN DEPRECATED -%token LBRACKET RBRACKET PIPE ARROW COMMA EQUAL +%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 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 @@ -92,6 +94,7 @@ node: | grammar_extend { $1 } | vernac_extend { $1 } | tactic_extend { $1 } +| argument_extend { $1 } ; declare_plugin: @@ -103,8 +106,126 @@ grammar_extend: { GramExt { gramext_name = $3; gramext_globals = $4; gramext_entries = $5 } } ; +argument_extend: +| ARGUMENT EXTEND IDENT + typed_opt + printed_opt + interpreted_opt + globalized_opt + substituted_opt + raw_printed_opt + glob_printed_opt + tactic_rules + END + { ArgumentExt { + argext_name = $3; + argext_rules = $11; + argext_rprinter = $9; + argext_gprinter = $10; + argext_tprinter = $5; + argext_interp = $6; + argext_glob = $7; + argext_subst = $8; + argext_type = $4; + } } +| VERNAC ARGUMENT EXTEND IDENT printed_opt tactic_rules END + { VernacArgumentExt { + vernacargext_name = $4; + vernacargext_printer = $5; + vernacargext_rules = $6; + } } +; + +printed_opt: +| { None } +| PRINTED BY CODE { Some $3 } +; + +raw_printed_opt: +| { None } +| RAW_PRINTED BY CODE { Some $3 } +; + +glob_printed_opt: +| { None } +| GLOB_PRINTED BY CODE { Some $3 } +; + +interpreted_opt: +| { None } +| INTERPRETED BY CODE { Some $3 } +; + +globalized_opt: +| { None } +| GLOBALIZED BY CODE { Some $3 } +; + +substituted_opt: +| { None } +| SUBSTITUTED BY CODE { Some $3 } +; + +typed_opt: +| { None } +| TYPED AS argtype { Some $3 } +; + +argtype: +| IDENT { ExtraArgType $1 } +| argtype IDENT { + match $2 with + | "list" -> ListArgType $1 + | "option" -> OptArgType $1 + | _ -> raise Parsing.Parse_error + } +| LPAREN argtype STAR argtype RPAREN { PairArgType ($2, $4) } +; + vernac_extend: -| VERNAC EXTEND IDENT END { VernacExt } +| VERNAC vernac_entry EXTEND IDENT vernac_classifier vernac_rules END + { VernacExt { + vernacext_name = $4; + vernacext_entry = $2; + vernacext_class = $5; + vernacext_rules = $6; + } } +; + +vernac_entry: +| COMMAND { None } +| CODE { Some $1 } +; + +vernac_classifier: +| { ClassifDefault } +| CLASSIFIED BY CODE { ClassifCode $3 } +| CLASSIFIED AS IDENT { ClassifName $3 } +; + +vernac_rules: +| vernac_rule { [$1] } +| vernac_rule vernac_rules { $1 :: $2 } +; + +vernac_rule: +| PIPE LBRACKET ext_tokens RBRACKET rule_deprecation rule_classifier ARROW CODE + { { + vernac_toks = $3; + vernac_depr = $5; + vernac_class= $6; + vernac_body = $8; + } } +; + +rule_deprecation: +| { false } +| DEPRECATED { true } +; + +rule_classifier: +| { None } +| FUN CODE { Some $2 } ; tactic_extend: diff --git a/default.nix b/default.nix index 1faaafae03..61f434efe6 100644 --- a/default.nix +++ b/default.nix @@ -75,6 +75,11 @@ stdenv.mkDerivation rec { (path: _: !elem (baseNameOf path) [".git" "result" "bin" "_build" "_build_ci"]) ./.; + preConfigure = '' + patchShebangs kernel/ + patchShebangs dev/tools/ + ''; + prefixKey = "-prefix "; buildFlags = [ "world" "byte" ] ++ optional buildDoc "doc-html"; @@ -82,11 +87,16 @@ stdenv.mkDerivation rec { installTargets = [ "install" "install-byte" ] ++ optional buildDoc "install-doc-html"; + createFindlibDestdir = !shell; + + postInstall = "ln -s $out/lib/coq $OCAMLFIND_DESTDIR/coq"; + inherit doInstallCheck; preInstallCheck = '' patchShebangs tools/ patchShebangs test-suite/ + export OCAMLPATH=$OCAMLFIND_DESTDIR:$OCAMLPATH ''; installCheckTarget = [ "check" ]; diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 58bbb7229f..60436e672c 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -8,11 +8,6 @@ wget -qO- "${sf_lf_CI_TARURL}" | tar xvz wget -qO- "${sf_plf_CI_TARURL}" | tar xvz wget -qO- "${sf_vfa_CI_TARURL}" | tar xvz -sed -i.bak '1i From Coq Require Extraction.' lf/Extraction.v -sed -i.bak '1i From Coq Require Extraction.' vfa/Extract.v - -( cd lf && make clean && make ) - -( cd plf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make ) - +( cd lf && make clean && make ) +( cd plf && make clean && make ) ( cd vfa && make clean && make ) diff --git a/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh b/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh new file mode 100644 index 0000000000..b3a9f67e00 --- /dev/null +++ b/dev/ci/user-overlays/08704-ejgallego-vernac+monify_hook.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "8704" ] || [ "$CI_BRANCH" = "vernac+monify_hook" ]; then + + # ltac2_CI_REF=rm-section-path + # ltac2_CI_GITURL=https://github.com/maximedenes/ltac2 + + plugin_tutorial_CI_REF=vernac+monify_hook + plugin_tutorial_CI_GITURL=https://github.com/ejgallego/plugin_tutorials + + Elpi_CI_REF=vernac+monify_hook + Elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + Equations_CI_REF=vernac+monify_hook + Equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/doc/build-system.dune.md b/dev/doc/build-system.dune.md index 7349360be8..91ab57f1e9 100644 --- a/dev/doc/build-system.dune.md +++ b/dev/doc/build-system.dune.md @@ -107,6 +107,17 @@ global options --- such as flags --- on all packages, or build Coq with different OPAM switches simultaneously [for example to test compatibility]; for more information, please refer to the Dune manual. +## Inlining reports + +The `ireport` profile will produce standard OCaml [inlining +reports](https://caml.inria.fr/pub/docs/manual-ocaml/flambda.html#sec488). These +are to be found under `_build/default/$lib/$lib.objs/$module.$round.inlining.org` +and are in Emacs `org-mode` format. + +Note that due to https://github.com/ocaml/dune/issues/1401 , we must +perform a full rebuild each time as otherwise Dune will remove the +files. We hope to solve this in the future. + ## Documentation and test targets The documentation and test suite targets for Coq are still not diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 7e64f80ac5..eb5b9ee1d3 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -19,6 +19,19 @@ Names Constant.make3 has been removed, use Constant.make2 Constant.repr3 has been removed, use Constant.repr2 +Coqlib: + +- Most functions from the `Coqlib` module have been deprecated in favor of + `register_ref` and `lib_ref`. The first one is available through the + vernacular `Register` command; it binds a name to a constant. The second + command then enables to locate the registered constant through its name. The + name resolution is dynamic. + +Macros: + +- The RAW_TYPED AS and GLOB_TYPED AS stanzas of the ARGUMENT EXTEND macro are + deprecated. Use TYPED AS instead. + ## Changes between Coq 8.8 and Coq 8.9 ### ML API @@ -176,11 +189,73 @@ END #### VERNAC EXTEND -Not handled yet. +Steps to perform: +- replace the brackets enclosing OCaml code in actions and rule classifiers with + braces +- if not there yet, add a leading `|̀ to the first rule + +Handwritten classifiers declared through the `CLASSIFIED BY` statement are +considered OCaml code, so they also need to be wrapped in braces. + +For instance, code of the form: +``` +VERNAC COMMAND EXTEND my_command CLASSIFIED BY classifier + [ "foo" int(i) ] => [ classif' ] -> [ cmd1 i ] +| [ "bar" ] -> [ cmd2 ] +END +``` +should be turned into +``` +VERNAC COMMAND EXTEND my_command CLASSIFIED BY { classifier } +| [ "foo" int(i) ] => { classif' } -> { cmd1 i } +| [ "bar" ] -> { cmd2 } +END +``` #### ARGUMENT EXTEND -Not handled yet. +Steps to perform: +- replace the brackets enclosing OCaml code in actions with braces +- if not there yet, add a leading `|` to the first rule +- syntax of `TYPED AS` has been restricted not to accept compound generic + arguments as a literal, e.g. `foo_opt` should be rewritten into `foo option` + and similarly `foo_list` into `foo list`. +- parenthesis around pair types in `TYPED AS` are now mandatory +- `RAW_TYPED AS` and `GLOB_TYPED AS` clauses need to be removed + +`BY` clauses are considered OCaml code, and thus need to be wrapped in braces, +but not the `TYPED AS` clauses. + +For instance, code of the form: +``` +ARGUMENT EXTEND my_arg + TYPED AS int_opt + PRINTED BY printer + INTERPRETED BY interp_f + GLOBALIZED BY glob_f + SUBSTITUTED BY subst_f + RAW_TYPED AS int_opt + RAW_PRINTED BY raw_printer + GLOB_TYPED AS int_opt + GLOB_PRINTED BY glob_printer + [ "foo" int(i) ] -> [ my_arg1 i ] +| [ "bar" ] -> [ my_arg2 ] +END +``` +should be turned into +``` +ARGUMENT EXTEND my_arg + TYPED AS { int_opt } + PRINTED BY { printer } + INTERPRETED BY { interp_f } + GLOBALIZED BY { glob_f } + SUBSTITUTED BY { subst_f } + RAW_PRINTED BY { raw_printer } + GLOB_PRINTED BY { glob_printer } +| [ "foo" int(i) ] -> { my_arg1 i } +| [ "bar" ] -> { my_arg2 } +END +``` #### GEXTEND diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 1a8a816aaa..93b807d5e3 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -1,10 +1,6 @@ (lang dune 1.2) ; Add custom flags here. Default developer profile is `dev` -(env - (dev (flags :standard -rectypes -w -9-27-50+60)) - (release (flags :standard -rectypes))) - (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) (context (opam (switch 4.07.0))) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 8129a4a867..44d44ccc4b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -527,7 +527,7 @@ let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; GramNonTerminal - (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))] + (Loc.tag (rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr))] let _ = try @@ -543,7 +543,7 @@ let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; GramNonTerminal - (Loc.tag (Some (rawwit wit_constr),Extend.Aentry Pcoq.Constr.constr))] + (Loc.tag (rawwit wit_constr,Extend.Aentry Pcoq.Constr.constr))] (* Setting printer of unbound global reference *) open Names diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 3b9760f586..c0a57763b9 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -27,6 +27,13 @@ rationals ``Require Import Lqa`` and reals ``Require Import Lra``. generating a *proof cache* which makes it possible to rerun scripts even without `csdp`. +.. flag:: Simplex + + This option (set by default) instructs the decision procedures to + use the Simplex method for solving linear goals. If it is not set, + the decision procedures are using Fourier elimination. + + The tactics solve propositional formulas parameterized by atomic arithmetic expressions interpreted over a domain :math:`D` ∈ {ℤ, ℚ, ℝ}. The syntax of the formulas is the following: @@ -96,8 +103,7 @@ and checked to be :math:`-1`. .. tacn:: lra :name: lra - This tactic is searching for *linear* refutations using Fourier - elimination [#]_. As a result, this tactic explores a subset of the *Cone* + This tactic is searching for *linear* refutations. As a result, this tactic explores a subset of the *Cone* defined as :math:`\mathit{LinCone}(S) =\left\{ \left. \sum_{p \in S} \alpha_p \times p~\right|~\alpha_p \mbox{ are positive constants} \right\}` @@ -134,7 +140,7 @@ principle [#]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, *positivstellensatz* refutations are not even sufficient to decide linear *integer* arithmetic. The canonical example is :math:`2 * x = 1 -> \mathtt{False}` which is a theorem of :math:`\mathbb{Z}` but not a theorem of :math:`{\mathbb{R}}`. To remedy this -weakness, the `lia` tactic is using recursively a combination of: +weakness, the :tacn:`lia` tactic is using recursively a combination of: + linear *positivstellensatz* refutations; + cutting plane proofs; @@ -188,10 +194,10 @@ a proof. .. tacn:: nra :name: nra -This tactic is an *experimental* proof procedure for non-linear -arithmetic. The tactic performs a limited amount of non-linear -reasoning before running the linear prover of `lra`. This pre-processing -does the following: + This tactic is an *experimental* proof procedure for non-linear + arithmetic. The tactic performs a limited amount of non-linear + reasoning before running the linear prover of :tacn:`lra`. This pre-processing + does the following: + If the context contains an arithmetic expression of the form @@ -200,7 +206,7 @@ does the following: + For all pairs of hypotheses :math:`e_1 \ge 0`, :math:`e_2 \ge 0`, the context is enriched with :math:`e_1 \times e_2 \ge 0`. -After this pre-processing, the linear prover of `lra` searches for a +After this pre-processing, the linear prover of :tacn:`lra` searches for a proof by abstracting monomials by variables. `nia`: a proof procedure for non-linear integer arithmetic @@ -209,9 +215,9 @@ proof by abstracting monomials by variables. .. tacn:: nia :name: nia -This tactic is a proof procedure for non-linear integer arithmetic. -It performs a pre-processing similar to `nra`. The obtained goal is -solved using the linear integer prover `lia`. + This tactic is a proof procedure for non-linear integer arithmetic. + It performs a pre-processing similar to :tacn:`nra`. The obtained goal is + solved using the linear integer prover :tacn:`lia`. `psatz`: a proof procedure for non-linear arithmetic ---------------------------------------------------- @@ -219,22 +225,22 @@ solved using the linear integer prover `lia`. .. tacn:: psatz :name: psatz -This tactic explores the :math:`\mathit{Cone}` by increasing degrees – hence the -depth parameter :math:`n`. In theory, such a proof search is complete – if the -goal is provable the search eventually stops. Unfortunately, the -external oracle is using numeric (approximate) optimization techniques -that might miss a refutation. + This tactic explores the *Cone* by increasing degrees – hence the + depth parameter *n*. In theory, such a proof search is complete – if the + goal is provable the search eventually stops. Unfortunately, the + external oracle is using numeric (approximate) optimization techniques + that might miss a refutation. -To illustrate the working of the tactic, consider we wish to prove the -following Coq goal: + To illustrate the working of the tactic, consider we wish to prove the + following Coq goal: .. coqtop:: all - Require Import ZArith Psatz. - Open Scope Z_scope. - Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. - intro x. - psatz Z 2. + Require Import ZArith Psatz. + Open Scope Z_scope. + Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. + intro x. + psatz Z 2. As shown, such a goal is solved by ``intro x. psatz Z 2.``. The oracle returns the cone expression :math:`2 \times (x-1) + (\mathbf{x-1}) \times (\mathbf{x−1}) + -x^2` @@ -246,7 +252,6 @@ obtain :math:`-1`. By Theorem :ref:`Psatz <psatz_thm>`, the goal is valid. the `zify` tactic. .. [#] Sources and binaries can be found at https://projects.coin-or.org/Csdp .. [#] Variants deal with equalities and strict inequalities. -.. [#] More efficient linear programming techniques could equally be employed. .. [#] In practice, the oracle might fail to produce such a refutation. .. comment in original TeX: diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 71f01cbb17..d98b8641e9 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -193,8 +193,9 @@ html_theme = 'sphinx_rtd_theme' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the # documentation. -#html_theme_options = {} - +html_theme_options = { + 'collapse_navigation': False +} html_context = { 'display_github': True, 'github_user': 'coq', diff --git a/doc/sphinx/credits.html.rst b/doc/sphinx/credits.html.rst deleted file mode 100644 index 0b2b1c6ad1..0000000000 --- a/doc/sphinx/credits.html.rst +++ /dev/null @@ -1,7 +0,0 @@ -.. _credits: - -------- -Credits -------- - -.. include:: credits-contents.rst diff --git a/doc/sphinx/credits.latex.rst b/doc/sphinx/credits.latex.rst deleted file mode 100644 index 39101f9d52..0000000000 --- a/doc/sphinx/credits.latex.rst +++ /dev/null @@ -1,3 +0,0 @@ -.. _credits: - -.. include:: credits-contents.rst diff --git a/doc/sphinx/credits-contents.rst b/doc/sphinx/credits.rst index d1df0657aa..ffdc4f3ec6 100644 --- a/doc/sphinx/credits-contents.rst +++ b/doc/sphinx/credits.rst @@ -1,3 +1,7 @@ +------- +Credits +------- + Coq is a proof assistant for higher-order logic, allowing the development of computer programs consistent with their formal specification. It is the result of about ten years of research of the @@ -186,7 +190,7 @@ definitions of “inversion predicates”. | Credits: addendum for version 6.1 -================================= +--------------------------------- The present version 6.1 of |Coq| is based on the V5.10 architecture. It was ported to the new language Objective Caml by Bruno Barras. The @@ -223,7 +227,7 @@ Barras. | Credits: addendum for version 6.2 -================================= +--------------------------------- In version 6.2 of |Coq|, the parsing is done using camlp4, a preprocessor and pretty-printer for CAML designed by Daniel de Rauglaudre at INRIA. @@ -268,7 +272,7 @@ Loiseleur. | Credits: addendum for version 6.3 -================================= +--------------------------------- The main changes in version V6.3 were the introduction of a few new tactics and the extension of the guard condition for fixpoint @@ -301,7 +305,7 @@ Monin from CNET Lannion. | Credits: versions 7 -=================== +------------------- The version V7 is a new implementation started in September 1999 by Jean-Christophe Filliâtre. This is a major revision with respect to the @@ -390,7 +394,7 @@ J.-F. Monin from France Telecom R & D. | Credits: version 8.0 -==================== +-------------------- Coq version 8 is a major revision of the |Coq| proof assistant. First, the underlying logic is slightly different. The so-called *impredicativity* @@ -492,7 +496,7 @@ under the responsibility of Christine Paulin. | Credits: version 8.1 -==================== +-------------------- Coq version 8.1 adds various new functionalities. @@ -571,7 +575,7 @@ and Yale University. | Credits: version 8.2 -==================== +-------------------- Coq version 8.2 adds new features, new libraries and improves on many various aspects. @@ -665,7 +669,7 @@ the Coq-Club mailing list. | Credits: version 8.3 -==================== +-------------------- Coq version 8.3 is before all a transition version with refinements or extensions of the existing features and libraries and a new tactic nsatz @@ -739,7 +743,7 @@ Pierce for the excellent teaching materials they provided. | Credits: version 8.4 -==================== +-------------------- Coq version 8.4 contains the result of three long-term projects: a new modular library of arithmetic by Pierre Letouzey, a new proof engine by @@ -895,7 +899,7 @@ Eelis van der Weegen. | Credits: version 8.5 -==================== +-------------------- Coq version 8.5 contains the result of five specific long-term projects: @@ -1049,7 +1053,7 @@ Tankink. Maxime Dénès coordinated the release process. | Credits: version 8.6 -==================== +-------------------- Coq version 8.6 contains the result of refinements, stabilization of 8.5’s features and cleanups of the internals of the system. Over the @@ -1189,7 +1193,8 @@ Dénès to put together a |Coq| consortium. | Credits: version 8.7 -==================== +-------------------- + |Coq| version 8.7 contains the result of refinements, stabilization of features and cleanups of the internals of the system along with a few new features. The main user visible changes are: @@ -1294,8 +1299,7 @@ system, is now upcoming and will rely on Inria’s newly created Foundation. | Credits: version 8.8 -==================== - +-------------------- |Coq| version 8.8 contains the result of refinements and stabilization of features and deprecations, cleanups of the internals of the system along diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index cf12b57414..a652b9e1ca 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -1,13 +1,11 @@ -.. _introduction: - ========================== -Introduction +Introduction and Contents ========================== .. include:: introduction.rst -Table of contents ------------------ +Contents +-------- .. toctree:: :caption: Indexes @@ -82,9 +80,6 @@ Table of contents zebibliography -License -------- - .. include:: license.rst .. [#PG] Proof-General is available at https://proofgeneral.github.io/. diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index af757f8746..9e9eb330fe 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -2,26 +2,22 @@ The Coq Reference Manual ========================== +------------ Introduction ------------ .. include:: introduction.rst +.. include:: license.rst + .. [#PG] Proof-General is available at https://proofgeneral.github.io/. Optionally, you can enhance it with the minor mode Company-Coq :cite:`Pit16` (see https://github.com/cpitclaudel/company-coq). -Credits -------- - .. include:: credits.rst -License -------- - -.. include:: license.rst - +------------ The language ------------ @@ -33,6 +29,7 @@ The language language/cic language/module-system +---------------- The proof engine ---------------- @@ -45,6 +42,7 @@ The proof engine proof-engine/detailed-tactic-examples proof-engine/ssreflect-proof-language +--------------- User extensions --------------- @@ -53,6 +51,7 @@ User extensions user-extensions/syntax-extensions user-extensions/proof-schemes +--------------- Practical tools --------------- @@ -62,6 +61,7 @@ Practical tools practical-tools/utilities practical-tools/coqide +-------- Addendum -------- diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 5bb7bf542c..bcdf3277ad 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -44,7 +44,7 @@ are processed from a file. .. seealso:: :ref:`thecoqcommands`. How to read this book -===================== +--------------------- This is a Reference Manual, so it is not intended for continuous reading. We recommend using the various indexes to quickly locate the documentation @@ -90,7 +90,7 @@ Nonetheless, the manual has some structure that is explained below. solvers and tactics. See the table of contents for a complete list. List of additional documentation -================================ +-------------------------------- This manual does not contain all the documentation the user may need about |Coq|. Various informations can be found in the following documents: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 593afa8f20..8c82526f0c 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -1422,15 +1422,6 @@ using the keyword :cmd:`Qed`. #. One can also use :cmd:`Admitted` in place of :cmd:`Qed` to turn the current asserted statement into an axiom and exit the proof editing mode. -.. [1] - This is similar to the expression “*entry* :math:`\{` sep *entry* - :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* - :math:`)`\ \*” in the syntax of regular expressions. - -.. [2] - Except if the inductive type is empty in which case there is no - equation that can be used to infer the return type. - .. _gallina-attributes: Attributes @@ -1466,12 +1457,14 @@ the following attributes names are recognized: This attribute can trigger the following warnings: .. warn:: Tactic @qualid is deprecated since @string. @string. + :undocumented: .. warn:: Tactic Notation @qualid is deprecated since @string. @string. + :undocumented: -Here are a few examples: +.. example:: -.. coqtop:: all reset + .. coqtop:: all reset From Coq Require Program. #[program] Definition one : nat := S _. @@ -1486,3 +1479,12 @@ Here are a few examples: Proof. now foo. Abort. + +.. [1] + This is similar to the expression “*entry* :math:`\{` sep *entry* + :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* + :math:`)`\ \*” in the syntax of regular expressions. + +.. [2] + Except if the inductive type is empty in which case there is no + equation that can be used to infer the return type. diff --git a/doc/sphinx/license.rst b/doc/sphinx/license.rst index 232b04211c..55c6d988f0 100644 --- a/doc/sphinx/license.rst +++ b/doc/sphinx/license.rst @@ -1,3 +1,6 @@ +License +------- + This material (the Coq Reference Manual) may be distributed only subject to the terms and conditions set forth in the Open Publication License, v1.0 or later (the latest version is presently available at diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 19995520bb..7c78e1a50f 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -41,15 +41,17 @@ Building a |Coq| project with coq_makefile The majority of |Coq| projects are very similar: a collection of ``.v`` files and eventually some ``.ml`` ones (a |Coq| plugin). The main piece of metadata needed in order to build the project are the command line -options to ``coqc`` (e.g. ``-R``, ``-I``, see also: section -:ref:`command-line-options`). Collecting the list of files and options is the job -of the ``_CoqProject`` file. +options to ``coqc`` (e.g. ``-R``, ``Q``, ``-I``, see :ref:`command +line options <command-line-options>`). Collecting the list of files +and options is the job of the ``_CoqProject`` file. A simple example of a ``_CoqProject`` file follows: :: -R theories/ MyCode + -arg -w + -arg all theories/foo.v theories/bar.v -I src/ @@ -57,6 +59,11 @@ A simple example of a ``_CoqProject`` file follows: src/bazaux.ml src/qux_plugin.mlpack +where options ``-R``, ``-Q`` and ``-I`` are natively recognized, as well as +file names. The lines of the form ``-arg foo`` are used in order to tell +to literally pass an argument ``foo`` to ``coqc``: in the +example, this allows to pass the two-word option ``-w all`` (see +:ref:`command line options <command-line-options>`). Currently, both |CoqIDE| and Proof-General (version ≥ ``4.3pre``) understand ``_CoqProject`` files and invoke |Coq| with the desired options. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 46851050ac..c802f44ac1 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -632,16 +632,15 @@ How to enable diffs ``````````````````` .. opt:: Diffs %( "on" %| "off" %| "removed" %) + :name: Diffs - .. This ref doesn't work: :opt:`Set Diffs %( "on" %| "off" %| "removed" %)` - - The “on” option highlights added tokens in green, while the “removed” option - additionally reprints items with removed tokens in red. Unchanged tokens in - modified items are shown with pale green or red. (Colors are user-configurable.) + The “on” option highlights added tokens in green, while the “removed” option + additionally reprints items with removed tokens in red. Unchanged tokens in + modified items are shown with pale green or red. (Colors are user-configurable.) For coqtop, showing diffs can be enabled when starting coqtop with the -``-diffs on|off|removed`` command-line option or with the ``Set Diffs`` -command within Coq. You will need to provide the ``-color on|auto`` command-line option when +``-diffs on|off|removed`` command-line option or by setting the :opt:`Diffs` option +within Coq. You will need to provide the ``-color on|auto`` command-line option when you start coqtop in either case. Colors for coqtop can be configured by setting the ``COQ_COLORS`` environment diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index db9f04ba11..26f4ec6242 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -103,7 +103,7 @@ bindings_list`` where ``bindings_list`` may be of two different forms: .. exn:: Not the right number of missing arguments. -.. _occurencessets: +.. _occurrencessets: Occurrence sets and occurrence clauses ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1024,7 +1024,7 @@ Managing the local context This notation allows specifying which occurrences of :token:`term` have to be substituted in the context. The :n:`in @goal_occurrences` clause is an occurrence clause whose syntax and behavior are described in - :ref:`goal occurences <occurencessets>`. + :ref:`goal occurrences <occurrencessets>`. .. tacv:: set (@ident @binders := @term) {? in @goal_occurrences } @@ -1509,7 +1509,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This syntax is used for selecting which occurrences of :token:`term` the case analysis has to be done on. The :n:`in @goal_occurrences` clause is an occurrence clause whose syntax and behavior is described - in :ref:`occurences sets <occurencessets>`. + in :ref:`occurrences sets <occurrencessets>`. .. tacv:: destruct @term {? with @bindings_list } {? as @disj_conj_intro_pattern } {? eqn:@naming_intro_pattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } edestruct @term {? with @bindings_list } {? as @disj_conj_intro_pattern } {? eqn:@naming_intro_pattern } {? using @term {? with @bindings_list } } {? in @goal_occurrences } @@ -1659,7 +1659,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This syntax is used for selecting which occurrences of :n:`@term` the induction has to be carried on. The :n:`in @goal_occurrences` clause is an occurrence clause whose syntax and behavior is described in - :ref:`occurences sets <occurencessets>`. If variables or hypotheses not + :ref:`occurrences sets <occurrencessets>`. If variables or hypotheses not mentioning :n:`@term` in their type are listed in :n:`@goal_occurrences`, those are generalized as well in the statement to prove. @@ -3513,6 +3513,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is Info 1 auto with eqdec. .. cmdv:: Hint Cut @regexp + :name: Hint Cut .. warning:: @@ -3546,6 +3547,7 @@ The general command to add a hint to some databases :n:`{+ @ident}` is initial cut expression being `emp`. .. cmdv:: Hint Mode @qualid {* (+ | ! | -)} + :name: Hint Mode This sets an optional mode of use of the identifier :n:`@qualid`. When proof-search faces a goal that ends in an application of :n:`@qualid` to diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index be65ff7570..a69cf209c7 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -461,6 +461,7 @@ Requests to the environment .. note:: .. table:: Search Blacklist @string + :name: Search Blacklist Specifies a set of strings used to exclude lemmas from the results of :cmd:`Search`, :cmd:`SearchHead`, :cmd:`SearchPattern` and :cmd:`SearchRewrite` queries. A lemma whose @@ -1200,3 +1201,18 @@ scope of their effect. There are four kinds of commands: modifier extends the effect outside the module even when the command occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this category. + +.. _exposing-constants-to-ocaml-libraries: + +Exposing constants to OCaml libraries +---------------------------------------------------------------- + +.. cmd:: Register @qualid__1 as @qualid__2 + + This command exposes the constant :n:`@qualid__1` to OCaml libraries under + the name :n:`@qualid__2`. This constant can then be dynamically located + calling :n:`Coqlib.lib_ref "@qualid__2"`; i.e., there is no need to known + where is the constant defined (file, module, library, etc.). + + Due to its internal nature, this command is not for general use. It is meant + to appear only in standard libraries and in support libraries of plug-ins. diff --git a/doc/tools/Translator.tex b/doc/tools/Translator.tex index 3ee65d6f22..d8ac640f2a 100644 --- a/doc/tools/Translator.tex +++ b/doc/tools/Translator.tex @@ -490,7 +490,7 @@ to be applied are separated by a {\tt =>}. to turn implicit only the arguments that are {\em strictly} implicit (or rigid), i.e. that remains inferable whatever the other arguments are. For instance {\tt x} inferable from {\tt P x} is not strictly -inferable since it can disappears if {\tt P} is instanciated by a term +inferable since it can disappears if {\tt P} is instantiated by a term which erases {\tt x}. \begin{transbox} @@ -1,7 +1,15 @@ ; Default flags for all Coq libraries. (env - (dev (flags :standard -rectypes -w -9-27-50+60)) - (release (flags :standard -rectypes))) + (dev (flags :standard -rectypes -w -9-27-50+40+60)) + (release (flags :standard -rectypes) + (ocamlopt_flags -O3 -unbox-closures)) + (ireport (flags :standard -rectypes -w -9-27-50+40+60) + (ocamlopt_flags :standard -O3 -unbox-closures -inlining-report))) + +; The _ profile could help factoring the above, however it doesn't +; seem to work like we'd expect/like: +; +; (_ (flags :standard -rectypes))) ; Rules for coq_dune (rule @@ -26,3 +34,8 @@ (targets revision) (deps (:rev-script dev/tools/make_git_revision.sh)) (action (with-stdout-to revision (run %{rev-script})))) + +; Use summary.log as the target +(alias + (name runtest) + (deps test-suite/summary.log)) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index fc2189f870..13356627f0 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -579,7 +579,7 @@ let rec check_and_clear_in_constr env evdref err ids global c = has dependencies in another hyp of the context of ev and transitively remember the dependency *) let check id _ = - if occur_var_in_decl (Global.env ()) !evdref id h + if occur_var_in_decl env !evdref id h then raise (Depends id) in let () = Id.Map.iter check ri in diff --git a/engine/termops.ml b/engine/termops.ml index efe1525c9a..1244074d50 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -963,7 +963,7 @@ let collect_vars sigma c = let vars_of_global_reference env gr = let c, _ = Global.constr_of_global_in_context env gr in - vars_of_global (Global.env ()) c + vars_of_global env c (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 9c25dcfaba..b882d2164f 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -21,6 +21,13 @@ END let declare_str_items loc l = MLast.StDcl (loc, ploc_vala l) (* correspond to <:str_item< declare $list:l'$ end >> *) +let declare_arg loc s e = + declare_str_items loc [ + <:str_item< value ($lid:"wit_"^s$, $lid:s$) = $e$ >>; + (** Prevent the unused variable warning *) + <:str_item< value _ = ($lid:"wit_"^s$, $lid:s$) >>; + ] + let mk_extraarg loc s = <:expr< $lid:"wit_"^s$ >> let rec make_wit loc = function @@ -47,147 +54,100 @@ let make_act loc act pil = <:expr< (fun _ -> $make tl$) >> in make (List.rev pil) -let make_prod_item = function +let make_prod_item self = function | ExtTerminal s -> <:expr< Extend.Atoken (CLexer.terminal $mlexpr_of_string s$) >> + | ExtNonTerminal (Uentry e, _) when e = self -> <:expr< Extend.Aself >> | ExtNonTerminal (g, _) -> let base s = <:expr< $lid:s$ >> in mlexpr_of_prod_entry_key base g -let rec make_prod = function +let rec make_prod self = function | [] -> <:expr< Extend.Stop >> -| item :: prods -> <:expr< Extend.Next $make_prod prods$ $make_prod_item item$ >> +| item :: prods -> <:expr< Extend.Next $make_prod self prods$ $make_prod_item self item$ >> -let make_rule loc (prods,act) = - <:expr< Extend.Rule $make_prod (List.rev prods)$ $make_act loc act prods$ >> +let make_rule loc self (prods,act) = + <:expr< Extend.Rule $make_prod self (List.rev prods)$ $make_act loc act prods$ >> let is_ident x = function | <:expr< $lid:s$ >> -> (s : string) = x | _ -> false -let make_extend loc s cl wit = match cl with +let make_extend loc self cl = match cl with | [[ExtNonTerminal (Uentry e, Some id)], act] when is_ident id act -> (** Special handling of identity arguments by not redeclaring an entry *) - <:str_item< - value $lid:s$ = - let () = Pcoq.register_grammar $wit$ $lid:e$ in - $lid:e$ - >> + <:expr< Vernacentries.Arg_alias $lid:e$ >> | _ -> - let se = mlexpr_of_string s in - let rules = mlexpr_of_list (make_rule loc) (List.rev cl) in - <:str_item< - value $lid:s$ = - let $lid:s$ = Pcoq.create_generic_entry Pcoq.utactic $se$ (Genarg.rawwit $wit$) in - let () = Pcoq.grammar_extend $lid:s$ None (None, [(None, None, $rules$)]) in - $lid:s$ >> + <:expr< Vernacentries.Arg_rules $mlexpr_of_list (make_rule loc self) (List.rev cl)$ >> -let warning_redundant prefix s = - Printf.eprintf "Redundant [%sTYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" prefix s +let warning_deprecated prefix s = function +| None -> () +| Some _ -> + Printf.eprintf "Deprecated [%sTYPED AS] clause in [ARGUMENT EXTEND %s]. \ + Use [TYPED AS] instead.\n%!" prefix s -let get_type prefix s = function +let get_type s = function | None -> None | Some typ -> if is_self s typ then - let () = warning_redundant prefix s in None + let () = Printf.eprintf "Redundant [TYPED AS] clause in [ARGUMENT EXTEND %s].\n%!" s in + None else Some typ -let check_type prefix s = function -| None -> () -| Some _ -> warning_redundant prefix s - let declare_tactic_argument loc s (typ, f, g, h) cl = let se = mlexpr_of_string s in - let rawtyp, rawpr, globtyp, globpr, typ, pr = match typ with + let typ, pr = match typ with | `Uniform (typ, pr) -> - let typ = get_type "" s typ in - typ, pr, typ, pr, typ, pr + let typ = get_type s typ in + typ, <:expr< ($lid:pr$, $lid:pr$, $lid:pr$) >> | `Specialized (a, rpr, c, gpr, e, tpr) -> - (** Check that we actually need the TYPED AS arguments *) - let rawtyp = get_type "RAW_" s a in - let glbtyp = get_type "GLOB_" s c in - let toptyp = get_type "" s e in - let () = match g with None -> () | Some _ -> check_type "RAW_" s rawtyp in - let () = match f, h with Some _, Some _ -> check_type "GLOB_" s glbtyp | _ -> () in - rawtyp, rpr, glbtyp, gpr, toptyp, tpr + let () = warning_deprecated "RAW_" s a in + let () = warning_deprecated "GLOB_" s c in + let typ = get_type s e in + typ, <:expr< ($lid:rpr$, $lid:gpr$, $lid:tpr$) >> + in + let glob = match g, typ with + | Some f, (None | Some _) -> + <:expr< Tacentries.ArgInternFun (fun ist v -> (ist, $lid:f$ ist v)) >> + | None, Some typ -> + <:expr< Tacentries.ArgInternWit $make_wit loc typ$ >> + | None, None -> + <:expr< Tacentries.ArgInternFun (fun ist v -> (ist, v)) >> in - let glob = match g with - | None -> - begin match rawtyp with - | None -> <:expr< fun ist v -> (ist, v) >> - | Some rawtyp -> - <:expr< fun ist v -> - let ans = out_gen $make_globwit loc rawtyp$ - (Tacintern.intern_genarg ist - (Genarg.in_gen $make_rawwit loc rawtyp$ v)) in - (ist, ans) >> - end - | Some f -> - <:expr< fun ist v -> (ist, $lid:f$ ist v) >> + let interp = match f, typ with + | Some f, (None | Some _) -> + <:expr< Tacentries.ArgInterpLegacy $lid:f$ >> + | None, Some typ -> + <:expr< Tacentries.ArgInterpWit $make_wit loc typ$ >> + | None, None -> + <:expr< Tacentries.ArgInterpRet >> in - let interp = match f with - | None -> - begin match globtyp with - | None -> - let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in - <:expr< fun ist v -> Ftactic.return (Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v) >> - | Some globtyp -> - <:expr< fun ist x -> - Tacinterp.interp_genarg ist (Genarg.in_gen $make_globwit loc globtyp$ x) >> - end - | Some f -> - (** Compatibility layer, TODO: remove me *) - let typ = match globtyp with None -> ExtraArgType s | Some typ -> typ in - <:expr< - let f = $lid:f$ in - fun ist v -> Ftactic.enter (fun gl -> - let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in - let v = Geninterp.Val.inject (Geninterp.val_tag $make_topwit loc typ$) v in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) - ) - >> in - let subst = match h with - | None -> - begin match globtyp with - | None -> <:expr< fun s v -> v >> - | Some globtyp -> - <:expr< fun s x -> - out_gen $make_globwit loc globtyp$ - (Tacsubst.subst_genarg s - (Genarg.in_gen $make_globwit loc globtyp$ x)) >> - end - | Some f -> <:expr< $lid:f$>> in - let dyn = match typ with - | None -> <:expr< None >> - | Some typ -> <:expr< Some (Geninterp.val_tag $make_topwit loc typ$) >> + let subst = match h, typ with + | Some f, (None | Some _) -> + <:expr< Tacentries.ArgSubstFun $lid:f$ >> + | None, Some typ -> + <:expr< Tacentries.ArgSubstWit $make_wit loc typ$ >> + | None, None -> + <:expr< Tacentries.ArgSubstFun (fun s v -> v) >> in - let wit = <:expr< $lid:"wit_"^s$ >> in - declare_str_items loc - [ <:str_item< value ($lid:"wit_"^s$) = Genarg.make0 $se$ >>; - <:str_item< Genintern.register_intern0 $wit$ $glob$ >>; - <:str_item< Genintern.register_subst0 $wit$ $subst$ >>; - <:str_item< Geninterp.register_interp0 $wit$ $interp$ >>; - <:str_item< Geninterp.register_val0 $wit$ $dyn$ >>; - make_extend loc s cl wit; - <:str_item< do { - Pptactic.declare_extra_genarg_pprule - $wit$ $lid:rawpr$ $lid:globpr$ $lid:pr$; - Tacentries.create_ltac_quotation $se$ - (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit $wit$) v)) - ($lid:s$, None) - } >> ] + let dyn = mlexpr_of_option (fun typ -> <:expr< Geninterp.val_tag $make_topwit loc typ$ >>) typ in + declare_arg loc s <:expr< Tacentries.argument_extend ~{ name = $se$ } { + Tacentries.arg_parsing = $make_extend loc s cl$; + Tacentries.arg_tag = $dyn$; + Tacentries.arg_intern = $glob$; + Tacentries.arg_subst = $subst$; + Tacentries.arg_interp = $interp$; + Tacentries.arg_printer = $pr$ + } >> let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in - let wit = <:expr< $lid:"wit_"^s$ >> in let pr_rules = match pr with - | None -> <:expr< fun _ _ _ _ -> Pp.str $str:"[No printer for "^s^"]"$ >> - | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in - declare_str_items loc - [ <:str_item< - value ($lid:"wit_"^s$ : Genarg.genarg_type 'a unit unit) = - Genarg.create_arg $se$ >>; - make_extend loc s cl wit; - <:str_item< Pptactic.declare_extra_vernac_genarg_pprule $wit$ $pr_rules$ >> ] + | None -> <:expr< fun _ -> Pp.str $str:"[No printer for "^s^"]"$ >> + | Some pr -> <:expr< $lid:pr$ >> in + declare_arg loc s <:expr< Vernacentries.vernac_argument_extend ~{ name = $se$ } { + Vernacentries.arg_printer = $pr_rules$; + Vernacentries.arg_parsing = $make_extend loc s cl$ + } >> open Pcaml diff --git a/grammar/q_util.mli b/grammar/q_util.mli index f3af318b60..b163100fc3 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -50,3 +50,5 @@ val type_of_user_symbol : user_symbol -> argument_type val parse_user_entry : string -> string -> user_symbol val mlexpr_of_symbol : user_symbol -> MLast.expr + +val binders_of_tokens : MLast.expr -> extend_token list -> MLast.expr diff --git a/grammar/q_util.mlp b/grammar/q_util.mlp index 0e2bf55d86..a2007d258c 100644 --- a/grammar/q_util.mlp +++ b/grammar/q_util.mlp @@ -142,3 +142,9 @@ let rec mlexpr_of_symbol = function assert (e = "tactic"); let wit = <:expr< $lid:"wit_"^e$ >> in <:expr< Extend.TUentryl (Genarg.get_arg_tag $wit$) $mlexpr_of_int l$>> + +let rec binders_of_tokens e = function +| [] -> e +| ExtNonTerminal(_,None) :: cl -> <:expr< fun _ -> $binders_of_tokens e cl$ >> +| ExtNonTerminal(_,Some id) :: cl -> <:expr< fun $lid:id$ -> $binders_of_tokens e cl$ >> +| ExtTerminal _ :: cl -> binders_of_tokens e cl diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index 5943600b7c..a093f78388 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -20,16 +20,8 @@ let plugin_name = <:expr< __coq_plugin_name >> let rec mlexpr_of_clause = function | [] -> <:expr< TyNil >> | ExtTerminal s :: cl -> <:expr< TyIdent($str:s$, $mlexpr_of_clause cl$) >> -| ExtNonTerminal(g,None) :: cl -> - <:expr< TyAnonArg($mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> -| ExtNonTerminal(g,Some id) :: cl -> - <:expr< TyArg($mlexpr_of_symbol g$, $mlexpr_of_string id$, $mlexpr_of_clause cl$) >> - -let rec binders_of_clause e = function -| [] -> <:expr< fun ist -> $e$ >> -| ExtNonTerminal(_,None) :: cl -> binders_of_clause e cl -| ExtNonTerminal(_,Some id) :: cl -> <:expr< fun $lid:id$ -> $binders_of_clause e cl$ >> -| _ :: cl -> binders_of_clause e cl +| ExtNonTerminal (g, _) :: cl -> + <:expr< TyArg($mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> open Pcaml @@ -52,7 +44,8 @@ EXTEND tacrule: [ [ "["; l = LIST1 tacargs; "]"; "->"; "["; e = Pcaml.expr; "]" -> - <:expr< TyML($mlexpr_of_clause l$, $binders_of_clause e l$) >> + let e = <:expr< fun ist -> $e$ >> in + <:expr< TyML($mlexpr_of_clause l$, $binders_of_tokens e l$) >> ] ] ; diff --git a/grammar/vernacextend.mlp b/grammar/vernacextend.mlp index f30c96a7f5..3c401e827e 100644 --- a/grammar/vernacextend.mlp +++ b/grammar/vernacextend.mlp @@ -24,23 +24,16 @@ type rule = { (** Whether this entry is deprecated *) } -let rec make_patt r = function -| [] -> r -| ExtNonTerminal (_, Some p) :: l -> <:expr< fun $lid:p$ -> $make_patt r l$ >> -| ExtNonTerminal (_, None) :: l -> <:expr< fun _ -> $make_patt r l$ >> -| ExtTerminal _ :: l -> make_patt r l - let rec mlexpr_of_clause = function | [] -> <:expr< Vernacentries.TyNil >> | ExtTerminal s :: cl -> <:expr< Vernacentries.TyTerminal ($str:s$, $mlexpr_of_clause cl$) >> | ExtNonTerminal (g, id) :: cl -> - let id = mlexpr_of_option mlexpr_of_string id in - <:expr< Vernacentries.TyNonTerminal ($id$, $mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> + <:expr< Vernacentries.TyNonTerminal ($mlexpr_of_symbol g$, $mlexpr_of_clause cl$) >> let make_rule r = let ty = mlexpr_of_clause r.r_patt in - let cmd = make_patt r.r_branch r.r_patt in - let make_classifier c = make_patt c r.r_patt in + let cmd = binders_of_tokens r.r_branch r.r_patt in + let make_classifier c = binders_of_tokens c r.r_patt in let classif = mlexpr_of_option make_classifier r.r_class in <:expr< Vernacentries.TyML ($mlexpr_of_bool r.r_depr$, $ty$, $cmd$, $classif$) >> @@ -10,6 +10,8 @@ (executable (name fake_ide) + (public_name fake_ide) + (package coqide-server) (modules fake_ide) (libraries coqide-server.protocol coqide-server.core)) diff --git a/ide/nanoPG.ml b/ide/nanoPG.ml index 2be5dce426..002722ace9 100644 --- a/ide/nanoPG.ml +++ b/ide/nanoPG.ml @@ -189,7 +189,7 @@ let emacs = insert emacs "Emacs" [] [ run "Edit" "Cut"; { s with kill = Some(txt,false); sel = false } else s)); - mkE _k "k" "Kill untill the end of line" (Edit(fun s b i _ -> + mkE _k "k" "Kill until the end of line" (Edit(fun s b i _ -> let already_killed = match s.kill with Some (k,true) -> k | _ -> "" in let k = if i#ends_line then begin diff --git a/interp/constrintern.ml b/interp/constrintern.ml index d02f59414e..d7497d4e8e 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1863,12 +1863,11 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = Array.map (fun (bl,_,_) -> bl) idl, Array.map (fun (_,ty,_) -> ty) idl, Array.map (fun (_,_,bd) -> bd) idl) + | CProdN ([],c2) -> anomaly (Pp.str "The AST is malformed, found prod without binders.") | CProdN (bl,c2) -> let (env',bl) = List.fold_left intern_local_binder (env,[]) bl in expand_binders ?loc mkGProd bl (intern_type env' c2) - | CLambdaN ([],c2) -> - (* Such a term is built sometimes: it should not change scope *) - intern env c2 + | CLambdaN ([],c2) -> anomaly (Pp.str "The AST is malformed, found lambda without binders.") | CLambdaN (bl,c2) -> let (env',bl) = List.fold_left intern_local_binder (reset_tmp_scope env,[]) bl in expand_binders ?loc mkGLambda bl (intern env' c2) diff --git a/kernel/clambda.ml b/kernel/clambda.ml index c21ce22421..1e4dbfd418 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -764,7 +764,7 @@ and lambda_of_app env f args = and such, which can't be done at this time. for instance, for int31: if one of the digit is not closed, it's not impossible that the number - gets fully instanciated at run-time, thus to ensure + gets fully instantiated at run-time, thus to ensure uniqueness of the representation in the vm it is necessary to try and build a caml integer during the execution *) diff --git a/kernel/environ.ml b/kernel/environ.ml index dffcd70282..2fa33eb1cd 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -680,6 +680,16 @@ let remove_hyps ids check_context check_value ctxt = in fst (remove_hyps ctxt) +(* A general request *) + +let is_polymorphic env r = + let open Names.GlobRef in + match r with + | VarRef _id -> false + | ConstRef c -> polymorphic_constant c env + | IndRef ind -> polymorphic_ind ind env + | ConstructRef cstr -> polymorphic_ind (inductive_of_constructor cstr) env + (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module Safetyping, Environ only synchronizes the proactive and the reactive parts*) diff --git a/kernel/environ.mli b/kernel/environ.mli index 55ff7ff162..031e7968d7 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -315,7 +315,7 @@ val apply_to_hyp : named_context_val -> variable -> val remove_hyps : Id.Set.t -> (Constr.named_declaration -> Constr.named_declaration) -> (lazy_val -> lazy_val) -> named_context_val -> named_context_val - +val is_polymorphic : env -> Names.GlobRef.t -> bool open Retroknowledge (** functions manipulating the retroknowledge diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 820c5b3a2b..625b7e5073 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -168,6 +168,12 @@ let is_initial senv = let delta_of_senv senv = senv.modresolver,senv.paramresolver +let constant_of_delta_kn_senv senv kn = + Mod_subst.constant_of_deltas_kn senv.paramresolver senv.modresolver kn + +let mind_of_delta_kn_senv senv kn = + Mod_subst.mind_of_deltas_kn senv.paramresolver senv.modresolver kn + (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 0f150ea971..26fa91adbd 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -204,6 +204,9 @@ val exists_objlabel : Label.t -> safe_environment -> bool val delta_of_senv : safe_environment -> Mod_subst.delta_resolver * Mod_subst.delta_resolver +val constant_of_delta_kn_senv : safe_environment -> KerName.t -> Constant.t +val mind_of_delta_kn_senv : safe_environment -> KerName.t -> MutInd.t + (** {6 Retroknowledge / Native compiler } *) open Retroknowledge diff --git a/lib/future.ml b/lib/future.ml index 7a5b6f699b..b372bedc5d 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -49,7 +49,7 @@ end module UUIDMap = Map.Make(UUID) module UUIDSet = Set.Make(UUID) -type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] +type 'a assignment = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] (* Val is not necessarily a final state, so the computation restarts from the state stocked into Val *) @@ -103,7 +103,7 @@ let from_here ?(fix_exn=id) v = create fix_exn (Val v) let fix_exn_of ck = let _, _, fix_exn, _ = get ck in fix_exn let create_delegate ?(blocking=true) ~name fix_exn = - let assignement signal ck = fun v -> + let assignment signal ck = fun v -> let _, _, fix_exn, c = get ck in assert (match !c with Delegated _ -> true | _ -> false); begin match v with @@ -118,7 +118,7 @@ let create_delegate ?(blocking=true) ~name fix_exn = (fun () -> Mutex.lock lock; Condition.wait cond lock; Mutex.unlock lock), (fun () -> Mutex.lock lock; Condition.broadcast cond; Mutex.unlock lock) in let ck = create ~name fix_exn (Delegated wait) in - ck, assignement signal ck + ck, assignment signal ck (* TODO: get rid of try/catch to be stackless *) let rec compute ck : 'a value = diff --git a/lib/future.mli b/lib/future.mli index d9e8c87b21..55f05518b0 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -70,10 +70,10 @@ val fix_exn_of : 'a computation -> fix_exn (* Run remotely, returns the function to assign. If not blocking (the default) it raises NotReady if forced before the delegate assigns it. *) -type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] +type 'a assignment = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] val create_delegate : ?blocking:bool -> name:string -> - fix_exn -> 'a computation * ('a assignement -> unit) + fix_exn -> 'a computation * ('a assignment -> unit) (* Given a computation that is_exn, replace it by another one *) val replace : 'a computation -> 'a computation -> unit diff --git a/library/coqlib.ml b/library/coqlib.ml index e71de4d77e..677515981a 100644 --- a/library/coqlib.ml +++ b/library/coqlib.ml @@ -16,29 +16,68 @@ open Libnames open Globnames open Nametab -let coq = Libnames.coq_string (* "Coq" *) +let make_dir l = DirPath.make (List.rev_map Id.of_string l) (************************************************************************) -(* Generic functions to find Coq objects *) +(* Coq reference API *) +(************************************************************************) +let coq = Libnames.coq_string (* "Coq" *) -type message = string +let init_dir = [ coq; "Init"] -let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let jmeq_module_name = [coq;"Logic";"JMeq"] +let jmeq_library_path = make_dir jmeq_module_name +let jmeq_module = MPfile jmeq_library_path let find_reference locstr dir s = let dp = make_dir dir in let sp = Libnames.make_path dp (Id.of_string s) in - try Nametab.global_of_path sp - with Not_found -> - (* Following bug 5066 we are more permissive with the handling - of not found errors here *) - user_err ~hdr:locstr - Pp.(str "cannot find " ++ Libnames.pr_path sp ++ - str "; maybe library " ++ DirPath.print dp ++ - str " has to be required first.") + Nametab.global_of_path sp let coq_reference locstr dir s = find_reference locstr (coq::dir) s +let table : GlobRef.t CString.Map.t ref = + let name = "coqlib_registered" in + Summary.ref ~name CString.Map.empty + +let get_lib_refs () = + CString.Map.bindings !table + +let has_ref s = CString.Map.mem s !table + +let check_ind_ref s ind = + match CString.Map.find s !table with + | IndRef r -> eq_ind r ind + | _ -> false + | exception Not_found -> false + +let lib_ref s = + try CString.Map.find s !table + with Not_found -> + user_err Pp.(str "not found in table: " ++ str s) + +let add_ref s c = + table := CString.Map.add s c !table + +let cache_ref (_,(s,c)) = + add_ref s c + +let (inCoqlibRef : string * GlobRef.t -> Libobject.obj) = + let open Libobject in + declare_object { (default_object "COQLIBREF") with + cache_function = cache_ref; + load_function = (fun _ x -> cache_ref x); + classify_function = (fun o -> Substitute o); + subst_function = ident_subst_function; + discharge_function = fun (_, sc) -> Some sc } + +(** Replaces a binding ! *) +let register_ref s c = + Lib.add_anonymous_leaf @@ inCoqlibRef (s,c) + +(************************************************************************) +(* Generic functions to find Coq objects *) + let has_suffix_in_dirs dirs ref = let dir = dirpath (path_of_global ref) in List.exists (fun d -> is_dirpath_prefix_of d dir) dirs @@ -74,25 +113,12 @@ let check_required_library d = | _ -> false in if not in_current_dir then -(* Loading silently ... - let m, prefix = List.sep_last d' in - read_library - (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) -*) -(* or failing ...*) user_err ~hdr:"Coqlib.check_required_library" (str "Library " ++ DirPath.print dir ++ str " has to be required first.") (************************************************************************) -(* Specific Coq objects *) - -let init_reference dir s = - let d = coq::"Init"::dir in - check_required_library d; find_reference "Coqlib" d s - -let logic_reference dir s = - let d = coq::"Logic"::dir in - check_required_library d; find_reference "Coqlib" d s +(* Specific Coq objects *) +(************************************************************************) let arith_dir = [coq;"Arith"] let arith_modules = [arith_dir] @@ -104,7 +130,6 @@ let zarith_dir = [coq;"ZArith"] let zarith_base_modules = [numbers_dir;parith_dir;narith_dir;zarith_dir] -let init_dir = [coq;"Init"] let init_modules = [ init_dir@["Datatypes"]; init_dir@["Logic"]; @@ -115,9 +140,6 @@ let init_modules = [ init_dir@["Wf"] ] -let prelude_module_name = init_dir@["Prelude"] -let prelude_module = make_dir prelude_module_name - let logic_module_name = init_dir@["Logic"] let logic_module = MPfile (make_dir logic_module_name) @@ -127,10 +149,6 @@ let logic_type_module = make_dir logic_type_module_name let datatypes_module_name = init_dir@["Datatypes"] let datatypes_module = MPfile (make_dir datatypes_module_name) -let jmeq_module_name = [coq;"Logic";"JMeq"] -let jmeq_library_path = make_dir jmeq_module_name -let jmeq_module = MPfile jmeq_library_path - (** Identity *) let id = Constant.make2 datatypes_module @@ Label.make "idProp" @@ -167,6 +185,7 @@ let glob_identity = IndRef (identity_kn,0) let jmeq_kn = MutInd.make2 jmeq_module @@ Label.make "JMeq" let glob_jmeq = IndRef (jmeq_kn,0) +(* Sigma data *) type coq_sigma_data = { proj1 : GlobRef.t; proj2 : GlobRef.t; @@ -174,39 +193,29 @@ type coq_sigma_data = { intro : GlobRef.t; typ : GlobRef.t } +let build_sigma_gen str = + { typ = lib_ref ("core." ^ str ^ ".type"); + elim = lib_ref ("core." ^ str ^ ".rect"); + intro = lib_ref ("core." ^ str ^ ".intro"); + proj1 = lib_ref ("core." ^ str ^ ".proj1"); + proj2 = lib_ref ("core." ^ str ^ ".proj2"); + } + +let build_prod () = build_sigma_gen "prod" +let build_sigma () = build_sigma_gen "sig" +let build_sigma_type () = build_sigma_gen "sigT" + +(* Booleans *) + type coq_bool_data = { andb : GlobRef.t; andb_prop : GlobRef.t; andb_true_intro : GlobRef.t} let build_bool_type () = - { andb = init_reference ["Datatypes"] "andb"; - andb_prop = init_reference ["Datatypes"] "andb_prop"; - andb_true_intro = init_reference ["Datatypes"] "andb_true_intro" } - -let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type.") - -let build_sigma_type () = - { proj1 = init_reference ["Specif"] "projT1"; - proj2 = init_reference ["Specif"] "projT2"; - elim = init_reference ["Specif"] "sigT_rect"; - intro = init_reference ["Specif"] "existT"; - typ = init_reference ["Specif"] "sigT" } - -let build_sigma () = - { proj1 = init_reference ["Specif"] "proj1_sig"; - proj2 = init_reference ["Specif"] "proj2_sig"; - elim = init_reference ["Specif"] "sig_rect"; - intro = init_reference ["Specif"] "exist"; - typ = init_reference ["Specif"] "sig" } - - -let build_prod () = - { proj1 = init_reference ["Datatypes"] "fst"; - proj2 = init_reference ["Datatypes"] "snd"; - elim = init_reference ["Datatypes"] "prod_rec"; - intro = init_reference ["Datatypes"] "pair"; - typ = init_reference ["Datatypes"] "prod" } + { andb = lib_ref "core.bool.andb"; + andb_prop = lib_ref "core.bool.andb_prop"; + andb_true_intro = lib_ref "core.bool.andb_true_intro"; } (* Equalities *) type coq_eq_data = { @@ -217,6 +226,24 @@ type coq_eq_data = { trans: GlobRef.t; congr: GlobRef.t } +(* Leibniz equality on Type *) + +let build_eqdata_gen lib str = + let _ = check_required_library lib in { + eq = lib_ref ("core." ^ str ^ ".type"); + ind = lib_ref ("core." ^ str ^ ".ind"); + refl = lib_ref ("core." ^ str ^ ".refl"); + sym = lib_ref ("core." ^ str ^ ".sym"); + trans = lib_ref ("core." ^ str ^ ".trans"); + congr = lib_ref ("core." ^ str ^ ".congr"); + } + +let build_coq_eq_data () = build_eqdata_gen logic_module_name "eq" +let build_coq_jmeq_data () = build_eqdata_gen jmeq_module_name "JMeq" +let build_coq_identity_data () = build_eqdata_gen datatypes_module_name "identity" + +(* Inversion data... *) + (* Data needed for discriminate and injection *) type coq_inversion_data = { inv_eq : GlobRef.t; (* : forall params, t -> Prop *) @@ -224,161 +251,75 @@ type coq_inversion_data = { inv_congr: GlobRef.t (* : forall params B (f:t->B) y, eq params y -> f c=f y *) } -let lazy_init_reference dir id = lazy (init_reference dir id) -let lazy_logic_reference dir id = lazy (logic_reference dir id) - -(* Leibniz equality on Type *) - -let coq_eq_eq = lazy_init_reference ["Logic"] "eq" -let coq_eq_refl = lazy_init_reference ["Logic"] "eq_refl" -let coq_eq_ind = lazy_init_reference ["Logic"] "eq_ind" -let coq_eq_congr = lazy_init_reference ["Logic"] "f_equal" -let coq_eq_sym = lazy_init_reference ["Logic"] "eq_sym" -let coq_eq_trans = lazy_init_reference ["Logic"] "eq_trans" -let coq_f_equal2 = lazy_init_reference ["Logic"] "f_equal2" -let coq_eq_congr_canonical = - lazy_init_reference ["Logic"] "f_equal_canonical_form" - -let build_coq_eq_data () = - let _ = check_required_library logic_module_name in { - eq = Lazy.force coq_eq_eq; - ind = Lazy.force coq_eq_ind; - refl = Lazy.force coq_eq_refl; - sym = Lazy.force coq_eq_sym; - trans = Lazy.force coq_eq_trans; - congr = Lazy.force coq_eq_congr } - -let build_coq_eq () = Lazy.force coq_eq_eq -let build_coq_eq_refl () = Lazy.force coq_eq_refl -let build_coq_eq_sym () = Lazy.force coq_eq_sym -let build_coq_f_equal2 () = Lazy.force coq_f_equal2 +let build_coq_inversion_gen l str = + List.iter check_required_library l; { + inv_eq = lib_ref ("core." ^ str ^ ".type"); + inv_ind = lib_ref ("core." ^ str ^ ".ind"); + inv_congr = lib_ref ("core." ^ str ^ ".congr_canonical"); + } let build_coq_inversion_eq_data () = - let _ = check_required_library logic_module_name in { - inv_eq = Lazy.force coq_eq_eq; - inv_ind = Lazy.force coq_eq_ind; - inv_congr = Lazy.force coq_eq_congr_canonical } - -(* Heterogenous equality on Type *) - -let coq_jmeq_eq = lazy_logic_reference ["JMeq"] "JMeq" -let coq_jmeq_hom = lazy_logic_reference ["JMeq"] "JMeq_hom" -let coq_jmeq_refl = lazy_logic_reference ["JMeq"] "JMeq_refl" -let coq_jmeq_ind = lazy_logic_reference ["JMeq"] "JMeq_ind" -let coq_jmeq_sym = lazy_logic_reference ["JMeq"] "JMeq_sym" -let coq_jmeq_congr = lazy_logic_reference ["JMeq"] "JMeq_congr" -let coq_jmeq_trans = lazy_logic_reference ["JMeq"] "JMeq_trans" -let coq_jmeq_congr_canonical = - lazy_logic_reference ["JMeq"] "JMeq_congr_canonical_form" - -let build_coq_jmeq_data () = - let _ = check_required_library jmeq_module_name in { - eq = Lazy.force coq_jmeq_eq; - ind = Lazy.force coq_jmeq_ind; - refl = Lazy.force coq_jmeq_refl; - sym = Lazy.force coq_jmeq_sym; - trans = Lazy.force coq_jmeq_trans; - congr = Lazy.force coq_jmeq_congr } - -let build_coq_inversion_jmeq_data () = - let _ = check_required_library logic_module_name in { - inv_eq = Lazy.force coq_jmeq_hom; - inv_ind = Lazy.force coq_jmeq_ind; - inv_congr = Lazy.force coq_jmeq_congr_canonical } - -(* Specif *) -let coq_sumbool = lazy_init_reference ["Specif"] "sumbool" - -let build_coq_sumbool () = Lazy.force coq_sumbool - -(* Equality on Type as a Type *) -let coq_identity_eq = lazy_init_reference ["Datatypes"] "identity" -let coq_identity_refl = lazy_init_reference ["Datatypes"] "identity_refl" -let coq_identity_ind = lazy_init_reference ["Datatypes"] "identity_ind" -let coq_identity_congr = lazy_init_reference ["Logic_Type"] "identity_congr" -let coq_identity_sym = lazy_init_reference ["Logic_Type"] "identity_sym" -let coq_identity_trans = lazy_init_reference ["Logic_Type"] "identity_trans" -let coq_identity_congr_canonical = lazy_init_reference ["Logic_Type"] "identity_congr_canonical_form" - -let build_coq_identity_data () = - let _ = check_required_library datatypes_module_name in { - eq = Lazy.force coq_identity_eq; - ind = Lazy.force coq_identity_ind; - refl = Lazy.force coq_identity_refl; - sym = Lazy.force coq_identity_sym; - trans = Lazy.force coq_identity_trans; - congr = Lazy.force coq_identity_congr } - -let build_coq_inversion_identity_data () = - let _ = check_required_library datatypes_module_name in - let _ = check_required_library logic_type_module_name in { - inv_eq = Lazy.force coq_identity_eq; - inv_ind = Lazy.force coq_identity_ind; - inv_congr = Lazy.force coq_identity_congr_canonical } - -(* Equality to true *) -let coq_eq_true_eq = lazy_init_reference ["Datatypes"] "eq_true" -let coq_eq_true_ind = lazy_init_reference ["Datatypes"] "eq_true_ind" -let coq_eq_true_congr = lazy_init_reference ["Logic"] "eq_true_congr" + build_coq_inversion_gen [logic_module_name] "eq" let build_coq_inversion_eq_true_data () = - let _ = check_required_library datatypes_module_name in - let _ = check_required_library logic_module_name in { - inv_eq = Lazy.force coq_eq_true_eq; - inv_ind = Lazy.force coq_eq_true_ind; - inv_congr = Lazy.force coq_eq_true_congr } + build_coq_inversion_gen [logic_module_name] "True" -(* The False proposition *) -let coq_False = lazy_init_reference ["Logic"] "False" - -(* The True proposition and its unique proof *) -let coq_True = lazy_init_reference ["Logic"] "True" -let coq_I = lazy_init_reference ["Logic"] "I" +let build_coq_inversion_identity_data () = + build_coq_inversion_gen [logic_module_name] "identity" -(* Connectives *) -let coq_not = lazy_init_reference ["Logic"] "not" -let coq_and = lazy_init_reference ["Logic"] "and" -let coq_conj = lazy_init_reference ["Logic"] "conj" -let coq_or = lazy_init_reference ["Logic"] "or" -let coq_ex = lazy_init_reference ["Logic"] "ex" -let coq_iff = lazy_init_reference ["Logic"] "iff" +(* This needs a special case *) +let build_coq_inversion_jmeq_data () = { + inv_eq = lib_ref "core.JMeq.hom"; + inv_ind = lib_ref "core.JMeq.ind"; + inv_congr = lib_ref "core.JMeq.congr_canonical"; +} -let coq_iff_left_proj = lazy_init_reference ["Logic"] "proj1" -let coq_iff_right_proj = lazy_init_reference ["Logic"] "proj2" +(* Specif *) +let build_coq_sumbool () = lib_ref "core.sumbool.type" -let coq_prod = lazy_init_reference ["Datatypes"] "prod" -let coq_pair = lazy_init_reference ["Datatypes"] "pair" +let build_coq_eq () = lib_ref "core.eq.type" +let build_coq_eq_refl () = lib_ref "core.eq.refl" +let build_coq_eq_sym () = lib_ref "core.eq.sym" +let build_coq_f_equal2 () = lib_ref "core.eq.congr2" (* Runtime part *) -let build_coq_True () = Lazy.force coq_True -let build_coq_I () = Lazy.force coq_I +let build_coq_True () = lib_ref "core.True.type" +let build_coq_I () = lib_ref "core.True.I" +let build_coq_identity () = lib_ref "core.identity.type" -let build_coq_False () = Lazy.force coq_False -let build_coq_not () = Lazy.force coq_not -let build_coq_and () = Lazy.force coq_and -let build_coq_conj () = Lazy.force coq_conj -let build_coq_or () = Lazy.force coq_or -let build_coq_ex () = Lazy.force coq_ex -let build_coq_iff () = Lazy.force coq_iff +let build_coq_eq_true () = lib_ref "core.eq_true.type" +let build_coq_jmeq () = lib_ref "core.JMeq.type" -let build_coq_iff_left_proj () = Lazy.force coq_iff_left_proj -let build_coq_iff_right_proj () = Lazy.force coq_iff_right_proj +let build_coq_prod () = lib_ref "core.prod.type" +let build_coq_pair () = lib_ref "core.prod.intro" -let build_coq_prod () = Lazy.force coq_prod -let build_coq_pair () = Lazy.force coq_pair +let build_coq_False () = lib_ref "core.False.type" +let build_coq_not () = lib_ref "core.not.type" +let build_coq_and () = lib_ref "core.and.type" +let build_coq_conj () = lib_ref "core.and.conj" +let build_coq_or () = lib_ref "core.or.type" +let build_coq_ex () = lib_ref "core.ex.type" +let build_coq_sig () = lib_ref "core.sig.type" +let build_coq_existT () = lib_ref "core.sigT.existT" +let build_coq_iff () = lib_ref "core.iff.type" +let build_coq_iff_left_proj () = lib_ref "core.iff.proj1" +let build_coq_iff_right_proj () = lib_ref "core.iff.proj2" (* The following is less readable but does not depend on parsing *) -let coq_eq_ref = lazy (init_reference ["Logic"] "eq") -let coq_identity_ref = lazy (init_reference ["Datatypes"] "identity") -let coq_jmeq_ref = lazy (find_reference "Coqlib" [coq;"Logic";"JMeq"] "JMeq") -let coq_eq_true_ref = lazy (find_reference "Coqlib" [coq;"Init";"Datatypes"] "eq_true") -let coq_existS_ref = lazy (anomaly (Pp.str "use coq_existT_ref.")) -let coq_existT_ref = lazy (init_reference ["Specif"] "existT") -let coq_exist_ref = lazy (init_reference ["Specif"] "exist") -let coq_not_ref = lazy (init_reference ["Logic"] "not") -let coq_False_ref = lazy (init_reference ["Logic"] "False") -let coq_sumbool_ref = lazy (init_reference ["Specif"] "sumbool") -let coq_sig_ref = lazy (init_reference ["Specif"] "sig") -let coq_or_ref = lazy (init_reference ["Logic"] "or") -let coq_iff_ref = lazy (init_reference ["Logic"] "iff") +let coq_eq_ref = Lazy.from_fun build_coq_eq +let coq_identity_ref = Lazy.from_fun build_coq_identity +let coq_jmeq_ref = Lazy.from_fun build_coq_jmeq +let coq_eq_true_ref = Lazy.from_fun build_coq_eq_true +let coq_existS_ref = Lazy.from_fun build_coq_existT +let coq_existT_ref = Lazy.from_fun build_coq_existT +let coq_exist_ref = Lazy.from_fun build_coq_ex +let coq_not_ref = Lazy.from_fun build_coq_not +let coq_False_ref = Lazy.from_fun build_coq_False +let coq_sumbool_ref = Lazy.from_fun build_coq_sumbool +let coq_sig_ref = Lazy.from_fun build_coq_sig +let coq_or_ref = Lazy.from_fun build_coq_or +let coq_iff_ref = Lazy.from_fun build_coq_iff + +(** Deprecated functions that search by library name. *) +let build_sigma_set () = anomaly (Pp.str "Use build_sigma_type.") diff --git a/library/coqlib.mli b/library/coqlib.mli index 6a3d0953cd..351a0a7e84 100644 --- a/library/coqlib.mli +++ b/library/coqlib.mli @@ -10,92 +10,164 @@ open Util open Names -open Libnames -(** This module collects the global references, constructions and - patterns of the standard library used in ocaml files *) +(** Indirection between logical names and global references. -(** The idea is to migrate to rebindable name-based approach, thus the - only function this FILE will provide will be: + This module provides a mechanism to bind “names” to constants and to look up + these constants using their names. - [find_reference : string -> global_reference] + The two main functions are [register_ref n r] which binds the name [n] to + the reference [r] and [lib_ref n] which returns the previously registered + reference under name [n]. - such that [find_reference "core.eq.type"] returns the proper [global_reference] + The first function is meant to be available through the vernacular command + [Register r as n], so that plug-ins can refer to a constant without knowing + its user-facing name, the precise module path in which it is defined, etc. - [bind_reference : string -> global_reference -> unit] + For instance, [lib_ref "core.eq.type"] returns the proper [GlobRef.t] for + the type of the core equality type. +*) - will bind a reference. +(** Registers a global reference under the given name. *) +val register_ref : string -> GlobRef.t -> unit - A feature based approach would be possible too. +(** Retrieves the reference bound to the given name (by a previous call to {!register_ref}). + Raises an error if no reference is bound to this name. *) +val lib_ref : string -> GlobRef.t - Contrary to the old approach of raising an anomaly, we expect - tactics to gracefully fail in the absence of some primitive. +(** Checks whether a name refers to a registered constant. + For any name [n], if [has_ref n] returns [true], [lib_ref n] will succeed. *) +val has_ref : string -> bool - This is work in progress, see below. -*) +(** Checks whether a name is bound to a known inductive. *) +val check_ind_ref : string -> inductive -> bool + +(** List of all currently bound names. *) +val get_lib_refs : unit -> (string * GlobRef.t) list + +(* Exceptions to deprecation *) + +(** {2 For Equality tactics} *) + +type coq_sigma_data = { + proj1 : GlobRef.t; + proj2 : GlobRef.t; + elim : GlobRef.t; + intro : GlobRef.t; + typ : GlobRef.t } + +val build_sigma_set : coq_sigma_data delayed +val build_sigma_type : coq_sigma_data delayed +val build_sigma : coq_sigma_data delayed + +type coq_eq_data = { + eq : GlobRef.t; + ind : GlobRef.t; + refl : GlobRef.t; + sym : GlobRef.t; + trans: GlobRef.t; + congr: GlobRef.t } + +val build_coq_eq_data : coq_eq_data delayed +val build_coq_identity_data : coq_eq_data delayed +val build_coq_jmeq_data : coq_eq_data delayed + +(* XXX: Some tactics special case JMeq, they should instead check for + the constant, not the module *) +(** For tactics/commands requiring vernacular libraries *) +val check_required_library : string list -> unit + +(* Used by obligations *) +val datatypes_module_name : string list + +(* Used by ind_schemes *) +val logic_module_name : string list + +(* Used by tactics *) +val jmeq_module_name : string list + + +(*************************************************************************) +(** {2 DEPRECATED} *) +(*************************************************************************) + +(** All the functions below are deprecated and should go away in the + next coq version ... *) -(** {6 ... } *) (** [find_reference caller_message [dir;subdir;...] s] returns a global reference to the name dir.subdir.(...).s; the corresponding module must have been required or in the process of being compiled so that it must be used lazily; it raises an anomaly with the given message if not found *) +val find_reference : string -> string list -> string -> GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] -type message = string - -val find_reference : message -> string list -> string -> GlobRef.t -val coq_reference : message -> string list -> string -> GlobRef.t - -(** For tactics/commands requiring vernacular libraries *) -val check_required_library : string list -> unit +(** This just prefixes find_reference with Coq... *) +val coq_reference : string -> string list -> string -> GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Search in several modules (not prefixed by "Coq") *) val gen_reference_in_modules : string->string list list-> string -> GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val arith_modules : string list list +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val zarith_base_modules : string list list +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val init_modules : string list list +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** {6 Global references } *) (** Modules *) -val prelude_module : DirPath.t - val logic_module : ModPath.t -val logic_module_name : string list +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val logic_type_module : DirPath.t - -val jmeq_module : ModPath.t -val jmeq_library_path : DirPath.t -val jmeq_module_name : string list - -val datatypes_module_name : string list +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Identity *) val id : Constant.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val type_of_id : Constant.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Natural numbers *) -val nat_path : full_path + +val nat_path : Libnames.full_path +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] + val glob_nat : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val path_of_O : constructor +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val path_of_S : constructor +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_O : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_S : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Booleans *) val glob_bool : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] + val path_of_true : constructor +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val path_of_false : constructor +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_true : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_false : GlobRef.t - +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Equality *) val glob_eq : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_identity : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val glob_jmeq : GlobRef.t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** {6 ... } *) (** Constructions and patterns related to Coq initial state are unknown @@ -108,46 +180,24 @@ val glob_jmeq : GlobRef.t type coq_bool_data = { andb : GlobRef.t; andb_prop : GlobRef.t; - andb_true_intro : GlobRef.t} -val build_bool_type : coq_bool_data delayed - -(** {6 For Equality tactics } *) -type coq_sigma_data = { - proj1 : GlobRef.t; - proj2 : GlobRef.t; - elim : GlobRef.t; - intro : GlobRef.t; - typ : GlobRef.t } - -val build_sigma_set : coq_sigma_data delayed -val build_sigma_type : coq_sigma_data delayed -val build_sigma : coq_sigma_data delayed + andb_true_intro : GlobRef.t +} -(* val build_sigma_type_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) -(* val build_sigma_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) -(* val build_prod_in : Environ.env -> coq_sigma_data Univ.in_universe_context_set *) -(* val build_coq_eq_data_in : Environ.env -> coq_eq_data Univ.in_universe_context_set *) +val build_bool_type : coq_bool_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Non-dependent pairs in Set from Datatypes *) val build_prod : coq_sigma_data delayed - -type coq_eq_data = { - eq : GlobRef.t; - ind : GlobRef.t; - refl : GlobRef.t; - sym : GlobRef.t; - trans: GlobRef.t; - congr: GlobRef.t } - -val build_coq_eq_data : coq_eq_data delayed - -val build_coq_identity_data : coq_eq_data delayed -val build_coq_jmeq_data : coq_eq_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_eq : GlobRef.t delayed (** = [(build_coq_eq_data()).eq] *) +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_eq_refl : GlobRef.t delayed (** = [(build_coq_eq_data()).refl] *) +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_eq_sym : GlobRef.t delayed (** = [(build_coq_eq_data()).sym] *) +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_f_equal2 : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Data needed for discriminate and injection *) @@ -160,54 +210,85 @@ type coq_inversion_data = { } val build_coq_inversion_eq_data : coq_inversion_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_inversion_identity_data : coq_inversion_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_inversion_jmeq_data : coq_inversion_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_inversion_eq_true_data : coq_inversion_data delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Specif *) val build_coq_sumbool : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** {6 ... } *) (** Connectives The False proposition *) val build_coq_False : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** The True proposition and its unique proof *) val build_coq_True : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_I : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Negation *) val build_coq_not : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Conjunction *) val build_coq_and : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_conj : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_iff : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_iff_left_proj : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_iff_right_proj : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Pairs *) val build_coq_prod : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val build_coq_pair : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Disjunction *) val build_coq_or : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] (** Existential quantifier *) val build_coq_ex : GlobRef.t delayed +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_eq_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_identity_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_jmeq_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_eq_true_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_existS_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_existT_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_exist_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_not_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_False_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_sumbool_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_sig_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_or_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] val coq_iff_ref : GlobRef.t lazy_t +[@@ocaml.deprecated "Please use Coqlib.lib_ref"] diff --git a/library/global.ml b/library/global.ml index 0e236e6d34..769a4bea38 100644 --- a/library/global.ml +++ b/library/global.ml @@ -147,18 +147,10 @@ let body_of_constant cst = body_of_constant_body (lookup_constant cst) (** Operations on kernel names *) let constant_of_delta_kn kn = - let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ()) - in - (* TODO : are resolver and resolver_param orthogonal ? - the effect of resolver is lost if resolver_param isn't - trivial at that spot. *) - Mod_subst.constant_of_deltas_kn resolver_param resolver kn + Safe_typing.constant_of_delta_kn_senv (safe_env ()) kn let mind_of_delta_kn kn = - let resolver,resolver_param = Safe_typing.delta_of_senv (safe_env ()) - in - (* TODO idem *) - Mod_subst.mind_of_deltas_kn resolver_param resolver kn + Safe_typing.mind_of_delta_kn_senv (safe_env ()) kn (** Operations on libraries *) @@ -235,13 +227,7 @@ let universes_of_global env r = let universes_of_global gr = universes_of_global (env ()) gr -let is_polymorphic r = - let env = env() in - match r with - | VarRef id -> false - | ConstRef c -> Environ.polymorphic_constant c env - | IndRef ind -> Environ.polymorphic_ind ind env - | ConstructRef cstr -> Environ.polymorphic_ind (inductive_of_constructor cstr) env +let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = let env = env() in diff --git a/plugins/btauto/Reflect.v b/plugins/btauto/Reflect.v index d82e8ae8ad..4cde08872f 100644 --- a/plugins/btauto/Reflect.v +++ b/plugins/btauto/Reflect.v @@ -396,3 +396,16 @@ lazymatch goal with end | _ => fail "Cannot recognize a boolean equality" end. *) + +Register formula_var as plugins.btauto.f_var. +Register formula_btm as plugins.btauto.f_btm. +Register formula_top as plugins.btauto.f_top. +Register formula_cnj as plugins.btauto.f_cnj. +Register formula_dsj as plugins.btauto.f_dsj. +Register formula_neg as plugins.btauto.f_neg. +Register formula_xor as plugins.btauto.f_xor. +Register formula_ifb as plugins.btauto.f_ifb. + +Register formula_eval as plugins.btauto.eval. +Register boolean_witness as plugins.btauto.witness. +Register reduce_poly_of_formula_sound_alt as plugins.btauto.soundness. diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index b0f97c59b8..ac0a875229 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -12,17 +12,7 @@ open Constr let contrib_name = "btauto" -let init_constant dir s = - let find_constant contrib dir s = - UnivGen.constr_of_global (Coqlib.find_reference contrib dir s) - in - find_constant contrib_name dir s - -let get_constant dir s = lazy (UnivGen.constr_of_global @@ Coqlib.coq_reference contrib_name dir s) - -let get_inductive dir s = - let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in - Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) +let bt_lib_constr n = lazy (UnivGen.constr_of_global @@ Coqlib.lib_ref n) let decomp_term sigma (c : Constr.t) = Constr.kind (EConstr.Unsafe.to_constr (Termops.strip_outer_cast sigma (EConstr.of_constr c))) @@ -31,11 +21,11 @@ let lapp c v = Constr.mkApp (Lazy.force c, v) let (===) = Constr.equal + module CoqList = struct - let path = ["Init"; "Datatypes"] - let typ = get_constant path "list" - let _nil = get_constant path "nil" - let _cons = get_constant path "cons" + let typ = bt_lib_constr "core.list.type" + let _nil = bt_lib_constr "core.list.nil" + let _cons = bt_lib_constr "core.list.cons" let cons ty h t = lapp _cons [|ty; h ; t|] let nil ty = lapp _nil [|ty|] @@ -47,11 +37,10 @@ module CoqList = struct end module CoqPositive = struct - let path = ["Numbers"; "BinNums"] - let typ = get_constant path "positive" - let _xH = get_constant path "xH" - let _xO = get_constant path "xO" - let _xI = get_constant path "xI" + let typ = bt_lib_constr "num.pos.type" + let _xH = bt_lib_constr "num.pos.xH" + let _xO = bt_lib_constr "num.pos.xO" + let _xI = bt_lib_constr "num.pos.xI" (* A coq nat from an int *) let rec of_int n = @@ -91,14 +80,14 @@ end module Bool = struct - let typ = get_constant ["Init"; "Datatypes"] "bool" - let ind = get_inductive ["Init"; "Datatypes"] "bool" - let trueb = get_constant ["Init"; "Datatypes"] "true" - let falseb = get_constant ["Init"; "Datatypes"] "false" - let andb = get_constant ["Init"; "Datatypes"] "andb" - let orb = get_constant ["Init"; "Datatypes"] "orb" - let xorb = get_constant ["Init"; "Datatypes"] "xorb" - let negb = get_constant ["Init"; "Datatypes"] "negb" + let ind = lazy (Globnames.destIndRef (Coqlib.lib_ref "core.bool.type")) + let typ = bt_lib_constr "core.bool.type" + let trueb = bt_lib_constr "core.bool.true" + let falseb = bt_lib_constr "core.bool.false" + let andb = bt_lib_constr "core.bool.andb" + let orb = bt_lib_constr "core.bool.orb" + let xorb = bt_lib_constr "core.bool.xorb" + let negb = bt_lib_constr "core.bool.negb" type t = | Var of int @@ -150,21 +139,20 @@ module Btauto = struct open Pp - let eq = get_constant ["Init"; "Logic"] "eq" - - let f_var = get_constant ["btauto"; "Reflect"] "formula_var" - let f_btm = get_constant ["btauto"; "Reflect"] "formula_btm" - let f_top = get_constant ["btauto"; "Reflect"] "formula_top" - let f_cnj = get_constant ["btauto"; "Reflect"] "formula_cnj" - let f_dsj = get_constant ["btauto"; "Reflect"] "formula_dsj" - let f_neg = get_constant ["btauto"; "Reflect"] "formula_neg" - let f_xor = get_constant ["btauto"; "Reflect"] "formula_xor" - let f_ifb = get_constant ["btauto"; "Reflect"] "formula_ifb" + let eq = bt_lib_constr "core.eq.type" - let eval = get_constant ["btauto"; "Reflect"] "formula_eval" - let witness = get_constant ["btauto"; "Reflect"] "boolean_witness" + let f_var = bt_lib_constr "plugins.btauto.f_var" + let f_btm = bt_lib_constr "plugins.btauto.f_btm" + let f_top = bt_lib_constr "plugins.btauto.f_top" + let f_cnj = bt_lib_constr "plugins.btauto.f_cnj" + let f_dsj = bt_lib_constr "plugins.btauto.f_dsj" + let f_neg = bt_lib_constr "plugins.btauto.f_neg" + let f_xor = bt_lib_constr "plugins.btauto.f_xor" + let f_ifb = bt_lib_constr "plugins.btauto.f_ifb" - let soundness = get_constant ["btauto"; "Reflect"] "reduce_poly_of_formula_sound_alt" + let eval = bt_lib_constr "plugins.btauto.eval" + let witness = bt_lib_constr "plugins.btauto.witness" + let soundness = bt_lib_constr "plugins.btauto.soundness" let rec convert = function | Bool.Var n -> lapp f_var [|CoqPositive.of_int n|] diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 2eaa6146e1..055d36747d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -28,17 +28,13 @@ open Proofview.Notations module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let reference dir s = lazy (Coqlib.coq_reference "CC" dir s) - -let _f_equal = reference ["Init";"Logic"] "f_equal" -let _eq_rect = reference ["Init";"Logic"] "eq_rect" -let _refl_equal = reference ["Init";"Logic"] "eq_refl" -let _sym_eq = reference ["Init";"Logic"] "eq_sym" -let _trans_eq = reference ["Init";"Logic"] "eq_trans" -let _eq = reference ["Init";"Logic"] "eq" -let _False = reference ["Init";"Logic"] "False" -let _True = reference ["Init";"Logic"] "True" -let _I = reference ["Init";"Logic"] "I" +let _f_equal = lazy (Coqlib.lib_ref "core.eq.congr") +let _eq_rect = lazy (Coqlib.lib_ref "core.eq.rect") +let _refl_equal = lazy (Coqlib.lib_ref "core.eq.refl") +let _sym_eq = lazy (Coqlib.lib_ref "core.eq.sym") +let _trans_eq = lazy (Coqlib.lib_ref "core.eq.trans") +let _eq = lazy (Coqlib.lib_ref "core.eq.type") +let _False = lazy (Coqlib.lib_ref "core.False.type") let whd env sigma t = Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t @@ -423,7 +419,7 @@ let build_term_to_complete uf pac = let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - Coqlib.check_required_library Coqlib.logic_module_name; + Coqlib.(check_required_library logic_module_name); let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.mlg index a59324149c..18316bf2cd 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.mlg @@ -8,13 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Stdarg +} + DECLARE PLUGIN "derive_plugin" +{ + let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) -VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command +} + +VERNAC COMMAND EXTEND Derive CLASSIFIED BY { classify_derive_command } | [ "Derive" ident(f) "SuchThat" constr(suchthat) "As" ident(lemma) ] -> - [ Derive.start_deriving f suchthat lemma ] + { Derive.start_deriving f suchthat lemma } END diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.mlg index 93909f3e64..1445dffefa 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.mlg @@ -8,14 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pcoq.Prim +} + DECLARE PLUGIN "extraction_plugin" +{ + (* ML names *) open Ltac_plugin -open Genarg open Stdarg open Pp open Names @@ -24,23 +29,31 @@ open Extract_env let pr_mlname _ _ _ s = spc () ++ qs s +} + ARGUMENT EXTEND mlname TYPED AS string - PRINTED BY pr_mlname -| [ preident(id) ] -> [ id ] -| [ string(s) ] -> [ s ] + PRINTED BY { pr_mlname } +| [ preident(id) ] -> { id } +| [ string(s) ] -> { s } END +{ + let pr_int_or_id _ _ _ = function | ArgInt i -> int i | ArgId id -> Id.print id +} + ARGUMENT EXTEND int_or_id - PRINTED BY pr_int_or_id -| [ preident(id) ] -> [ ArgId (Id.of_string id) ] -| [ integer(i) ] -> [ ArgInt i ] + PRINTED BY { pr_int_or_id } +| [ preident(id) ] -> { ArgId (Id.of_string id) } +| [ integer(i) ] -> { ArgInt i } END +{ + let pr_language = function | Ocaml -> str "OCaml" | Haskell -> str "Haskell" @@ -52,117 +65,119 @@ let warn_deprecated_ocaml_spelling = (fun () -> strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\".")) +} + VERNAC ARGUMENT EXTEND language -PRINTED BY pr_language -| [ "Ocaml" ] -> [ let _ = warn_deprecated_ocaml_spelling () in Ocaml ] -| [ "OCaml" ] -> [ Ocaml ] -| [ "Haskell" ] -> [ Haskell ] -| [ "Scheme" ] -> [ Scheme ] -| [ "JSON" ] -> [ JSON ] +PRINTED BY { pr_language } +| [ "Ocaml" ] -> { let _ = warn_deprecated_ocaml_spelling () in Ocaml } +| [ "OCaml" ] -> { Ocaml } +| [ "Haskell" ] -> { Haskell } +| [ "Scheme" ] -> { Scheme } +| [ "JSON" ] -> { JSON } END (* Extraction commands *) VERNAC COMMAND EXTEND Extraction CLASSIFIED AS QUERY (* Extraction in the Coq toplevel *) -| [ "Extraction" global(x) ] -> [ simple_extraction x ] -| [ "Recursive" "Extraction" ne_global_list(l) ] -> [ full_extraction None l ] +| [ "Extraction" global(x) ] -> { simple_extraction x } +| [ "Recursive" "Extraction" ne_global_list(l) ] -> { full_extraction None l } (* Monolithic extraction to a file *) | [ "Extraction" string(f) ne_global_list(l) ] - -> [ full_extraction (Some f) l ] + -> { full_extraction (Some f) l } (* Extraction to a temporary file and OCaml compilation *) | [ "Extraction" "TestCompile" ne_global_list(l) ] - -> [ extract_and_compile l ] + -> { extract_and_compile l } END VERNAC COMMAND EXTEND SeparateExtraction CLASSIFIED AS QUERY (* Same, with content splitted in several files *) | [ "Separate" "Extraction" ne_global_list(l) ] - -> [ separate_extraction l ] + -> { separate_extraction l } END (* Modular extraction (one Coq library = one ML module) *) VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY | [ "Extraction" "Library" ident(m) ] - -> [ extraction_library false m ] + -> { extraction_library false m } END VERNAC COMMAND EXTEND RecursiveExtractionLibrary CLASSIFIED AS QUERY | [ "Recursive" "Extraction" "Library" ident(m) ] - -> [ extraction_library true m ] + -> { extraction_library true m } END (* Target Language *) VERNAC COMMAND EXTEND ExtractionLanguage CLASSIFIED AS SIDEFF | [ "Extraction" "Language" language(l) ] - -> [ extraction_language l ] + -> { extraction_language l } END VERNAC COMMAND EXTEND ExtractionInline CLASSIFIED AS SIDEFF (* Custom inlining directives *) | [ "Extraction" "Inline" ne_global_list(l) ] - -> [ extraction_inline true l ] + -> { extraction_inline true l } END VERNAC COMMAND EXTEND ExtractionNoInline CLASSIFIED AS SIDEFF | [ "Extraction" "NoInline" ne_global_list(l) ] - -> [ extraction_inline false l ] + -> { extraction_inline false l } END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> [Feedback. msg_info (print_extraction_inline ()) ] + -> {Feedback. msg_info (print_extraction_inline ()) } END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Inline" ] - -> [ reset_extraction_inline () ] + -> { reset_extraction_inline () } END VERNAC COMMAND EXTEND ExtractionImplicit CLASSIFIED AS SIDEFF (* Custom implicit arguments of some csts/inds/constructors *) | [ "Extraction" "Implicit" global(r) "[" int_or_id_list(l) "]" ] - -> [ extraction_implicit r l ] + -> { extraction_implicit r l } END VERNAC COMMAND EXTEND ExtractionBlacklist CLASSIFIED AS SIDEFF (* Force Extraction to not use some filenames *) | [ "Extraction" "Blacklist" ne_ident_list(l) ] - -> [ extraction_blacklist l ] + -> { extraction_blacklist l } END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> [ Feedback.msg_info (print_extraction_blacklist ()) ] + -> { Feedback.msg_info (print_extraction_blacklist ()) } END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF | [ "Reset" "Extraction" "Blacklist" ] - -> [ reset_extraction_blacklist () ] + -> { reset_extraction_blacklist () } END (* Overriding of a Coq object by an ML one *) VERNAC COMMAND EXTEND ExtractionConstant CLASSIFIED AS SIDEFF | [ "Extract" "Constant" global(x) string_list(idl) "=>" mlname(y) ] - -> [ extract_constant_inline false x idl y ] + -> { extract_constant_inline false x idl y } END VERNAC COMMAND EXTEND ExtractionInlinedConstant CLASSIFIED AS SIDEFF | [ "Extract" "Inlined" "Constant" global(x) "=>" mlname(y) ] - -> [ extract_constant_inline true x [] y ] + -> { extract_constant_inline true x [] y } END VERNAC COMMAND EXTEND ExtractionInductive CLASSIFIED AS SIDEFF | [ "Extract" "Inductive" global(x) "=>" mlname(id) "[" mlname_list(idl) "]" string_opt(o) ] - -> [ extract_inductive x id idl o ] + -> { extract_inductive x id idl o } END (* Show the extraction of the current proof *) VERNAC COMMAND EXTEND ShowExtraction CLASSIFIED AS QUERY | [ "Show" "Extraction" ] - -> [ show_extraction () ] + -> { show_extraction () } END diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.mlg index 7e54bc8adb..c41687e721 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.mlg @@ -8,6 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ open Ltac_plugin open Formula @@ -21,10 +22,14 @@ open Stdarg open Tacarg open Pcoq.Prim +} + DECLARE PLUGIN "ground_plugin" (* declaring search depth as a global option *) +{ + let ground_depth=ref 3 let _= @@ -65,22 +70,25 @@ let default_intuition_tac = let (set_default_solver, default_solver, print_default_solver) = Tactic_option.declare_tactic_option ~default:default_intuition_tac "Firstorder default solver" -VERNAC COMMAND FUNCTIONAL EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF -| [ "Set" "Firstorder" "Solver" tactic(t) ] -> [ - fun ~atts ~st -> let open Vernacinterp in +} + +VERNAC COMMAND EXTEND Firstorder_Set_Solver CLASSIFIED AS SIDEFF +| [ "Set" "Firstorder" "Solver" tactic(t) ] -> { + let open Vernacinterp in set_default_solver (Locality.make_section_locality atts.locality) - (Tacintern.glob_tactic t); - st - ] + (Tacintern.glob_tactic t) + } END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY -| [ "Print" "Firstorder" "Solver" ] -> [ +| [ "Print" "Firstorder" "Solver" ] -> { Feedback.msg_info - (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] + (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) } END +{ + let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") let gen_ground_tac flag taco ids bases = @@ -109,11 +117,11 @@ let gen_ground_tac flag taco ids bases = (* special for compatibility with Intuition -let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str +let constant str = Coqlib.get_constr str let defined_connectives=lazy - [[],EvalConstRef (destConst (constant "not")); - [],EvalConstRef (destConst (constant "iff"))] + [[],EvalConstRef (destConst (constant "core.not.type")); + [],EvalConstRef (destConst (constant "core.iff.type"))] let normalize_evaluables= onAllHypsAndConcl @@ -123,7 +131,6 @@ let normalize_evaluables= unfold_in_hyp (Lazy.force defined_connectives) (Tacexpr.InHypType id)) *) -open Genarg open Ppconstr open Printer let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid @@ -134,34 +141,33 @@ let warn_deprecated_syntax = CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated" (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator") +} ARGUMENT EXTEND firstorder_using - TYPED AS reference_list - PRINTED BY pr_firstorder_using_typed - RAW_TYPED AS reference_list - RAW_PRINTED BY pr_firstorder_using_raw - GLOB_TYPED AS reference_list - GLOB_PRINTED BY pr_firstorder_using_glob -| [ "using" reference(a) ] -> [ [a] ] -| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] -| [ "using" reference(a) reference(b) reference_list(l) ] -> [ + TYPED AS reference list + PRINTED BY { pr_firstorder_using_typed } + RAW_PRINTED BY { pr_firstorder_using_raw } + GLOB_PRINTED BY { pr_firstorder_using_glob } +| [ "using" reference(a) ] -> { [a] } +| [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> { a::l } +| [ "using" reference(a) reference(b) reference_list(l) ] -> { warn_deprecated_syntax (); a::b::l - ] -| [ ] -> [ [] ] + } +| [ ] -> { [] } END TACTIC EXTEND firstorder - [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l [] ] +| [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> + { gen_ground_tac true (Option.map (tactic_of_value ist) t) l [] } | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l ] + { gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l } | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> - [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l l' ] + { gen_ground_tac true (Option.map (tactic_of_value ist) t) l l' } END TACTIC EXTEND gintuition - [ "gintuition" tactic_opt(t) ] -> - [ gen_ground_tac false (Option.map (tactic_of_value ist) t) [] [] ] +| [ "gintuition" tactic_opt(t) ] -> + { gen_ground_tac false (Option.map (tactic_of_value ist) t) [] [] } END diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 3ae777cc9a..8fa676de44 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -234,11 +234,11 @@ let ll_forall_tac prod backtrack id continue seq= (* special for compatibility with old Intuition *) let constant str = UnivGen.constr_of_global - @@ Coqlib.coq_reference "User" ["Init";"Logic"] str + @@ Coqlib.lib_ref str -let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (Constr.destConst (constant "iff")))] +let defined_connectives = lazy + [AllOccurrences, EvalConstRef (fst (Constr.destConst (constant "core.not.type"))); + AllOccurrences, EvalConstRef (fst (Constr.destConst (constant "core.iff.type")))] let normalize_evaluables= Proofview.Goal.enter begin fun gl -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 5336948642..98d68d3db7 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -414,9 +414,9 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ()) in - let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ()) in - let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) in + let coq_False = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type") in + let coq_True = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.type") in + let coq_I = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.I") in let rec scan_type context type_of_hyp : tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in @@ -638,11 +638,11 @@ let my_orelse tac1 tac2 g = (* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g -let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = +let instantiate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = let args = Array.of_list (List.map mkVar args_id) in - let instanciate_one_hyp hid = + let instantiate_one_hyp hid = my_orelse - ( (* we instanciate the hyp if possible *) + ( (* we instantiate the hyp if possible *) fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in @@ -678,7 +678,7 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps; - tclMAP instanciate_one_hyp hyps; + tclMAP instantiate_one_hyp hyps; (fun g -> let all_g_hyps_id = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty @@ -722,11 +722,11 @@ let build_proof tclTHENLIST [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instanciate_partial = g'_nb_prod - g_nb_prod in + let nb_instantiate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case ptes_infos - nb_instanciate_partial + nb_instantiate_partial (build_proof do_finalize) t dyn_infos) @@ -760,7 +760,7 @@ let build_proof nb_rec_hyps = List.length new_hyps } in -(* observe_tac "Lambda" *) (instanciate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' +(* observe_tac "Lambda" *) (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' (* build_proof do_finalize new_infos g' *) ) g | _ -> @@ -1120,7 +1120,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in (full_params, (* real params *) princ_params, (* the params of the principle which are not params of the function *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl full_params) f_body ) @@ -1130,7 +1130,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let f_body = compose_lam f_ctxt_other f_body in (princ_info.params, (* real params *) [],(* all params are full params *) - substl (* function instanciated with real params *) + substl (* function instantiated with real params *) (List.map var_of_decl princ_info.params) f_body ) @@ -1321,7 +1321,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) (* ); *) - (* observe_tac "instancing" *) (instanciate_hyps_with_args prove_tac + (* observe_tac "instancing" *) (instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id)) ] @@ -1371,7 +1371,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam do_prove dyn_infos in - instanciate_hyps_with_args prove_tac + instantiate_hyps_with_args prove_tac (List.rev_map id_of_decl princ_info.branches) (List.rev args_id) ] @@ -1605,7 +1605,7 @@ let prove_principle_for_gen match !tcc_lemma_ref with | Undefined -> user_err Pp.(str "No tcc proof !!") | Value lemma -> EConstr.of_constr lemma - | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_I ()) + | Not_needed -> EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.True.I") in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1728,8 +1728,8 @@ let prove_principle_for_gen ptes_info (body_info rec_hyps) in - (* observe_tac "instanciate_hyps_with_args" *) - (instanciate_hyps_with_args + (* observe_tac "instantiate_hyps_with_args" *) + (instantiate_hyps_with_args make_proof (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) (List.rev args_ids) diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.mlg index a2d31780dd..857215751a 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.mlg @@ -7,23 +7,28 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) + +{ + open Ltac_plugin open Util open Pp open Constrexpr open Indfun_common open Indfun -open Genarg open Stdarg open Tacarg open Tactypes -open Pcoq open Pcoq.Prim open Pcoq.Constr open Pltac +} + DECLARE PLUGIN "recdef_plugin" +{ + let pr_fun_ind_using prc prlc _ opt_c = match opt_c with | None -> mt () @@ -44,26 +49,27 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = let (_, b) = b env evd in spc () ++ hov 2 (str "using" ++ spc () ++ Miscprint.pr_with_bindings prc prlc b) +} ARGUMENT EXTEND fun_ind_using TYPED AS constr_with_bindings option - PRINTED BY pr_fun_ind_using_typed - RAW_TYPED AS constr_with_bindings_opt - RAW_PRINTED BY pr_fun_ind_using - GLOB_TYPED AS constr_with_bindings_opt - GLOB_PRINTED BY pr_fun_ind_using -| [ "using" constr_with_bindings(c) ] -> [ Some c ] -| [ ] -> [ None ] + PRINTED BY { pr_fun_ind_using_typed } + RAW_PRINTED BY { pr_fun_ind_using } + GLOB_PRINTED BY { pr_fun_ind_using } +| [ "using" constr_with_bindings(c) ] -> { Some c } +| [ ] -> { None } END TACTIC EXTEND newfuninv - [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> - [ +| [ "functional" "inversion" quantified_hypothesis(hyp) reference_opt(fname) ] -> + { Proofview.V82.tactic (Invfun.invfun hyp fname) - ] + } END +{ + let pr_intro_as_pat _prc _ _ pat = match pat with | Some pat -> @@ -75,56 +81,70 @@ let out_disjunctive = CAst.map (function | IntroAction (IntroOrAndPattern l) -> l | _ -> CErrors.user_err Pp.(str "Disjunctive or conjunctive intro pattern expected.")) -ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat -| [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] -| [] ->[ None ] +} + +ARGUMENT EXTEND with_names TYPED AS intropattern option PRINTED BY { pr_intro_as_pat } +| [ "as" simple_intropattern(ipat) ] -> { Some ipat } +| [] -> { None } END +{ + let functional_induction b c x pat = Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) +} TACTIC EXTEND newfunind - ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ +| ["functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + { let c = match cl with | [] -> assert false | [c] -> c | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl } END (***** debug only ***) TACTIC EXTEND snewfunind - ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> - [ +| ["soft" "functional" "induction" ne_constr_list(cl) fun_ind_using(princl) with_names(pat)] -> + { let c = match cl with | [] -> assert false | [c] -> c | c::cl -> EConstr.applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl } END +{ let pr_constr_comma_sequence prc _ _ = prlist_with_sep pr_comma prc +} + ARGUMENT EXTEND constr_comma_sequence' - TYPED AS constr_list - PRINTED BY pr_constr_comma_sequence -| [ constr(c) "," constr_comma_sequence'(l) ] -> [ c::l ] -| [ constr(c) ] -> [ [c] ] + TYPED AS constr list + PRINTED BY { pr_constr_comma_sequence } +| [ constr(c) "," constr_comma_sequence'(l) ] -> { c::l } +| [ constr(c) ] -> { [c] } END +{ + let pr_auto_using prc _prlc _prt = Pptactic.pr_auto_using prc +} + ARGUMENT EXTEND auto_using' - TYPED AS constr_list - PRINTED BY pr_auto_using -| [ "using" constr_comma_sequence'(l) ] -> [ l ] -| [ ] -> [ [] ] + TYPED AS constr list + PRINTED BY { pr_auto_using } +| [ "using" constr_comma_sequence'(l) ] -> { l } +| [ ] -> { [] } END +{ + module Gram = Pcoq.Gram module Vernac = Pvernac.Vernac_ module Tactic = Pltac @@ -137,23 +157,29 @@ let (wit_function_rec_definition_loc : function_rec_definition_loc_argtype Genar let function_rec_definition_loc = Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: function_rec_definition_loc ; function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> Loc.tag ~loc:!@loc g ]] + [ [ g = Vernac.rec_definition -> { Loc.tag ~loc g } ]] ; END +{ + let () = let raw_printer _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer +} + (* TASSI: n'importe quoi ! *) VERNAC COMMAND EXTEND Function - ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] - => [ let hard = List.exists (function +| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] + => { let hard = List.exists (function | _,((_,(_,(CMeasureRec _|CWfRec _)),_,_,_),_) -> true | _,((_,(_,CStructRec),_,_,_),_) -> false) recsl in match @@ -162,20 +188,25 @@ VERNAC COMMAND EXTEND Function with | Vernacexpr.VtSideff ids, _ when hard -> Vernacexpr.(VtStartProof ("Classic", GuaranteesOpacity, ids), VtLater) - | x -> x ] - -> [ do_generate_principle false (List.map snd recsl) ] + | x -> x } + -> { do_generate_principle false (List.map snd recsl) } END +{ + let pr_fun_scheme_arg (princ_name,fun_name,s) = Names.Id.print princ_name ++ str " :=" ++ spc() ++ str "Induction for " ++ Libnames.pr_qualid fun_name ++ spc() ++ str "Sort " ++ Termops.pr_sort_family s +} + VERNAC ARGUMENT EXTEND fun_scheme_arg -PRINTED BY pr_fun_scheme_arg -| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> [ (princ_name,fun_name,s) ] +PRINTED BY { pr_fun_scheme_arg } +| [ ident(princ_name) ":=" "Induction" "for" reference(fun_name) "Sort" sort_family(s) ] -> { (princ_name,fun_name,s) } END +{ let warning_error names e = let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in @@ -190,12 +221,13 @@ let warning_error names e = warn_cannot_define_principle (names,error) | _ -> raise e +} VERNAC COMMAND EXTEND NewFunctionalScheme - ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] - => [ Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater ] +| ["Functional" "Scheme" ne_fun_scheme_arg_list_sep(fas,"with") ] + => { Vernacexpr.VtSideff(List.map pi1 fas), Vernacexpr.VtLater } -> - [ + { begin try Functional_principles_types.build_scheme fas @@ -223,17 +255,17 @@ VERNAC COMMAND EXTEND NewFunctionalScheme warning_error names e end - ] + } END (***** debug only ***) VERNAC COMMAND EXTEND NewFunctionalCase - ["Functional" "Case" fun_scheme_arg(fas) ] - => [ Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater ] - -> [ Functional_principles_types.build_case_scheme fas ] +| ["Functional" "Case" fun_scheme_arg(fas) ] + => { Vernacexpr.VtSideff[pi1 fas], Vernacexpr.VtLater } + -> { Functional_principles_types.build_case_scheme fas } END (***** debug only ***) VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY -["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] +| ["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 0c45de4dc4..7c80b776a4 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -259,11 +259,8 @@ let mk_result ctxt value avoid = Some functions to deal with overlapping patterns **************************************************) -let coq_True_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "True") - -let coq_False_ref = - lazy (Coqlib.coq_reference "" ["Init";"Logic"] "False") +let coq_True_ref = lazy (Coqlib.lib_ref "core.True.type") +let coq_False_ref = lazy (Coqlib.lib_ref "core.False.type") (* [make_discr_match_el \[e1,...en\]] builds match e1,...,en with @@ -957,7 +954,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = assert false end | GApp(eq_as_ref,[ty; id ;rt]) - when is_gvar id && is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gvar id && is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> let loc1 = rt.CAst.loc in let loc2 = eq_as_ref.CAst.loc in @@ -1078,7 +1075,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else new_b, Id.Set.add id id_to_exclude *) | GApp(eq_as_ref,[ty;rt1;rt2]) - when is_gr eq_as_ref (Lazy.force Coqlib.coq_eq_ref) && n == Anonymous + when is_gr eq_as_ref Coqlib.(lib_ref "core.eq.type") && n == Anonymous -> begin try @@ -1089,7 +1086,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = List.fold_left (fun acc (lhs,rhs) -> mkGProd(Anonymous, - mkGApp(mkGRef(Lazy.force Coqlib.coq_eq_ref),[mkGHole ();lhs;rhs]),acc) + mkGApp(mkGRef Coqlib.(lib_ref "core.eq.type"),[mkGHole ();lhs;rhs]),acc) ) b l diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index f81de82d5e..5b45a8dbed 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -38,11 +38,11 @@ let glob_decompose_app = (* [glob_make_eq t1 t2] build the glob_constr corresponding to [t2 = t1] *) let glob_make_eq ?(typ= mkGHole ()) t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_eq_ref),[typ;t2;t1]) + mkGApp(mkGRef (Coqlib.lib_ref "core.eq.type"),[typ;t2;t1]) (* [glob_make_neq t1 t2] build the glob_constr corresponding to [t1 <> t2] *) let glob_make_neq t1 t2 = - mkGApp(mkGRef (Lazy.force Coqlib.coq_not_ref),[glob_make_eq t1 t2]) + mkGApp(mkGRef (Coqlib.lib_ref "core.not.type"),[glob_make_eq t1 t2]) let remove_name_from_mapping mapping na = match na with diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 6ed382ca1c..03a64988e4 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -114,6 +114,7 @@ let def_of_const t = with Not_found -> assert false) |_ -> assert false +[@@@ocaml.warning "-3"] let coq_constant s = UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" @@ -441,7 +442,7 @@ let jmeq () = Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq" + Coqlib.lib_ref "core.JMeq.type" with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = @@ -449,7 +450,7 @@ let jmeq_refl () = Coqlib.check_required_library Coqlib.jmeq_module_name; EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "Function" ["Logic";"JMeq"] "JMeq_refl" + Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -461,8 +462,10 @@ let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded" let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") +[@@@ocaml.warning "-3"] let well_founded_ltof () = EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "" ["Arith";"Wf_nat"] "well_founded_ltof" + Coqlib.find_reference "IndFun" ["Coq"; "Arith";"Wf_nat"] "well_founded_ltof" +[@@@ocaml.warning "+3"] let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 7e52ee224f..1b4c1248a5 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -46,7 +46,7 @@ val jmeq : unit -> EConstr.constr val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> - unit Lemmas.declaration_hook CEphemeron.key -> unit + Lemmas.declaration_hook CEphemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and abort the proof diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 56fe430077..b8973a18dc 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -81,10 +81,9 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - EConstr.of_constr (UnivGen.constr_of_global (Coqlib.build_coq_eq ())) - with _ -> assert false + EConstr.of_constr (UnivGen.constr_of_global (Coqlib.lib_ref "core.eq.type")) + with _ -> assert false - (* [generate_type g_to_f f graph i] build the completeness (resp. correctness) lemma type if [g_to_f = true] (resp. g_to_f = false) where [graph] is the graph of [f] and is the [i]th function in the block. @@ -512,7 +511,7 @@ and intros_with_rewrite_aux : Tacmach.tactic = intros_with_rewrite ] g end - | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type")) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENLIST[ diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 633d98a585..9fa333c629 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -49,11 +49,12 @@ open Context.Rel.Declaration (* Ugly things which should not be here *) +[@@@ocaml.warning "-3"] let coq_constant m s = EConstr.of_constr @@ UnivGen.constr_of_global @@ - Coqlib.coq_reference "RecursiveDefinition" m s + Coqlib.find_reference "RecursiveDefinition" m s -let arith_Nat = ["Arith";"PeanoNat";"Nat"] -let arith_Lt = ["Arith";"Lt"] +let arith_Nat = ["Coq"; "Arith";"PeanoNat";"Nat"] +let arith_Lt = ["Coq"; "Arith";"Lt"] let pr_leconstr_rd = let sigma, env = Pfedit.get_current_context () in @@ -63,6 +64,7 @@ let coq_init_constant s = EConstr.of_constr ( UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules s) +[@@@ocaml.warning "+3"] let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -143,6 +145,7 @@ let def_id = Id.of_string "def" let p_id = Id.of_string "p" let rec_res_id = Id.of_string "rec_res";; let lt = function () -> (coq_init_constant "lt") +[@@@ocaml.warning "-3"] let le = function () -> (Coqlib.gen_reference_in_modules "RecursiveDefinition" Coqlib.init_modules "le") let ex = function () -> (coq_init_constant "ex") let nat = function () -> (coq_init_constant "nat") @@ -163,7 +166,6 @@ let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) -let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -1241,8 +1243,8 @@ let get_current_subgoals_types () = exception EmptySubgoals let build_and_l sigma l = - let and_constr = UnivGen.constr_of_global @@ Coqlib.build_coq_and () in - let conj_constr = coq_conj () in + let and_constr = UnivGen.constr_of_global @@ Coqlib.lib_ref "core.and.type" in + let conj_constr = Coqlib.build_coq_conj () in let mk_and p1 p2 = mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = @@ -1318,7 +1320,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | None -> try add_suffix current_proof_name "_subproof" with e when CErrors.noncritical e -> - anomaly (Pp.str "open_new_goal with an unamed theorem.") + anomaly (Pp.str "open_new_goal with an unnamed theorem.") in let na = next_global_ident_away name Id.Set.empty in if Termops.occur_existential sigma gls_type then diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.mlg index f4555509cc..c4c4e51ecc 100644 --- a/plugins/ltac/extraargs.ml4 +++ b/plugins/ltac/extraargs.mlg @@ -8,8 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp -open Genarg open Stdarg open Tacarg open Pcoq.Prim @@ -62,22 +63,29 @@ let pr_orient _prc _prlc _prt = function | true -> Pp.mt () | false -> Pp.str " <-" -ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient -| [ "->" ] -> [ true ] -| [ "<-" ] -> [ false ] -| [ ] -> [ true ] +} + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY { pr_orient } +| [ "->" ] -> { true } +| [ "<-" ] -> { false } +| [ ] -> { true } END +{ + let pr_int _ _ _ i = Pp.int i let _natural = Pcoq.Prim.natural -ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int -| [ _natural(i) ] -> [ i ] +} + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY { pr_int } +| [ _natural(i) ] -> { i } END -let pr_orient = pr_orient () () () +{ +let pr_orient = pr_orient () () () let pr_int_list = Pp.pr_sequence Pp.int let pr_int_list_full _prc _prlc _prt l = pr_int_list l @@ -116,21 +124,25 @@ let glob_occs ist l = l let subst_occs evm l = l +} + ARGUMENT EXTEND occurrences TYPED AS int list - PRINTED BY pr_int_list_full + PRINTED BY { pr_int_list_full } - INTERPRETED BY interp_occs - GLOBALIZED BY glob_occs - SUBSTITUTED BY subst_occs + INTERPRETED BY { interp_occs } + GLOBALIZED BY { glob_occs } + SUBSTITUTED BY { subst_occs } - RAW_PRINTED BY pr_occurrences - GLOB_PRINTED BY pr_occurrences + RAW_PRINTED BY { pr_occurrences } + GLOB_PRINTED BY { pr_occurrences } -| [ ne_integer_list(l) ] -> [ ArgArg l ] -| [ var(id) ] -> [ ArgVar id ] +| [ ne_integer_list(l) ] -> { ArgArg l } +| [ var(id) ] -> { ArgVar id } END +{ + let pr_occurrences = pr_occurrences () () () let pr_gen prc _prlc _prtac c = prc c @@ -147,49 +159,61 @@ let pr_lconstr _ prc _ c = prc c let subst_glob = Tacsubst.subst_glob_constr_and_expr +} + ARGUMENT EXTEND glob - PRINTED BY pr_globc + PRINTED BY { pr_globc } - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ constr(c) ] -> [ c ] + RAW_PRINTED BY { pr_gen } + GLOB_PRINTED BY { pr_gen } +| [ constr(c) ] -> { c } END +{ + let l_constr = Pcoq.Constr.lconstr +} + ARGUMENT EXTEND lconstr TYPED AS constr - PRINTED BY pr_lconstr - [ l_constr(c) ] -> [ c ] + PRINTED BY { pr_lconstr } +| [ l_constr(c) ] -> { c } END ARGUMENT EXTEND lglob TYPED AS glob - PRINTED BY pr_globc + PRINTED BY { pr_globc } - INTERPRETED BY interp_glob - GLOBALIZED BY glob_glob - SUBSTITUTED BY subst_glob + INTERPRETED BY { interp_glob } + GLOBALIZED BY { glob_glob } + SUBSTITUTED BY { subst_glob } - RAW_PRINTED BY pr_gen - GLOB_PRINTED BY pr_gen - [ lconstr(c) ] -> [ c ] + RAW_PRINTED BY { pr_gen } + GLOB_PRINTED BY { pr_gen } +| [ lconstr(c) ] -> { c } END +{ + let interp_casted_constr ist gl c = interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c +} + ARGUMENT EXTEND casted_constr TYPED AS constr - PRINTED BY pr_gen - INTERPRETED BY interp_casted_constr - [ constr(c) ] -> [ c ] + PRINTED BY { pr_gen } + INTERPRETED BY { interp_casted_constr } +| [ constr(c) ] -> { c } END +{ + type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = lident gen_place @@ -228,70 +252,84 @@ let warn_deprecated_instantiate_syntax = ("Syntax \"in (" ^ v ^ " of " ^ s ^ ")\" is deprecated; use \"in (" ^ v' ^ " of " ^ s ^ ")\".") ) +} + ARGUMENT EXTEND hloc - PRINTED BY pr_place - INTERPRETED BY interp_place - GLOBALIZED BY intern_place - SUBSTITUTED BY subst_place - RAW_PRINTED BY pr_loc_place - GLOB_PRINTED BY pr_loc_place - [ ] -> - [ ConclLocation () ] + PRINTED BY { pr_place } + INTERPRETED BY { interp_place } + GLOBALIZED BY { intern_place } + SUBSTITUTED BY { subst_place } + RAW_PRINTED BY { pr_loc_place } + GLOB_PRINTED BY { pr_loc_place } +| [ ] -> + { ConclLocation () } | [ "in" "|-" "*" ] -> - [ ConclLocation () ] + { ConclLocation () } | [ "in" ident(id) ] -> - [ HypLocation ((CAst.make id),InHyp) ] + { HypLocation ((CAst.make id),InHyp) } | [ "in" "(" "Type" "of" ident(id) ")" ] -> - [ warn_deprecated_instantiate_syntax ("Type","type",id); - HypLocation ((CAst.make id),InHypTypeOnly) ] + { warn_deprecated_instantiate_syntax ("Type","type",id); + HypLocation ((CAst.make id),InHypTypeOnly) } | [ "in" "(" "Value" "of" ident(id) ")" ] -> - [ warn_deprecated_instantiate_syntax ("Value","value",id); - HypLocation ((CAst.make id),InHypValueOnly) ] + { warn_deprecated_instantiate_syntax ("Value","value",id); + HypLocation ((CAst.make id),InHypValueOnly) } | [ "in" "(" "type" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypTypeOnly) ] + { HypLocation ((CAst.make id),InHypTypeOnly) } | [ "in" "(" "value" "of" ident(id) ")" ] -> - [ HypLocation ((CAst.make id),InHypValueOnly) ] + { HypLocation ((CAst.make id),InHypValueOnly) } END +{ + let pr_rename _ _ _ (n, m) = Id.print n ++ str " into " ++ Id.print m +} + ARGUMENT EXTEND rename - TYPED AS ident * ident - PRINTED BY pr_rename -| [ ident(n) "into" ident(m) ] -> [ (n, m) ] + TYPED AS (ident * ident) + PRINTED BY { pr_rename } +| [ ident(n) "into" ident(m) ] -> { (n, m) } END (* Julien: Mise en commun des differentes version de replace with in by *) +{ + let pr_by_arg_tac _prc _prlc prtac opt_c = match opt_c with | None -> mt () | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Notation_gram.E) t) +} + ARGUMENT EXTEND by_arg_tac - TYPED AS tactic_opt - PRINTED BY pr_by_arg_tac -| [ "by" tactic3(c) ] -> [ Some c ] -| [ ] -> [ None ] + TYPED AS tactic option + PRINTED BY { pr_by_arg_tac } +| [ "by" tactic3(c) ] -> { Some c } +| [ ] -> { None } END +{ + let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl let in_clause' = Pltac.in_clause +} + ARGUMENT EXTEND in_clause TYPED AS clause_dft_concl - PRINTED BY pr_in_top_clause - RAW_TYPED AS clause_dft_concl - RAW_PRINTED BY pr_in_clause - GLOB_TYPED AS clause_dft_concl - GLOB_PRINTED BY pr_in_clause -| [ in_clause'(cl) ] -> [ cl ] + PRINTED BY { pr_in_top_clause } + RAW_PRINTED BY { pr_in_clause } + GLOB_PRINTED BY { pr_in_clause } +| [ in_clause'(cl) ] -> { cl } END +{ + let local_test_lpar_id_colon = let err () = raise Stream.Failure in Pcoq.Gram.Entry.of_parser "lpar_id_colon" @@ -308,6 +346,8 @@ let local_test_lpar_id_colon = let pr_lpar_id_colon _ _ _ _ = mt () -ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY pr_lpar_id_colon -| [ local_test_lpar_id_colon(x) ] -> [ () ] +} + +ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY { pr_lpar_id_colon } +| [ local_test_lpar_id_colon(x) ] -> { () } END diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.mlg index ba3fa6fa0d..b660865e8b 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.mlg @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp open Constr open Genarg @@ -30,8 +32,14 @@ open Tactics open Proofview.Notations open Vernacinterp +let wit_hyp = wit_var + +} + DECLARE PLUGIN "ltac_plugin" +{ + (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) (* cutrewrite, dependent rewrite *) @@ -43,7 +51,7 @@ let with_delayed_uconstr ist c tac = use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true - } in + } in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -54,26 +62,30 @@ let replace_in_clause_maybe_by ist c1 c2 cl tac = let replace_term ist dir_opt c cl = with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) +} + TACTIC EXTEND replace - ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] --> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +| ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> { replace_in_clause_maybe_by ist c1 c2 cl tac } END TACTIC EXTEND replace_term_left - [ "replace" "->" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some true) c cl ] +| [ "replace" "->" uconstr(c) clause(cl) ] + -> { replace_term ist (Some true) c cl } END TACTIC EXTEND replace_term_right - [ "replace" "<-" uconstr(c) clause(cl) ] - -> [ replace_term ist (Some false) c cl ] +| [ "replace" "<-" uconstr(c) clause(cl) ] + -> { replace_term ist (Some false) c cl } END TACTIC EXTEND replace_term - [ "replace" uconstr(c) clause(cl) ] - -> [ replace_term ist None c cl ] +| [ "replace" uconstr(c) clause(cl) ] + -> { replace_term ist None c cl } END +{ + let induction_arg_of_quantified_hyp = function | AnonHyp n -> None,ElimOnAnonHyp n | NamedHyp id -> None,ElimOnIdent (CAst.make id) @@ -94,28 +106,36 @@ let elimOnConstrWithHoles tac with_evars c = Tacticals.New.tclDELAYEDWITHHOLES with_evars c (fun c -> tac with_evars (Some (None,ElimOnConstr c))) +} + TACTIC EXTEND simplify_eq - [ "simplify_eq" ] -> [ dEq ~keep_proofs:None false None ] -| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) false c ] +| [ "simplify_eq" ] -> { dEq ~keep_proofs:None false None } +| [ "simplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) false c } END TACTIC EXTEND esimplify_eq -| [ "esimplify_eq" ] -> [ dEq ~keep_proofs:None true None ] -| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles (dEq ~keep_proofs:None) true c ] +| [ "esimplify_eq" ] -> { dEq ~keep_proofs:None true None } +| [ "esimplify_eq" destruction_arg(c) ] -> { mytclWithHoles (dEq ~keep_proofs:None) true c } END +{ + let discr_main c = elimOnConstrWithHoles discr_tac false c +} + TACTIC EXTEND discriminate -| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" ] -> { discr_tac false None } | [ "discriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac false c ] + { mytclWithHoles discr_tac false c } END TACTIC EXTEND ediscriminate -| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" ] -> { discr_tac true None } | [ "ediscriminate" destruction_arg(c) ] -> - [ mytclWithHoles discr_tac true c ] + { mytclWithHoles discr_tac true c } END +{ + let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> discr_main (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) @@ -123,39 +143,45 @@ let discrHyp id = let injection_main with_evars c = elimOnConstrWithHoles (injClause None None) with_evars c +} + TACTIC EXTEND injection -| [ "injection" ] -> [ injClause None None false None ] -| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) false c ] +| [ "injection" ] -> { injClause None None false None } +| [ "injection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) false c } END TACTIC EXTEND einjection -| [ "einjection" ] -> [ injClause None None true None ] -| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None None) true c ] +| [ "einjection" ] -> { injClause None None true None } +| [ "einjection" destruction_arg(c) ] -> { mytclWithHoles (injClause None None) true c } END TACTIC EXTEND injection_as | [ "injection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) false None ] + { injClause None (Some ipat) false None } | [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) false c ] + { mytclWithHoles (injClause None (Some ipat)) false c } END TACTIC EXTEND einjection_as | [ "einjection" "as" intropattern_list(ipat)] -> - [ injClause None (Some ipat) true None ] + { injClause None (Some ipat) true None } | [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> - [ mytclWithHoles (injClause None (Some ipat)) true c ] + { mytclWithHoles (injClause None (Some ipat)) true c } END TACTIC EXTEND simple_injection -| [ "simple" "injection" ] -> [ simpleInjClause None false None ] -| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles (simpleInjClause None) false c ] +| [ "simple" "injection" ] -> { simpleInjClause None false None } +| [ "simple" "injection" destruction_arg(c) ] -> { mytclWithHoles (simpleInjClause None) false c } END +{ + let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> injection_main false (fun env sigma -> (sigma, (EConstr.mkVar id, NoBindings))) +} + TACTIC EXTEND dependent_rewrite -| [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] +| [ "dependent" "rewrite" orient(b) constr(c) ] -> { rewriteInConcl b c } | [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] - -> [ rewriteInHyp b c id ] + -> { rewriteInHyp b c id } END (** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to @@ -163,43 +189,53 @@ END "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } | [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> [ cutRewriteInHyp b eqn id ] + -> { cutRewriteInHyp b eqn id } END (**********************************************************************) (* Decompose *) TACTIC EXTEND decompose_sum -| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +| [ "decompose" "sum" constr(c) ] -> { Elim.h_decompose_or c } END TACTIC EXTEND decompose_record -| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +| [ "decompose" "record" constr(c) ] -> { Elim.h_decompose_and c } END (**********************************************************************) (* Contradiction *) +{ + open Contradiction +} + TACTIC EXTEND absurd - [ "absurd" constr(c) ] -> [ absurd c ] +| [ "absurd" constr(c) ] -> { absurd c } END +{ + let onSomeWithHoles tac = function | None -> tac None | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) +} + TACTIC EXTEND contradiction - [ "contradiction" constr_with_bindings_opt(c) ] -> - [ onSomeWithHoles contradiction c ] +| [ "contradiction" constr_with_bindings_opt(c) ] -> + { onSomeWithHoles contradiction c } END (**********************************************************************) (* AutoRewrite *) +{ + open Autorewrite let pr_orient _prc _prlc _prt = function @@ -209,50 +245,58 @@ let pr_orient _prc _prlc _prt = function let pr_orient_string _prc _prlc _prt (orient, s) = pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s -ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string -| [ orient(r) preident(i) ] -> [ r, i ] +} + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY { pr_orient_string } +| [ orient(r) preident(i) ] -> { r, i } END TACTIC EXTEND autorewrite | [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite l ( cl) ] + { auto_multi_rewrite l ( cl) } | [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ + { auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl - ] + } END TACTIC EXTEND autorewrite_star | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> - [ auto_multi_rewrite ~conds:AllMatches l cl ] + { auto_multi_rewrite ~conds:AllMatches l cl } | [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> - [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] + { auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl } END (**********************************************************************) (* Rewrite star *) +{ + let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in with_delayed_uconstr ist c (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) +} + TACTIC EXTEND rewrite_star | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] + { rewrite_star ist (Some id) o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> - [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] + { rewrite_star ist (Some id) o Locus.AllOccurrences c tac } | [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> - [ rewrite_star ist None o (occurrences_of occ) c tac ] + { rewrite_star ist None o (occurrences_of occ) c tac } | [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> - [ rewrite_star ist None o Locus.AllOccurrences c tac ] + { rewrite_star ist None o Locus.AllOccurrences c tac } END (**********************************************************************) (* Hint Rewrite *) +{ + let add_rewrite_hint ~poly bases ort t lcsr = let env = Global.env() in let sigma = Evd.from_env env in @@ -274,21 +318,25 @@ let add_rewrite_hint ~poly bases ort t lcsr = let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater -VERNAC COMMAND FUNCTIONAL EXTEND HintRewrite CLASSIFIED BY classify_hint - [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o None l; st ] +} + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY { classify_hint } +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + { add_rewrite_hint ~poly:atts.polymorphic bl o None l } | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ":" preident_list(bl) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l; st ] + { add_rewrite_hint ~poly:atts.polymorphic bl o (Some t) l } | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l; st ] + { add_rewrite_hint ~poly:atts.polymorphic ["core"] o None l } | [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> - [ fun ~atts ~st -> add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l; st ] + { add_rewrite_hint ~poly:atts.polymorphic ["core"] o (Some t) l } END (**********************************************************************) (* Refine *) +{ + open EConstr open Vars @@ -304,7 +352,7 @@ let refine_tac ist simple with_classes c = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let flags = - { constr_flags () with Pretyping.use_typeclasses = with_classes } in + { (constr_flags ()) with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Tacinterp.type_uconstr ~flags ~expected_type ist c in let update = begin fun sigma -> @@ -317,125 +365,141 @@ let refine_tac ist simple with_classes c = Proofview.shelve_unifiable end +} + TACTIC EXTEND refine | [ "refine" uconstr(c) ] -> - [ refine_tac ist false true c ] + { refine_tac ist false true c } END TACTIC EXTEND simple_refine | [ "simple" "refine" uconstr(c) ] -> - [ refine_tac ist true true c ] + { refine_tac ist true true c } END TACTIC EXTEND notcs_refine | [ "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist false false c ] + { refine_tac ist false false c } END TACTIC EXTEND notcs_simple_refine | [ "simple" "notypeclasses" "refine" uconstr(c) ] -> - [ refine_tac ist true false c ] + { refine_tac ist true false c } END (* Solve unification constraints using heuristics or fail if any remain *) TACTIC EXTEND solve_constraints -[ "solve_constraints" ] -> [ Refine.solve_constraints ] +| [ "solve_constraints" ] -> { Refine.solve_constraints } END (**********************************************************************) (* Inversion lemmas (Leminv) *) +{ + open Inv open Leminv let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater +} + (*VERNAC ARGUMENT EXTEND sort_family -| [ "Set" ] -> [ InSet ] -| [ "Prop" ] -> [ InProp ] -| [ "Type" ] -> [ InType ] +| [ "Set" ] -> { InSet } +| [ "Prop" ] -> { InProp } +| [ "Type" ] -> { InType } END*) -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversionClear +VERNAC COMMAND EXTEND DeriveInversionClear | [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> + => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_clear_tac } -| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_clear_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveInversion +VERNAC COMMAND EXTEND DeriveInversion | [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> + => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c s false inv_tac } -| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] - -> [ fun ~atts ~st -> +| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c Sorts.InProp false inv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversion +VERNAC COMMAND EXTEND DeriveDependentInversion | [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> + => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_tac } END -VERNAC COMMAND FUNCTIONAL EXTEND DeriveDependentInversionClear +VERNAC COMMAND EXTEND DeriveDependentInversionClear | [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort_family(s) ] - => [ seff na ] - -> [ fun ~atts ~st -> + => { seff na } + -> { let open Vernacinterp in - add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac; st ] + add_inversion_lemma_exn ~poly:atts.polymorphic na c s true dinv_clear_tac } END (**********************************************************************) (* Subst *) TACTIC EXTEND subst -| [ "subst" ne_var_list(l) ] -> [ subst l ] -| [ "subst" ] -> [ subst_all () ] +| [ "subst" ne_var_list(l) ] -> { subst l } +| [ "subst" ] -> { subst_all () } END +{ + let simple_subst_tactic_flags = { only_leibniz = true; rewrite_dependent_proof = false } +} + TACTIC EXTEND simple_subst -| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +| [ "simple" "subst" ] -> { subst_all ~flags:simple_subst_tactic_flags () } END +{ + open Evar_tactics +} + (**********************************************************************) (* Evar creation *) (* TODO: add support for some test similar to g_constr.name_colon so that expressions like "evar (list A)" do not raise a syntax error *) TACTIC EXTEND evar - [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name.Name id) typ ] -| [ "evar" constr(typ) ] -> [ let_evar Name.Anonymous typ ] +| [ "evar" test_lpar_id_colon "(" ident(id) ":" lconstr(typ) ")" ] -> { let_evar (Name.Name id) typ } +| [ "evar" constr(typ) ] -> { let_evar Name.Anonymous typ } END TACTIC EXTEND instantiate - [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> - [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + { Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals } | [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> - [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] -| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] + { Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals } +| [ "instantiate" ] -> { Proofview.V82.nf_evar_goals } END (**********************************************************************) (** Nijmegen "step" tactic for setoid rewriting *) +{ + open Tactics open Glob_term open Libobject @@ -489,28 +553,32 @@ let add_transitivity_lemma left lem = let lem' = EConstr.to_constr sigma lem' in add_anonymous_leaf (inTransitivity (left,lem')) +} + (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> { step true c (Tacinterp.tactic_of_value ist tac) } +| ["stepl" constr(c) ] -> { step true c (Proofview.tclUNIT ()) } END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> { step false c (Tacinterp.tactic_of_value ist tac) } +| ["stepr" constr(c) ] -> { step false c (Proofview.tclUNIT ()) } END VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF | [ "Declare" "Left" "Step" constr(t) ] -> - [ add_transitivity_lemma true t ] + { add_transitivity_lemma true t } END VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF | [ "Declare" "Right" "Step" constr(t) ] -> - [ add_transitivity_lemma false t ] + { add_transitivity_lemma false t } END +{ + let cache_implicit_tactic (_,tac) = match tac with | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) | None -> Pfedit.clear_implicit_tactic () @@ -537,9 +605,11 @@ let clear_implicit_tactic () = let () = warn_deprecated_implicit_tactic () in Lib.add_anonymous_leaf (inImplicitTactic None) +} + VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF -| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] -| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> { declare_implicit_tactic tac } +| [ "Clear" "Implicit" "Tactic" ] -> { clear_implicit_tactic () } END @@ -549,16 +619,16 @@ END (* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as defined by Conor McBride *) TACTIC EXTEND generalize_eqs -| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +| ["generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false id } END TACTIC EXTEND dep_generalize_eqs -| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +| ["dependent" "generalize_eqs" hyp(id) ] -> { abstract_generalize ~generalize_vars:false ~force_dep:true id } END TACTIC EXTEND generalize_eqs_vars -| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +| ["generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~generalize_vars:true id } END TACTIC EXTEND dep_generalize_eqs_vars -| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> { abstract_generalize ~force_dep:true ~generalize_vars:true id } END (** Tactic to automatically simplify hypotheses of the form [Π Δ, x_i = t_i -> T] @@ -566,7 +636,7 @@ END during dependent induction. For internal use. *) TACTIC EXTEND specialize_eqs -[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +| [ "specialize_eqs" hyp(id) ] -> { specialize_eqs id } END (**********************************************************************) @@ -577,6 +647,8 @@ END (* Contributed by Chung-Kil Hur (Winter 2009) *) (**********************************************************************) +{ + let subst_var_with_hole occ tid t = let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in let locref = ref 0 in @@ -593,7 +665,7 @@ let subst_var_with_hole occ tid t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - }, IntroAnonymous, None))) + }, IntroAnonymous, None))) else x | _ -> map_glob_constr_left_to_right substrec x in let t' = substrec t @@ -608,7 +680,7 @@ let subst_hole_with_term occ tc t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - }, IntroAnonymous, s) -> + }, IntroAnonymous, s) -> decr occref; if Int.equal !occref 0 then tc else @@ -618,7 +690,7 @@ let subst_hole_with_term occ tc t = Evar_kinds.qm_obligation=Evar_kinds.Define true; Evar_kinds.qm_name=Anonymous; Evar_kinds.qm_record_field=None; - },IntroAnonymous,s)) + },IntroAnonymous,s)) | _ -> map_glob_constr_left_to_right substrec c in substrec t @@ -659,9 +731,11 @@ let hResolve_auto id c t = in resolve_auto 1 +} + TACTIC EXTEND hresolve_core -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] -| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> { hResolve id c occ t } +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> { hResolve_auto id c t } END (** @@ -669,7 +743,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> [ Evar_tactics.hget_evar n ] +| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) @@ -682,6 +756,8 @@ END (* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) (**********************************************************************) +{ + exception Found of unit Proofview.tactic let rewrite_except h = @@ -693,12 +769,7 @@ let rewrite_except h = end -let refl_equal = - let coq_base_constant s = - Coqlib.gen_reference_in_modules "RecursiveDefinition" - (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in - function () -> (coq_base_constant "eq_refl") - +let refl_equal () = Coqlib.lib_ref "core.eq.type" (* This is simply an implementation of the case_eq tactic. this code should be replaced by a call to the tactic but I don't know how to @@ -768,9 +839,11 @@ let destauto_in id = destauto ctype end +} + TACTIC EXTEND destauto -| [ "destauto" ] -> [ Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end ] -| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +| [ "destauto" ] -> { Proofview.Goal.enter begin fun gl -> destauto (Proofview.Goal.concl gl) end } +| [ "destauto" "in" hyp(id) ] -> { destauto_in id } END (**********************************************************************) @@ -781,116 +854,116 @@ END (**********************************************************************) TACTIC EXTEND transparent_abstract -| [ "transparent_abstract" tactic3(t) ] -> [ Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end ] -| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> [ Proofview.Goal.enter begin fun gl -> - Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end ] +| [ "transparent_abstract" tactic3(t) ] -> { Proofview.Goal.enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false None (Tacinterp.tactic_of_value ist t) end } +| [ "transparent_abstract" tactic3(t) "using" ident(id) ] -> { Proofview.Goal.enter begin fun gl -> + Tactics.tclABSTRACT ~opaque:false (Some id) (Tacinterp.tactic_of_value ist t) end } END (* ********************************************************************* *) TACTIC EXTEND constr_eq -| [ "constr_eq" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:false x y ] +| [ "constr_eq" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:false x y } END TACTIC EXTEND constr_eq_strict -| [ "constr_eq_strict" constr(x) constr(y) ] -> [ Tactics.constr_eq ~strict:true x y ] +| [ "constr_eq_strict" constr(x) constr(y) ] -> { Tactics.constr_eq ~strict:true x y } END TACTIC EXTEND constr_eq_nounivs -| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> { Proofview.tclEVARMAP >>= fun sigma -> - if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] + if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") } END TACTIC EXTEND is_evar -| [ "is_evar" constr(x) ] -> [ +| [ "is_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Evar _ -> Proofview.tclUNIT () | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") - ] + } END TACTIC EXTEND has_evar -| [ "has_evar" constr(x) ] -> [ +| [ "has_evar" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> if Evarutil.has_undefined_evars sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") -] +} END TACTIC EXTEND is_hyp -| [ "is_var" constr(x) ] -> [ +| [ "is_var" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Var _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") } END TACTIC EXTEND is_fix -| [ "is_fix" constr(x) ] -> [ +| [ "is_fix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Fix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") } +END TACTIC EXTEND is_cofix -| [ "is_cofix" constr(x) ] -> [ +| [ "is_cofix" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | CoFix _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") } +END TACTIC EXTEND is_ind -| [ "is_ind" constr(x) ] -> [ +| [ "is_ind" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Ind _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") } +END TACTIC EXTEND is_constructor -| [ "is_constructor" constr(x) ] -> [ +| [ "is_constructor" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Construct _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") } +END TACTIC EXTEND is_proj -| [ "is_proj" constr(x) ] -> [ +| [ "is_proj" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Proj _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") } +END TACTIC EXTEND is_const -| [ "is_const" constr(x) ] -> [ +| [ "is_const" constr(x) ] -> { Proofview.tclEVARMAP >>= fun sigma -> match EConstr.kind sigma x with | Const _ -> Proofview.tclUNIT () - | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] -END;; + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") } +END (* Command to grab the evars left unresolved at the end of a proof. *) (* spiwack: I put it in extratactics because it is somewhat tied with the semantics of the LCF-style tactics, hence with the classic tactic mode. *) VERNAC COMMAND EXTEND GrabEvars -[ "Grab" "Existential" "Variables" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +| [ "Grab" "Existential" "Variables" ] + => { Vernac_classifier.classify_as_proofstep } + -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) } END (* Shelves all the goals under focus. *) TACTIC EXTEND shelve | [ "shelve" ] -> - [ Proofview.shelve ] + { Proofview.shelve } END (* Shelves the unifiable goals under focus, i.e. the goals which @@ -898,25 +971,25 @@ END considered). *) TACTIC EXTEND shelve_unifiable | [ "shelve_unifiable" ] -> - [ Proofview.shelve_unifiable ] + { Proofview.shelve_unifiable } END (* Unshelves the goal shelved by the tactic. *) TACTIC EXTEND unshelve | [ "unshelve" tactic1(t) ] -> - [ + { Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> let gls = List.map Proofview.with_empty_state gls in Proofview.Unsafe.tclGETGOALS >>= fun ogls -> Proofview.Unsafe.tclSETGOALS (gls @ ogls) - ] + } END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve -[ "Unshelve" ] - => [ Vernac_classifier.classify_as_proofstep ] - -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +| [ "Unshelve" ] + => { Vernac_classifier.classify_as_proofstep } + -> { Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) } END (* Gives up on the goals under focus: the goals are considered solved, @@ -924,24 +997,26 @@ END these goals. *) TACTIC EXTEND give_up | [ "give_up" ] -> - [ Proofview.give_up ] + { Proofview.give_up } END (* cycles [n] goals *) TACTIC EXTEND cycle -| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +| [ "cycle" int_or_var(n) ] -> { Proofview.cycle n } END (* swaps goals number [i] and [j] *) TACTIC EXTEND swap -| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +| [ "swap" int_or_var(i) int_or_var(j) ] -> { Proofview.swap i j } END (* reverses the list of focused goals *) TACTIC EXTEND revgoals -| [ "revgoals" ] -> [ Proofview.revgoals ] +| [ "revgoals" ] -> { Proofview.revgoals } END +{ + type cmp = | Eq | Lt | Le @@ -970,29 +1045,35 @@ let pr_itest = pr_test_gen Pp.int let pr_itest' _prc _prlc _prt = pr_itest +} - -ARGUMENT EXTEND comparison PRINTED BY pr_cmp' -| [ "=" ] -> [ Eq ] -| [ "<" ] -> [ Lt ] -| [ "<=" ] -> [ Le ] -| [ ">" ] -> [ Gt ] -| [ ">=" ] -> [ Ge ] +ARGUMENT EXTEND comparison PRINTED BY { pr_cmp' } +| [ "=" ] -> { Eq } +| [ "<" ] -> { Lt } +| [ "<=" ] -> { Le } +| [ ">" ] -> { Gt } +| [ ">=" ] -> { Ge } END +{ + let interp_test ist gls = function | Test (c,x,y) -> project gls , Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) +} + ARGUMENT EXTEND test - PRINTED BY pr_itest' - INTERPRETED BY interp_test - RAW_PRINTED BY pr_test' - GLOB_PRINTED BY pr_test' -| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] + PRINTED BY { pr_itest' } + INTERPRETED BY { interp_test } + RAW_PRINTED BY { pr_test' } + GLOB_PRINTED BY { pr_test' } +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> { Test(c,x,y) } END +{ + let interp_cmp = function | Eq -> Int.equal | Lt -> ((<):int->int->bool) @@ -1010,11 +1091,14 @@ let guard tst = let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in Tacticals.New.tclZEROMSG msg +} TACTIC EXTEND guard -| [ "guard" test(tst) ] -> [ guard tst ] +| [ "guard" test(tst) ] -> { guard tst } END +{ + let decompose l c = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in @@ -1026,14 +1110,16 @@ let decompose l c = Elim.h_decompose l c end +} + TACTIC EXTEND decompose -| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> { decompose l c } END (** library/keys *) VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> { let get_key c = let env = Global.env () in let evd = Evd.from_env env in @@ -1045,26 +1131,30 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF let k2 = get_key c' in match k1, k2 with | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 - | _ -> () ] + | _ -> () } END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] +| [ "Print" "Equivalent" "Keys" ] -> { Feedback.msg_info (Keys.pr_keys Printer.pr_global) } END VERNAC COMMAND EXTEND OptimizeProof -| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Proof_global.compact_the_proof () ] -| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> - [ Gc.compact () ] +| [ "Optimize" "Proof" ] => { Vernac_classifier.classify_as_proofstep } -> + { Proof_global.compact_the_proof () } +| [ "Optimize" "Heap" ] => { Vernac_classifier.classify_as_proofstep } -> + { Gc.compact () } END (** tactic analogous to "OPTIMIZE HEAP" *) +{ + let tclOPTIMIZE_HEAP = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> Gc.compact ())) +} + TACTIC EXTEND optimize_heap -| [ "optimize_heap" ] -> [ tclOPTIMIZE_HEAP ] +| [ "optimize_heap" ] -> { tclOPTIMIZE_HEAP } END diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.mlg index 35ed14fc18..c07b653f3a 100644 --- a/plugins/ltac/g_auto.ml4 +++ b/plugins/ltac/g_auto.mlg @@ -8,38 +8,49 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Pp open Constr -open Genarg open Stdarg open Pcoq.Prim open Pcoq.Constr open Pltac open Hints +let wit_hyp = wit_var + +} + DECLARE PLUGIN "ltac_plugin" (* Hint bases *) TACTIC EXTEND eassumption -| [ "eassumption" ] -> [ Eauto.e_assumption ] +| [ "eassumption" ] -> { Eauto.e_assumption } END TACTIC EXTEND eexact -| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +| [ "eexact" constr(c) ] -> { Eauto.e_give_exact c } END +{ + let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases +} + ARGUMENT EXTEND hintbases - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ "with" "*" ] -> [ None ] -| [ "with" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ Some [] ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ "with" "*" ] -> { None } +| [ "with" ne_preident_list(l) ] -> { Some l } +| [ ] -> { Some [] } END +{ + let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; @@ -59,104 +70,108 @@ let pr_auto_using _ _ _ = Pptactic.pr_auto_using (let sigma, env = Pfedit.get_current_context () in Printer.pr_closed_glob_env env sigma) +} + ARGUMENT EXTEND auto_using - TYPED AS uconstr_list - PRINTED BY pr_auto_using - RAW_TYPED AS uconstr_list - RAW_PRINTED BY pr_auto_using_raw - GLOB_TYPED AS uconstr_list - GLOB_PRINTED BY pr_auto_using_glob -| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] -| [ ] -> [ [] ] + TYPED AS uconstr list + PRINTED BY { pr_auto_using } + RAW_PRINTED BY { pr_auto_using_raw } + GLOB_PRINTED BY { pr_auto_using_glob } +| [ "using" ne_uconstr_list_sep(l, ",") ] -> { l } +| [ ] -> { [] } END (** Auto *) TACTIC EXTEND trivial | [ "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial (eval_uconstrs ist lems) db ] + { Auto.h_trivial (eval_uconstrs ist lems) db } END TACTIC EXTEND info_trivial | [ "info_trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_trivial | [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> - [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] + { Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db } END TACTIC EXTEND auto | [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto n (eval_uconstrs ist lems) db ] + { Auto.h_auto n (eval_uconstrs ist lems) db } END TACTIC EXTEND info_auto | [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db } END TACTIC EXTEND debug_auto | [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] + { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END (** Eauto *) TACTIC EXTEND prolog | [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> - [ Eauto.prolog_tac (eval_uconstrs ist l) n ] + { Eauto.prolog_tac (eval_uconstrs ist l) n } END +{ + let make_depth n = snd (Eauto.make_dimension n None) +} + TACTIC EXTEND eauto | [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND new_eauto | [ "new" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> - [ match db with + { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) - | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l } END TACTIC EXTEND debug_eauto | [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND info_eauto | [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } END TACTIC EXTEND dfs_eauto | [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] + { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END TACTIC EXTEND autounfold -| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> { Eauto.autounfold_tac db cl } END TACTIC EXTEND autounfold_one | [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) } | [ "autounfold_one" hintbases(db) ] -> - [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + { Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None } END TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] -| ["unify" constr(x) constr(y) "with" preident(base) ] -> [ +| ["unify" constr(x) constr(y) ] -> { Tactics.unify x y } +| ["unify" constr(x) constr(y) "with" preident(base) ] -> { let table = try Some (Hints.searchtable_map base) with Not_found -> None in match table with | None -> @@ -165,65 +180,70 @@ TACTIC EXTEND unify | Some t -> let state = Hints.Hint_db.transparent_state t in Tactics.unify ~state x y - ] + } END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> { Tactics.convert_concl_no_check x DEFAULTcast } END +{ + let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_qualid let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global let glob_hints_path_atom ist = Hints.glob_hints_path_atom +} + ARGUMENT EXTEND hints_path_atom - PRINTED BY pr_hints_path_atom + PRINTED BY { pr_hints_path_atom } - GLOBALIZED BY glob_hints_path_atom + GLOBALIZED BY { glob_hints_path_atom } - RAW_PRINTED BY pr_pre_hints_path_atom - GLOB_PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints g ] -| [ "_" ] -> [ Hints.PathAny ] + RAW_PRINTED BY { pr_pre_hints_path_atom } + GLOB_PRINTED BY { pr_hints_path_atom } +| [ ne_global_list(g) ] -> { Hints.PathHints g } +| [ "_" ] -> { Hints.PathAny } END +{ + let pr_hints_path prc prx pry c = Hints.pp_hints_path c let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_qualid c let glob_hints_path ist = Hints.glob_hints_path +} + ARGUMENT EXTEND hints_path -PRINTED BY pr_hints_path +PRINTED BY { pr_hints_path } -GLOBALIZED BY glob_hints_path -RAW_PRINTED BY pr_pre_hints_path -GLOB_PRINTED BY pr_hints_path +GLOBALIZED BY { glob_hints_path } +RAW_PRINTED BY { pr_pre_hints_path } +GLOB_PRINTED BY { pr_hints_path } -| [ "(" hints_path(p) ")" ] -> [ p ] -| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] -| [ "emp" ] -> [ Hints.PathEmpty ] -| [ "eps" ] -> [ Hints.PathEpsilon ] -| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] -| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] -| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +| [ "(" hints_path(p) ")" ] -> { p } +| [ hints_path(p) "*" ] -> { Hints.PathStar p } +| [ "emp" ] -> { Hints.PathEmpty } +| [ "eps" ] -> { Hints.PathEpsilon } +| [ hints_path(p) "|" hints_path(q) ] -> { Hints.PathOr (p, q) } +| [ hints_path_atom(a) ] -> { Hints.PathAtom a } +| [ hints_path(p) hints_path(q) ] -> { Hints.PathSeq (p, q) } END ARGUMENT EXTEND opthints - TYPED AS preident_list_opt - PRINTED BY pr_hintbases -| [ ":" ne_preident_list(l) ] -> [ Some l ] -| [ ] -> [ None ] + TYPED AS preident list option + PRINTED BY { pr_hintbases } +| [ ":" ne_preident_list(l) ] -> { Some l } +| [ ] -> { None } END -VERNAC COMMAND FUNCTIONAL EXTEND HintCut CLASSIFIED AS SIDEFF -| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - fun ~atts ~st -> begin +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { let open Vernacinterp in let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in Hints.add_hints ~local:(Locality.make_section_locality atts.locality) (match dbnames with None -> ["core"] | Some l -> l) entry; - st - end - ] + } END diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.mlg index 1c2f90b670..9ecc36bdf3 100644 --- a/plugins/ltac/g_class.ml4 +++ b/plugins/ltac/g_class.mlg @@ -8,87 +8,103 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Class_tactics open Stdarg open Tacarg +} + DECLARE PLUGIN "ltac_plugin" (** Options: depth, debug and transparency settings. *) +{ + let set_transparency cl b = List.iter (fun r -> let gr = Smartlocate.global_with_alias r in let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in Classes.set_typeclass_transparency ev (Locality.make_section_locality None) b) cl +} + VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ - set_transparency cl true ] +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> { + set_transparency cl true } END VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF -| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ - set_transparency cl false ] +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> { + set_transparency cl false } END -open Genarg +{ let pr_debug _prc _prlc _prt b = if b then Pp.str "debug" else Pp.mt() -ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug -| [ "debug" ] -> [ true ] -| [ ] -> [ false ] +} + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY { pr_debug } +| [ "debug" ] -> { true } +| [ ] -> { false } END +{ + let pr_search_strategy _prc _prlc _prt = function | Some Dfs -> Pp.str "dfs" | Some Bfs -> Pp.str "bfs" | None -> Pp.mt () -ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy -| [ "(bfs)" ] -> [ Some Bfs ] -| [ "(dfs)" ] -> [ Some Dfs ] -| [ ] -> [ None ] +} + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY { pr_search_strategy } +| [ "(bfs)" ] -> { Some Bfs } +| [ "(dfs)" ] -> { Some Dfs } +| [ ] -> { None } END (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> { set_typeclasses_debug d; Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth - ] + } END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + { typeclasses_eauto ~strategy:Bfs ~depth:d l } | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto ~depth:d l ] - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ - typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] + { typeclasses_eauto ~depth:d l } + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] } END TACTIC EXTEND head_of_constr - [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +| [ "head_of_constr" ident(h) constr(c) ] -> { head_of_constr h c } END TACTIC EXTEND not_evar - [ "not_evar" constr(ty) ] -> [ not_evar ty ] +| [ "not_evar" constr(ty) ] -> { not_evar ty } END TACTIC EXTEND is_ground - [ "is_ground" constr(ty) ] -> [ is_ground ty ] +| [ "is_ground" constr(ty) ] -> { is_ground ty } END TACTIC EXTEND autoapply - [ "autoapply" constr(c) "using" preident(i) ] -> [ autoapply c i ] +| [ "autoapply" constr(c) "using" preident(i) ] -> { autoapply c i } END +{ + (** TODO: DEPRECATE *) (* A progress test that allows to see if the evars have changed *) open Constr @@ -114,6 +130,8 @@ let progress_evars t = in t <*> check end +} + TACTIC EXTEND progress_evars - [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +| [ "progress_evars" tactic(t) ] -> { progress_evars (Tacinterp.tactic_of_value ist t) } END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.mlg index 929390b1c4..d62f985350 100644 --- a/plugins/ltac/g_ltac.ml4 +++ b/plugins/ltac/g_ltac.mlg @@ -10,6 +10,8 @@ DECLARE PLUGIN "ltac_plugin" +{ + open Util open Pp open Glob_term @@ -80,282 +82,288 @@ let test_bracket_ident = let hint = G_proofs.hint -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint tactic_mode constr_may_eval constr_eval toplevel_selector operconstr; tactic_then_last: - [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> - Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) - | -> [||] + [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } + | -> { [||] } ] ] ; tactic_then_gen: - [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) - | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) - | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) - | ta = tactic_expr -> ([ta], None) - | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) - | -> ([TacId []], None) + [ [ ta = tactic_expr; "|"; tg = tactic_then_gen -> { let (first,last) = tg in (ta::first, last) } + | ta = tactic_expr; ".."; l = tactic_then_last -> { ([], Some (ta, l)) } + | ".."; l = tactic_then_last -> { ([], Some (TacId [], l)) } + | ta = tactic_expr -> { ([ta], None) } + | "|"; tg = tactic_then_gen -> { let (first,last) = tg in (TacId [] :: first, last) } + | -> { ([TacId []], None) } ] ] ; tactic_then_locality: (* [true] for the local variant [TacThens] and [false] for [TacExtend] *) - [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] ; tactic_expr: [ "5" RIGHTA - [ te = binder_tactic -> te ] + [ te = binder_tactic -> { te } ] | "4" LEFTA - [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) - | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) - | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> { TacThen (ta0,ta1) } + | ta0 = tactic_expr; ";"; l = tactic_then_locality; tg = tactic_then_gen; "]" -> { + let (first,tail) = tg in match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) | false , None -> TacThen (ta0,TacDispatch first) - | true , None -> TacThens (ta0,first) ] + | true , None -> TacThens (ta0,first) } ] | "3" RIGHTA - [ IDENT "try"; ta = tactic_expr -> TacTry ta - | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) - | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) - | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) - | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta - | IDENT "progress"; ta = tactic_expr -> TacProgress ta - | IDENT "once"; ta = tactic_expr -> TacOnce ta - | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta - | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta + [ IDENT "try"; ta = tactic_expr -> { TacTry ta } + | IDENT "do"; n = int_or_var; ta = tactic_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = tactic_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = tactic_expr -> { TacRepeat ta } + | IDENT "progress"; ta = tactic_expr -> { TacProgress ta } + | IDENT "once"; ta = tactic_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = tactic_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = tactic_expr -> { TacShowHyps ta } (*To do: put Abstract in Refiner*) - | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT -> { TacAbstract (tc,None) } | IDENT "abstract"; tc = NEXT; "using"; s = ident -> - TacAbstract (tc,Some s) - | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] + { TacAbstract (tc,Some s) } + | sel = selector; ta = tactic_expr -> { TacSelect (sel, ta) } ] (*End of To do*) | "2" RIGHTA - [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) - | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> { TacOr (ta0,ta1) } | IDENT "tryif" ; ta = tactic_expr ; "then" ; tat = tactic_expr ; - "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) - | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) - | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + "else" ; tae = tactic_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> { TacOrelse (ta0,ta1) } ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,false,mrl) + { TacMatchGoal (b,false,mrl) } | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> - TacMatchGoal (b,true,mrl) + { TacMatchGoal (b,true,mrl) } | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> - TacMatch (b,c,mrl) + { TacMatch (b,c,mrl) } | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacFirst l + { TacFirst l } | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> - TacSolve l - | IDENT "idtac"; l = LIST0 message_token -> TacId l - | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; - l = LIST0 message_token -> TacFail (g,n,l) - | st = simple_tactic -> st - | a = tactic_arg -> TacArg(Loc.tag ~loc:!@loc a) + { TacSolve l } + | IDENT "idtac"; l = LIST0 message_token -> { TacId l } + | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; + l = LIST0 message_token -> { TacFail (g,n,l) } + | st = simple_tactic -> { st } + | a = tactic_arg -> { TacArg(Loc.tag ~loc a) } | r = reference; la = LIST0 tactic_arg_compat -> - TacArg(Loc.tag ~loc:!@loc @@ TacCall (Loc.tag ~loc:!@loc (r,la))) ] + { TacArg(Loc.tag ~loc @@ TacCall (Loc.tag ~loc (r,la))) } ] | "0" - [ "("; a = tactic_expr; ")" -> a - | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + [ "("; a = tactic_expr; ")" -> { a } + | "["; ">"; tg = tactic_then_gen; "]" -> { + let (tf,tail) = tg in begin match tail with | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) | None -> TacDispatch tf - end - | a = tactic_atom -> TacArg (Loc.tag ~loc:!@loc a) ] ] + end } + | a = tactic_atom -> { TacArg (Loc.tag ~loc a) } ] ] ; failkw: - [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] + [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] ; (* binder_tactic: level 5 of tactic_expr *) binder_tactic: [ RIGHTA [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> - TacFun (it,body) - | "let"; isrec = [IDENT "rec" -> true | -> false]; + { TacFun (it,body) } + | "let"; isrec = [IDENT "rec" -> { true } | -> { false } ]; llc = LIST1 let_clause SEP "with"; "in"; - body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) - | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] + body = tactic_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } + | IDENT "info"; tc = tactic_expr LEVEL "5" -> { TacInfo tc } ] ] ; (* Tactic arguments to the right of an application *) tactic_arg_compat: - [ [ a = tactic_arg -> a - | c = Constr.constr -> (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) + [ [ a = tactic_arg -> { a } + | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } (* Unambiguous entries: tolerated w/o "ltac:" modifier *) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_arg: - [ [ c = constr_eval -> ConstrMayEval c - | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l - | IDENT "type_term"; c=uconstr -> TacPretype c - | IDENT "numgoals" -> TacNumgoals ] ] + [ [ c = constr_eval -> { ConstrMayEval c } + | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } + | IDENT "type_term"; c=uconstr -> { TacPretype c } + | IDENT "numgoals" -> { TacNumgoals } ] ] ; (* If a qualid is given, use its short name. TODO: have the shortest non ambiguous name where dots are replaced by "_"? Probably too verbose most of the time. *) fresh_id: - [ [ s = STRING -> Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) - | qid = qualid -> Locus.ArgVar (CAst.make ~loc:!@loc @@ Libnames.qualid_basename qid) ] ] + [ [ s = STRING -> { Locus.ArgArg s (*| id = ident -> Locus.ArgVar (!@loc,id)*) } + | qid = qualid -> { Locus.ArgVar (CAst.make ~loc @@ Libnames.qualid_basename qid) } ] ] ; constr_eval: [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> - ConstrEval (rtc,c) + { ConstrEval (rtc,c) } | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> - ConstrContext (id,c) + { ConstrContext (id,c) } | IDENT "type"; IDENT "of"; c = Constr.constr -> - ConstrTypeOf c ] ] + { ConstrTypeOf c } ] ] ; constr_may_eval: (* For extensions *) - [ [ c = constr_eval -> c - | c = Constr.constr -> ConstrTerm c ] ] + [ [ c = constr_eval -> { c } + | c = Constr.constr -> { ConstrTerm c } ] ] ; tactic_atom: - [ [ n = integer -> TacGeneric (genarg_of_int n) - | r = reference -> TacCall (Loc.tag ~loc:!@loc (r,[])) - | "()" -> TacGeneric (genarg_of_unit ()) ] ] + [ [ n = integer -> { TacGeneric (genarg_of_int n) } + | r = reference -> { TacCall (Loc.tag ~loc (r,[])) } + | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] ; match_key: - [ [ "match" -> Once - | "lazymatch" -> Select - | "multimatch" -> General ] ] + [ [ "match" -> { Once } + | "lazymatch" -> { Select } + | "multimatch" -> { General } ] ] ; input_fun: - [ [ "_" -> Name.Anonymous - | l = ident -> Name.Name l ] ] + [ [ "_" -> { Name.Anonymous } + | l = ident -> { Name.Name l } ] ] ; let_clause: [ [ idr = identref; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr te) - | na = ["_" -> CAst.make ~loc:!@loc Anonymous]; ":="; te = tactic_expr -> - (na, arg_of_expr te) + { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + { (na, arg_of_expr te) } | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> - (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) ] ] + { (CAst.map (fun id -> Name id) idr, arg_of_expr (TacFun(args,te))) } ] ] ; match_pattern: [ [ IDENT "context"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> - Subterm (oid, pc) - | pc = Constr.lconstr_pattern -> Term pc ] ] + { Subterm (oid, pc) } + | pc = Constr.lconstr_pattern -> { Term pc } ] ] ; match_hyps: - [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) - | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + [ [ na = name; ":"; mp = match_pattern -> { Hyp (na, mp) } + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> { Def (na, mpv, mpt) } | na = name; ":="; mpv = match_pattern -> - let t, ty = + { let t, ty = match mpv with | Term t -> (match t with | { CAst.v = CCast (t, (CastConv ty | CastVM ty | CastNative ty)) } -> Term t, Some (Term ty) | _ -> mpv, None) | _ -> mpv, None - in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) + in Def (na, t, Option.default (Term (CAst.make @@ CHole (None, IntroAnonymous, None))) ty) } ] ] ; match_context_rule: [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; te = tactic_expr -> Pat (largs, mp, te) + "=>"; te = tactic_expr -> { Pat (largs, mp, te) } | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) - | "_"; "=>"; te = tactic_expr -> All te ] ] + "]"; "=>"; te = tactic_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] ; match_context_list: - [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + [ [ mrl = LIST1 match_context_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_context_rule SEP "|" -> { mrl } ] ] ; match_rule: - [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) - | "_"; "=>"; te = tactic_expr -> All te ] ] + [ [ mp = match_pattern; "=>"; te = tactic_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = tactic_expr -> { All te } ] ] ; match_list: - [ [ mrl = LIST1 match_rule SEP "|" -> mrl - | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } + | "|"; mrl = LIST1 match_rule SEP "|" -> { mrl } ] ] ; message_token: - [ [ id = identref -> MsgIdent id - | s = STRING -> MsgString s - | n = integer -> MsgInt n ] ] + [ [ id = identref -> { MsgIdent id } + | s = STRING -> { MsgString s } + | n = integer -> { MsgInt n } ] ] ; ltac_def_kind: - [ [ ":=" -> false - | "::=" -> true ] ] + [ [ ":=" -> { false } + | "::=" -> { true } ] ] ; (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) + { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in - Tacexpr.TacticDefinition (id, TacFun (it, body)) + Tacexpr.TacticDefinition (id, TacFun (it, body)) } | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> - if redef then Tacexpr.TacticRedefinition (name, body) + { if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in - Tacexpr.TacticDefinition (id, body) + Tacexpr.TacticDefinition (id, body) } ] ] ; tactic: - [ [ tac = tactic_expr -> tac ] ] + [ [ tac = tactic_expr -> { tac } ] ] ; range_selector: - [ [ n = natural ; "-" ; m = natural -> (n, m) - | n = natural -> (n, n) ] ] + [ [ n = natural ; "-" ; m = natural -> { (n, m) } + | n = natural -> { (n, n) } ] ] ; (* We unfold a range selectors list once so that we can make a special case * for a unique SelectNth selector. *) range_selector_or_nth: [ [ n = natural ; "-" ; m = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - Goal_select.SelectList ((n, m) :: Option.default [] l) + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { Goal_select.SelectList ((n, m) :: Option.default [] l) } | n = natural; - l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> - let open Goal_select in - Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] + l = OPT [","; l = LIST1 range_selector SEP "," -> { l } ] -> + { let open Goal_select in + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] ; selector_body: - [ [ l = range_selector_or_nth -> l - | test_bracket_ident; "["; id = ident; "]" -> Goal_select.SelectId id ] ] + [ [ l = range_selector_or_nth -> { l } + | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] ; selector: - [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] + [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] ; toplevel_selector: - [ [ sel = selector_body; ":" -> sel - | "!"; ":" -> Goal_select.SelectAlreadyFocused - | IDENT "all"; ":" -> Goal_select.SelectAll ] ] + [ [ sel = selector_body; ":" -> { sel } + | "!"; ":" -> { Goal_select.SelectAlreadyFocused } + | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] ; tactic_mode: - [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g - | g = OPT toplevel_selector; "{" -> Vernacexpr.VernacSubproof g ] ] + [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> { tac g } + | g = OPT toplevel_selector; "{" -> { Vernacexpr.VernacSubproof g } ] ] ; command: [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> - Vernacexpr.VernacProof (Some (in_tac ta), l) + l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> + { Vernacexpr.VernacProof (Some (in_tac ta), l) } | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; - ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> - Vernacexpr.VernacProof (ta,Some l) ] ] + ta = OPT [ "with"; ta = Pltac.tactic -> { in_tac ta } ] -> + { Vernacexpr.VernacProof (ta,Some l) } ] ] ; hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - Hints.HintsExtern (n,c, in_tac tac) ] ] + { Hints.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> - let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in - CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, Some arg) ] ] + { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] ; END +{ + open Stdarg open Tacarg open Vernacexpr @@ -390,24 +398,36 @@ let vernac_solve n info tcom b = let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s -VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector -| [ toplevel_selector(s) ] -> [ s ] +} + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY { pr_ltac_selector } +| [ toplevel_selector(s) ] -> { s } END +{ + let pr_ltac_info n = str "Info" ++ spc () ++ int n -VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info -| [ "Info" natural(n) ] -> [ n ] +} + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY { pr_ltac_info } +| [ "Info" natural(n) ] -> { n } END +{ + let pr_ltac_use_default b = if b then (* Bug: a space is inserted before "..." *) str ".." else mt () -VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default -| [ "." ] -> [ false ] -| [ "..." ] -> [ true ] +} + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY { pr_ltac_use_default } +| [ "." ] -> { false } +| [ "..." ] -> { true } END +{ + let is_anonymous_abstract = function | TacAbstract (_,None) -> true | TacSolve [TacAbstract (_,None)] -> true @@ -418,36 +438,44 @@ let rm_abstract = function | x -> x 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) ] => - [ classify_as_proofstep ] -> [ +} + +VERNAC { tactic_mode } EXTEND VernacSolve +| [ 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 - ] -| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ + } +| [ "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 let parallel = `Yes (solving_tac,anon_abstracting_tac) in let pbr = if solving_tac then Some "par" else None in VtProofStep{ parallel = parallel; proof_block_detection = pbr }, VtLater - ] -> [ + } -> { let t = rm_abstract t in vernac_solve Goal_select.SelectAll n t def - ] + } END +{ + let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" -VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level -| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +} + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY { pr_ltac_tactic_level } +| [ "(" "at" "level" natural(n) ")" ] -> { n } END VERNAC ARGUMENT EXTEND ltac_production_sep -| [ "," string(sep) ] -> [ sep ] +| [ "," string(sep) ] -> { sep } END +{ + let pr_ltac_production_item = function | Tacentries.TacTerm s -> quote (str s) | Tacentries.TacNonTerm (_, ((arg, None), None)) -> str arg @@ -459,35 +487,38 @@ let pr_ltac_production_item = function in str arg ++ str "(" ++ Id.print id ++ sep ++ str ")" -VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item -| [ string(s) ] -> [ Tacentries.TacTerm s ] +} + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY { pr_ltac_production_item } +| [ string(s) ] -> { Tacentries.TacTerm s } | [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) ] + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, sep), Some p)) } | [ ident(nt) ] -> - [ Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) ] + { Tacentries.TacNonTerm (Loc.tag ~loc ((Id.to_string nt, None), None)) } END -VERNAC COMMAND FUNCTIONAL EXTEND VernacTacticNotation +VERNAC COMMAND EXTEND VernacTacticNotation | [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => - [ VtSideff [], VtNow ] -> - [ fun ~atts ~st -> let open Vernacinterp in + { VtSideff [], VtNow } -> + { let open Vernacinterp in let n = Option.default 0 n in let deprecation = atts.deprecated in Tacentries.add_tactic_notation (Locality.make_module_locality atts.locality) n ?deprecation r e; - st - ] + } END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - [ Feedback.msg_notice (Tacintern.print_ltac r) ] + { Feedback.msg_notice (Tacintern.print_ltac r) } END VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY | [ "Locate" "Ltac" reference(r) ] -> - [ Tacentries.print_located_tactic r ] + { Tacentries.print_located_tactic r } END +{ + let pr_ltac_ref = Libnames.pr_qualid let pr_tacdef_body tacdef_body = @@ -506,23 +537,24 @@ let pr_tacdef_body tacdef_body = ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) ++ Pptactic.pr_raw_tactic body +} + VERNAC ARGUMENT EXTEND ltac_tacdef_body -PRINTED BY pr_tacdef_body -| [ tacdef_body(t) ] -> [ t ] +PRINTED BY { pr_tacdef_body } +| [ tacdef_body(t) ] -> { t } END -VERNAC COMMAND FUNCTIONAL EXTEND VernacDeclareTacticDefinition -| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => { VtSideff (List.map (function | TacticDefinition ({CAst.v=r},_) -> r | TacticRedefinition (qid,_) -> qualid_basename qid) l), VtLater - ] -> [ fun ~atts ~st -> let open Vernacinterp in + } -> { let open Vernacinterp in let deprecation = atts.deprecated in Tacentries.register_ltac (Locality.make_module_locality atts.locality) ?deprecation l; - st - ] + } END VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY -| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] +| [ "Print" "Ltac" "Signatures" ] -> { Tacentries.print_ltacs () } END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.mlg index 1f56244c75..26f2b08d3a 100644 --- a/plugins/ltac/g_obligations.ml4 +++ b/plugins/ltac/g_obligations.mlg @@ -12,6 +12,8 @@ Syntax for the subtac terms and types. Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) +{ + open Constrexpr open Constrexpr_ops open Stdarg @@ -57,22 +59,26 @@ let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: withtac; withtac: - [ [ "with"; t = Tactic.tactic -> Some t - | -> None ] ] + [ [ "with"; t = Tactic.tactic -> { Some t } + | -> { None } ] ] ; Constr.closed_binder: - [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> - let typ = mkAppC (sigref !@loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in - [CLocalAssum ([id], default_binder_kind, typ)] + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> { + let typ = mkAppC (sigref loc, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [CLocalAssum ([id], default_binder_kind, typ)] } ] ]; END +{ + open Obligations let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac @@ -80,77 +86,81 @@ let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) -VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +} + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } | [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, Some name, Some t) tac ] + { obligation (num, Some name, Some t) tac } | [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> - [ obligation (num, Some name, None) tac ] + { obligation (num, Some name, None) tac } | [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> - [ obligation (num, None, Some t) tac ] + { obligation (num, None, Some t) tac } | [ "Obligation" integer(num) withtac(tac) ] -> - [ obligation (num, None, None) tac ] + { obligation (num, None, None) tac } | [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> - [ next_obligation (Some name) tac ] -| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] + { next_obligation (Some name) tac } +| [ "Next" "Obligation" withtac(tac) ] -> { next_obligation None tac } END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF | [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> - [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] + { try_solve_obligation num None (Some (Tacinterp.interp t)) } END VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> - [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] + { try_solve_obligations (Some name) (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" "with" tactic(t) ] -> - [ try_solve_obligations None (Some (Tacinterp.interp t)) ] + { try_solve_obligations None (Some (Tacinterp.interp t)) } | [ "Solve" "Obligations" ] -> - [ try_solve_obligations None None ] + { try_solve_obligations None None } END VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF | [ "Solve" "All" "Obligations" "with" tactic(t) ] -> - [ solve_all_obligations (Some (Tacinterp.interp t)) ] + { solve_all_obligations (Some (Tacinterp.interp t)) } | [ "Solve" "All" "Obligations" ] -> - [ solve_all_obligations None ] + { solve_all_obligations None } END VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF -| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] -| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +| [ "Admit" "Obligations" "of" ident(name) ] -> { admit_obligations (Some name) } +| [ "Admit" "Obligations" ] -> { admit_obligations None } END -VERNAC COMMAND FUNCTIONAL EXTEND Set_Solver CLASSIFIED AS SIDEFF -| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ - fun ~atts ~st -> begin +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> { let open Vernacinterp in set_default_tactic (Locality.make_section_locality atts.locality) (Tacintern.glob_tactic t); - st - end] + } END +{ + open Pp +} + VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY -| [ "Show" "Obligation" "Tactic" ] -> [ - Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +| [ "Show" "Obligation" "Tactic" ] -> { + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) } END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY -| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] -| [ "Obligations" ] -> [ show_obligations None ] +| [ "Obligations" "of" ident(name) ] -> { show_obligations (Some name) } +| [ "Obligations" ] -> { show_obligations None } END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] +| [ "Preterm" "of" ident(name) ] -> { Feedback.msg_info (show_term (Some name)) } +| [ "Preterm" ] -> { Feedback.msg_info (show_term None) } END -open Pp +{ (* Declare a printer for the content of Program tactics *) let () = @@ -159,3 +169,5 @@ let () = | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac in Pptactic.declare_extra_vernac_genarg_pprule wit_withtac printer + +} diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.mlg index f1634f1561..3e47724c4c 100644 --- a/plugins/ltac/g_rewrite.ml4 +++ b/plugins/ltac/g_rewrite.mlg @@ -10,6 +10,8 @@ (* Syntax for rewriting with strategies *) +{ + open Names open Locus open Constrexpr @@ -25,8 +27,14 @@ open Pcoq.Constr open Pvernac.Vernac_ open Pltac +let wit_hyp = wit_var + +} + DECLARE PLUGIN "ltac_plugin" +{ + type constr_expr_with_bindings = constr_expr with_bindings type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings @@ -43,19 +51,23 @@ let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings let subst_glob_constr_with_bindings s c = Tacsubst.subst_glob_with_bindings s c +} + ARGUMENT EXTEND glob_constr_with_bindings - PRINTED BY pr_glob_constr_with_bindings_sign + PRINTED BY { pr_glob_constr_with_bindings_sign } - INTERPRETED BY interp_glob_constr_with_bindings - GLOBALIZED BY glob_glob_constr_with_bindings - SUBSTITUTED BY subst_glob_constr_with_bindings + INTERPRETED BY { interp_glob_constr_with_bindings } + GLOBALIZED BY { glob_glob_constr_with_bindings } + SUBSTITUTED BY { subst_glob_constr_with_bindings } - RAW_PRINTED BY pr_constr_expr_with_bindings - GLOB_PRINTED BY pr_glob_constr_with_bindings + RAW_PRINTED BY { pr_constr_expr_with_bindings } + GLOB_PRINTED BY { pr_glob_constr_with_bindings } - [ constr_with_bindings(bl) ] -> [ bl ] +| [ constr_with_bindings(bl) ] -> { bl } END +{ + type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast @@ -78,53 +90,61 @@ let pr_glob_strategy prc prlc _ (s : glob_strategy) = in Rewrite.pr_strategy prc prr s +} + ARGUMENT EXTEND rewstrategy - PRINTED BY pr_strategy - - INTERPRETED BY interp_strategy - GLOBALIZED BY glob_strategy - SUBSTITUTED BY subst_strategy - - RAW_PRINTED BY pr_raw_strategy - GLOB_PRINTED BY pr_glob_strategy - - [ glob(c) ] -> [ StratConstr (c, true) ] - | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] - | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] - | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] - | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] - | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] - | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] - | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] - | [ "id" ] -> [ StratId ] - | [ "fail" ] -> [ StratFail ] - | [ "refl" ] -> [ StratRefl ] - | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] - | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] - | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] - | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] - | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] - | [ "(" rewstrategy(h) ")" ] -> [ h ] - | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] - | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] - | [ "hints" preident(h) ] -> [ StratHints (false, h) ] - | [ "terms" constr_list(h) ] -> [ StratTerms h ] - | [ "eval" red_expr(r) ] -> [ StratEval r ] - | [ "fold" constr(c) ] -> [ StratFold c ] + PRINTED BY { pr_strategy } + + INTERPRETED BY { interp_strategy } + GLOBALIZED BY { glob_strategy } + SUBSTITUTED BY { subst_strategy } + + RAW_PRINTED BY { pr_raw_strategy } + GLOB_PRINTED BY { pr_glob_strategy } + + | [ glob(c) ] -> { StratConstr (c, true) } + | [ "<-" constr(c) ] -> { StratConstr (c, false) } + | [ "subterms" rewstrategy(h) ] -> { StratUnary (Subterms, h) } + | [ "subterm" rewstrategy(h) ] -> { StratUnary (Subterm, h) } + | [ "innermost" rewstrategy(h) ] -> { StratUnary(Innermost, h) } + | [ "outermost" rewstrategy(h) ] -> { StratUnary(Outermost, h) } + | [ "bottomup" rewstrategy(h) ] -> { StratUnary(Bottomup, h) } + | [ "topdown" rewstrategy(h) ] -> { StratUnary(Topdown, h) } + | [ "id" ] -> { StratId } + | [ "fail" ] -> { StratFail } + | [ "refl" ] -> { StratRefl } + | [ "progress" rewstrategy(h) ] -> { StratUnary (Progress, h) } + | [ "try" rewstrategy(h) ] -> { StratUnary (Try, h) } + | [ "any" rewstrategy(h) ] -> { StratUnary (Any, h) } + | [ "repeat" rewstrategy(h) ] -> { StratUnary (Repeat, h) } + | [ rewstrategy(h) ";" rewstrategy(h') ] -> { StratBinary (Compose, h, h') } + | [ "(" rewstrategy(h) ")" ] -> { h } + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> { StratBinary (Choice, h, h') } + | [ "old_hints" preident(h) ] -> { StratHints (true, h) } + | [ "hints" preident(h) ] -> { StratHints (false, h) } + | [ "terms" constr_list(h) ] -> { StratTerms h } + | [ "eval" red_expr(r) ] -> { StratEval r } + | [ "fold" constr(c) ] -> { StratFold c } END (* By default the strategy for "rewrite_db" is top-down *) +{ + let db_strat db = StratUnary (Topdown, StratHints (false, db)) let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) +} + TACTIC EXTEND rewrite_strat -| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] -| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] -| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] -| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> { cl_rewrite_clause_strat s (Some id) } +| [ "rewrite_strat" rewstrategy(s) ] -> { cl_rewrite_clause_strat s None } +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db db (Some id) } +| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db db None } END +{ + let clsubstitute o c = Proofview.Goal.enter begin fun gl -> let is_tac id = match DAst.get (fst (fst (snd c))) with GVar id' when Id.equal id' id -> true | _ -> false in @@ -137,59 +157,63 @@ let clsubstitute o c = (None :: List.map (fun id -> Some id) hyps) end +} + TACTIC EXTEND substitute -| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> { clsubstitute o c } END (* Compatibility with old Setoids *) TACTIC EXTEND setoid_rewrite - [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] - -> [ cl_rewrite_clause c o AllOccurrences None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> { cl_rewrite_clause c o AllOccurrences None } | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> - [ cl_rewrite_clause c o AllOccurrences (Some id) ] + { cl_rewrite_clause c o AllOccurrences (Some id) } | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> - [ cl_rewrite_clause c o (occurrences_of occ) None ] + { cl_rewrite_clause c o (occurrences_of occ) None } | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> - [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] + { cl_rewrite_clause c o (occurrences_of occ) (Some id) } END VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] + { declare_relation a aeq n (Some lemma1) (Some lemma2) None } | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None None ] + { declare_relation a aeq n (Some lemma1) None None } | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation a aeq n None None None ] + { declare_relation a aeq n None None None } END VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) None ] + { declare_relation a aeq n None (Some lemma2) None } | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] + { declare_relation a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] + { declare_relation a aeq n (Some lemma1) None (Some lemma3) } | [ "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 a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + { declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation a aeq n None None (Some lemma3) ] + { declare_relation a aeq n None None (Some lemma3) } END +{ + type binders_argtype = local_binder_expr list let wit_binders = @@ -203,95 +227,92 @@ let () = open Pcoq -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: binders; binders: - [ [ b = Pcoq.Constr.binders -> b ] ]; + [ [ b = Pcoq.Constr.binders -> { b } ] ]; END VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] + { declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None } | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] + { declare_relation ~binders:b a aeq n (Some lemma1) None None } | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None None ] + { declare_relation ~binders:b a aeq n None None None } END VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] + { declare_relation ~binders:b a aeq n None (Some lemma2) None } | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] + { declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) } END VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF - [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] + { declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) } | [ "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 ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + { declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) } | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> - [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] + { declare_relation ~binders:b a aeq n None None (Some lemma3) } END -VERNAC COMMAND FUNCTIONAL EXTEND AddSetoid1 CLASSIFIED AS SIDEFF - [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + | [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + { let open Vernacinterp in add_setoid (not (Locality.make_section_locality atts.locality)) [] a aeq t n; - st - ] + } | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> - [ fun ~atts ~st -> let open Vernacinterp in + { let open Vernacinterp in add_setoid (not (Locality.make_section_locality atts.locality)) binders a aeq t n; - st - ] + } | [ "Add" "Morphism" constr(m) ":" ident(n) ] (* This command may or may not open a goal *) - => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] - -> [ fun ~atts ~st -> let open Vernacinterp in + => { Vernacexpr.VtUnknown, Vernacexpr.VtNow } + -> { let open Vernacinterp in add_morphism_infer (not (Locality.make_section_locality atts.locality)) m n; - st - ] + } | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in + => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + -> { let open Vernacinterp in add_morphism (not (Locality.make_section_locality atts.locality)) [] m s n; - st - ] + } | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] - => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] - -> [ fun ~atts ~st -> let open Vernacinterp in + => { Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) } + -> { let open Vernacinterp in add_morphism (not (Locality.make_section_locality atts.locality)) binders m s n; - st - ] + } END TACTIC EXTEND setoid_symmetry - [ "setoid_symmetry" ] -> [ setoid_symmetry ] - | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] + | [ "setoid_symmetry" ] -> { setoid_symmetry } + | [ "setoid_symmetry" "in" hyp(n) ] -> { setoid_symmetry_in n } END TACTIC EXTEND setoid_reflexivity -[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +| [ "setoid_reflexivity" ] -> { setoid_reflexivity } END TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] -| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] +| [ "setoid_transitivity" constr(t) ] -> { setoid_transitivity (Some t) } +| [ "setoid_etransitivity" ] -> { setoid_transitivity None } 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) ] +| [ "Print" "Rewrite" "HintDb" preident(s) ] -> + { let sigma, env = Pfedit.get_current_context () in + Feedback.msg_notice (Autorewrite.print_rewrite_hintdb env sigma s) } END diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack index ec96e1bbdd..e83eab20dc 100644 --- a/plugins/ltac/ltac_plugin.mlpack +++ b/plugins/ltac/ltac_plugin.mlpack @@ -7,10 +7,10 @@ Pltac Taccoerce Tactic_debug Tacintern -Tacentries Profile_ltac Tactic_matching Tacinterp +Tacentries Evar_tactics Tactic_option Extraargs diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.mlg index 983e1578be..2713819c7b 100644 --- a/plugins/ltac/profile_ltac_tactics.ml4 +++ b/plugins/ltac/profile_ltac_tactics.mlg @@ -8,13 +8,19 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + (** Ltac profiling entrypoints *) open Profile_ltac open Stdarg +} + DECLARE PLUGIN "ltac_plugin" +{ + let tclSET_PROFILING b = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) @@ -33,42 +39,44 @@ let tclRESTART_TIMER s = let tclFINISH_TIMING ?(prefix="Timer") (s : string option) = Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> finish_timing ~prefix s)) +} + TACTIC EXTEND start_ltac_profiling -| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +| [ "start" "ltac" "profiling" ] -> { tclSET_PROFILING true } END TACTIC EXTEND stop_ltac_profiling -| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +| [ "stop" "ltac" "profiling" ] -> { tclSET_PROFILING false } END TACTIC EXTEND reset_ltac_profile -| [ "reset" "ltac" "profile" ] -> [ tclRESET_PROFILE ] +| [ "reset" "ltac" "profile" ] -> { tclRESET_PROFILE } END TACTIC EXTEND show_ltac_profile -| [ "show" "ltac" "profile" ] -> [ tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "show" "ltac" "profile" "cutoff" int(n) ] -> [ tclSHOW_PROFILE ~cutoff:(float_of_int n) ] -| [ "show" "ltac" "profile" string(s) ] -> [ tclSHOW_PROFILE_TACTIC s ] +| [ "show" "ltac" "profile" ] -> { tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff } +| [ "show" "ltac" "profile" "cutoff" int(n) ] -> { tclSHOW_PROFILE ~cutoff:(float_of_int n) } +| [ "show" "ltac" "profile" string(s) ] -> { tclSHOW_PROFILE_TACTIC s } END TACTIC EXTEND restart_timer -| [ "restart_timer" string_opt(s) ] -> [ tclRESTART_TIMER s ] +| [ "restart_timer" string_opt(s) ] -> { tclRESTART_TIMER s } END TACTIC EXTEND finish_timing -| [ "finish_timing" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix:"Timer" s ] -| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> [ tclFINISH_TIMING ~prefix s ] +| [ "finish_timing" string_opt(s) ] -> { tclFINISH_TIMING ~prefix:"Timer" s } +| [ "finish_timing" "(" string(prefix) ")" string_opt(s) ] -> { tclFINISH_TIMING ~prefix s } END VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF - [ "Reset" "Ltac" "Profile" ] -> [ reset_profile () ] +| [ "Reset" "Ltac" "Profile" ] -> { reset_profile () } END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY -| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +| [ "Show" "Ltac" "Profile" ] -> { print_results ~cutoff:!Flags.profile_ltac_cutoff } +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> { print_results ~cutoff:(float_of_int n) } END VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY - [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +| [ "Show" "Ltac" "Profile" string(s) ] -> { print_results_tactic s } END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 5b8bd6d01a..9dd98a4ab7 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -56,12 +56,14 @@ let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] +let find_reference dir s = + Coqlib.find_reference "generalized rewriting" dir s +[@@warning "-3"] + let lazy_find_reference dir s = - let gr = lazy (Coqlib.coq_reference "generalized rewriting" dir s) in + let gr = lazy (find_reference dir s) in fun () -> Lazy.force gr -let find_reference dir s = Coqlib.coq_reference "generalized rewriting" dir s - type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) let find_global dir s = @@ -74,13 +76,13 @@ let find_global dir s = (** Global constants. *) -let coq_eq_ref = lazy_find_reference ["Init"; "Logic"] "eq" -let coq_eq = find_global ["Init"; "Logic"] "eq" -let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" -let coq_all = find_global ["Init"; "Logic"] "all" -let impl = find_global ["Program"; "Basics"] "impl" +let coq_eq_ref () = Coqlib.lib_ref "core.eq.type" +let coq_eq = find_global ["Coq"; "Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Coq"; "Init"; "Logic"] "f_equal" +let coq_all = find_global ["Coq"; "Init"; "Logic"] "all" +let impl = find_global ["Coq"; "Program"; "Basics"] "impl" -(** Bookkeeping which evars are constraints so that we can +(** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) let goalevars evars = fst evars @@ -154,7 +156,7 @@ end) = struct let respectful = find_global morphisms "respectful" let respectful_ref = lazy_find_reference morphisms "respectful" - let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + let default_relation = find_global ["Coq"; "Classes"; "SetoidTactics"] "DefaultRelation" let coq_forall = find_global morphisms "forall_def" @@ -374,12 +376,12 @@ let type_app_poly env env evd f args = module PropGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "RelationClasses"] - let morphisms = ["Classes"; "Morphisms"] - let relation = ["Relations";"Relation_Definitions"], "relation" + let relation_classes = ["Coq"; "Classes"; "RelationClasses"] + let morphisms = ["Coq"; "Classes"; "Morphisms"] + let relation = ["Coq"; "Relations";"Relation_Definitions"], "relation" let app_poly = app_poly_nocheck - let arrow = find_global ["Program"; "Basics"] "arrow" - let coq_inverse = find_global ["Program"; "Basics"] "flip" + let arrow = find_global ["Coq"; "Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Coq"; "Program"; "Basics"] "flip" end module G = GlobalBindings(Consts) @@ -395,12 +397,12 @@ end module TypeGlobal = struct module Consts = struct - let relation_classes = ["Classes"; "CRelationClasses"] - let morphisms = ["Classes"; "CMorphisms"] + let relation_classes = ["Coq"; "Classes"; "CRelationClasses"] + let morphisms = ["Coq"; "Classes"; "CMorphisms"] let relation = relation_classes, "crelation" let app_poly = app_poly_check - let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" - let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + let arrow = find_global ["Coq"; "Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Coq"; "Classes"; "CRelationClasses"] "flip" end module G = GlobalBindings(Consts) @@ -740,9 +742,9 @@ let new_global (evars, cstrs) gr = (sigma, cstrs), c let make_eq sigma = - new_global sigma (Coqlib.build_coq_eq ()) + new_global sigma Coqlib.(lib_ref "core.eq.type") let make_eq_refl sigma = - new_global sigma (Coqlib.build_coq_eq_refl ()) + new_global sigma Coqlib.(lib_ref "core.eq.refl") let get_rew_prf evars r = match r.rew_prf with | RewPrf (rel, prf) -> evars, (rel, prf) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 636cb8ebf8..16cff420bd 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -187,7 +187,7 @@ let add_tactic_entry (kn, ml, tg) state = | TacTerm s -> GramTerminal s | TacNonTerm (loc, (s, ido)) -> let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in - GramNonTerminal (Loc.tag ?loc @@ (Option.map (fun _ -> typ) ido, e)) + GramNonTerminal (Loc.tag ?loc @@ (typ, e)) in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in @@ -556,18 +556,14 @@ let () = ] in register_grammars_by_name "tactic" entries -let get_identifier id = +let get_identifier i = (** Workaround for badly-designed generic arguments lacking a closure *) - Names.Id.of_string_soft ("$" ^ id) - + Names.Id.of_string_soft (Printf.sprintf "$%i" i) type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml @@ -581,18 +577,16 @@ let rec untype_user_symbol : type a b c. (a,b,c) ty_user_symbol -> Genarg.ArgT.a | TUentry a -> Uentry (Genarg.ArgT.Any a) | TUentryl (a,i) -> Uentryl (Genarg.ArgT.Any a,i) -let rec clause_of_sign : type a. a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = - fun sign -> match sign with +let rec clause_of_sign : type a. int -> a ty_sig -> Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list = + fun i sign -> match sign with | TyNil -> [] - | TyIdent (s, sig') -> TacTerm s :: clause_of_sign sig' - | TyArg (a, id, sig') -> - let id = get_identifier id in - TacNonTerm (None,(untype_user_symbol a,Some id)) :: clause_of_sign sig' - | TyAnonArg (a, sig') -> - TacNonTerm (None,(untype_user_symbol a,None)) :: clause_of_sign sig' + | TyIdent (s, sig') -> TacTerm s :: clause_of_sign i sig' + | TyArg (a, sig') -> + let id = Some (get_identifier i) in + TacNonTerm (None, (untype_user_symbol a, id)) :: clause_of_sign (i + 1) sig' let clause_of_ty_ml = function - | TyML (t,_) -> clause_of_sign t + | TyML (t,_) -> clause_of_sign 1 t let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = fun sign tac -> @@ -603,7 +597,7 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i | _ :: _ -> assert false end | TyIdent (s, sig') -> eval_sign sig' tac - | TyArg (a, _, sig') -> + | TyArg (a, sig') -> let f = eval_sign sig' in begin fun tac vals ist -> match vals with | [] -> assert false @@ -611,7 +605,6 @@ let rec eval_sign : type a. a ty_sig -> a -> Geninterp.Val.t list -> Geninterp.i let v' = Taccoerce.Value.cast (topwit (Egramml.proj_symbol a)) v in f (tac v') vals ist end tac - | TyAnonArg (a, sig') -> eval_sign sig' tac let eval : ty_ml -> Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic = function | TyML (t,tac) -> eval_sign t tac @@ -623,14 +616,12 @@ let is_constr_entry = function let rec only_constr : type a. a ty_sig -> bool = function | TyNil -> true | TyIdent(_,_) -> false -| TyArg (u, _, s) -> if is_constr_entry u then only_constr s else false -| TyAnonArg (u, s) -> if is_constr_entry u then only_constr s else false +| TyArg (u, s) -> if is_constr_entry u then only_constr s else false -let rec mk_sign_vars : type a. a ty_sig -> Name.t list = function +let rec mk_sign_vars : type a. int -> a ty_sig -> Name.t list = fun i tu -> match tu with | TyNil -> [] -| TyIdent (_,s) -> mk_sign_vars s -| TyArg (_, name, s) -> Name (get_identifier name) :: mk_sign_vars s -| TyAnonArg (_, s) -> Anonymous :: mk_sign_vars s +| TyIdent (_,s) -> mk_sign_vars i s +| TyArg (_, s) -> Name (get_identifier i) :: mk_sign_vars (i + 1) s let dummy_id = Id.of_string "_" @@ -661,12 +652,7 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = | [TyML (TyIdent (name, s),tac) as ml_tac] when only_constr s -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) - (* - let patt = make_patt rem in - let vars = List.map make_var rem in - let vars = mlexpr_of_list (mlexpr_of_name mlexpr_of_ident) vars in - *) - let vars = mk_sign_vars s in + let vars = mk_sign_vars 1 s in let ml = { Tacexpr.mltac_name = ml_tactic_name; Tacexpr.mltac_index = 0 } in let tac = match s with | TyNil -> eval ml_tac @@ -687,3 +673,96 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = let obj () = add_ml_tactic_notation ml_tactic_name ~level ?deprecation (List.map clause_of_ty_ml sign) in Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign); Mltop.declare_cache_obj obj plugin_name + + +(** ARGUMENT EXTEND *) + +open Geninterp + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Val.t) interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacentries.argument_rule; + arg_tag : 'c Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +let intern_fun (type a b c) name (arg : (a, b, c) tactic_argument) : (a, b) Genintern.intern_fun = +match arg.arg_intern with +| ArgInternFun f -> f +| ArgInternWit wit -> + fun ist v -> + let ans = Genarg.out_gen (glbwit wit) (Tacintern.intern_genarg ist (Genarg.in_gen (rawwit wit) v)) in + (ist, ans) + +let subst_fun (type a b c) (arg : (a, b, c) tactic_argument) : b Genintern.subst_fun = +match arg.arg_subst with +| ArgSubstFun f -> f +| ArgSubstWit wit -> + fun s v -> + let ans = Genarg.out_gen (glbwit wit) (Tacsubst.subst_genarg s (Genarg.in_gen (glbwit wit) v)) in + ans + +let interp_fun (type a b c) name (arg : (a, b, c) tactic_argument) (tag : c Val.tag) : (b, Val.t) interp_fun = +match arg.arg_interp with +| ArgInterpRet -> (fun ist v -> Ftactic.return (Geninterp.Val.inject tag v)) +| ArgInterpFun f -> f +| ArgInterpWit wit -> + (fun ist x -> Tacinterp.interp_genarg ist (Genarg.in_gen (glbwit wit) x)) +| ArgInterpLegacy f -> + (fun ist v -> Ftactic.enter (fun gl -> + let (sigma, v) = Tacmach.New.of_old (fun gl -> f ist gl v) gl in + let v = Geninterp.Val.inject tag v in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Ftactic.return v) + )) + +let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = + let wit = Genarg.create_arg name in + let () = Genintern.register_intern0 wit (intern_fun name arg) in + let () = Genintern.register_subst0 wit (subst_fun arg) in + let tag = match arg.arg_tag with + | None -> + let () = register_val0 wit None in + val_tag (topwit wit) + | Some tag -> + let () = register_val0 wit (Some tag) in + tag + in + let () = register_interp0 wit (interp_fun name arg tag) in + let entry = match arg.arg_parsing with + | Vernacentries.Arg_alias e -> + let () = Pcoq.register_grammar wit e in + e + | Vernacentries.Arg_rules rules -> + let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in + e + in + let (rpr, gpr, tpr) = arg.arg_printer in + let () = Pptactic.declare_extra_genarg_pprule wit rpr gpr tpr in + let () = create_ltac_quotation name + (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v)) + (entry, None) + in + (wit, entry) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 138a584e01..5b4bedb50a 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -70,15 +70,71 @@ val print_ltacs : unit -> unit val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +(** {5 TACTIC EXTEND} *) + type _ ty_sig = | TyNil : (Geninterp.interp_sign -> unit Proofview.tactic) ty_sig | TyIdent : string * 'r ty_sig -> 'r ty_sig -| TyArg : - ('a, 'b, 'c) Extend.ty_user_symbol * string * 'r ty_sig -> ('c -> 'r) ty_sig -| TyAnonArg : - ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> 'r ty_sig +| TyArg : ('a, 'b, 'c) Extend.ty_user_symbol * 'r ty_sig -> ('c -> 'r) ty_sig type ty_ml = TyML : 'r ty_sig * 'r -> ty_ml val tactic_extend : string -> string -> level:Int.t -> ?deprecation:deprecation -> ty_ml list -> unit + +(** {5 ARGUMENT EXTEND} *) + +(** + + This is the main entry point for the ARGUMENT EXTEND macro that allows to + easily create user-made Ltac arguments. + + + Each argument has three type parameters. See {!Genarg} for more details. + There are two kinds of Ltac arguments, uniform and non-uniform. The former + have the same type at each level (raw, glob, top) while the latter may vary. + + When declaring an argument one must provide the following data: + - Internalization : raw -> glob + - Substitution : glob -> glob + - Interpretation : glob -> Ltac dynamic value + - Printing for every level + - An optional toplevel tag of type top (with the proviso that the + interpretation function only produces values with this tag) + + This data can be either given explicitly with the [Fun] constructors, or it + can be inherited from another argument with the [Wit] constructors. + +*) + +type ('a, 'b, 'c) argument_printer = + 'a Pptactic.raw_extra_genarg_printer * + 'b Pptactic.glob_extra_genarg_printer * + 'c Pptactic.extra_genarg_printer + +type ('a, 'b) argument_intern = +| ArgInternFun : ('a, 'b) Genintern.intern_fun -> ('a, 'b) argument_intern +| ArgInternWit : ('a, 'b, 'c) Genarg.genarg_type -> ('a, 'b) argument_intern + +type 'b argument_subst = +| ArgSubstFun : 'b Genintern.subst_fun -> 'b argument_subst +| ArgSubstWit : ('a, 'b, 'c) Genarg.genarg_type -> 'b argument_subst + +type ('b, 'c) argument_interp = +| ArgInterpRet : ('c, 'c) argument_interp +| ArgInterpFun : ('b, Geninterp.Val.t) Geninterp.interp_fun -> ('b, 'c) argument_interp +| ArgInterpWit : ('a, 'b, 'r) Genarg.genarg_type -> ('b, 'c) argument_interp +| ArgInterpLegacy : + (Geninterp.interp_sign -> Proof_type.goal Evd.sigma -> 'b -> Evd.evar_map * 'c) -> ('b, 'c) argument_interp + +type ('a, 'b, 'c) tactic_argument = { + arg_parsing : 'a Vernacentries.argument_rule; + arg_tag : 'c Geninterp.Val.tag option; + arg_intern : ('a, 'b) argument_intern; + arg_subst : 'b argument_subst; + arg_interp : ('b, 'c) argument_interp; + arg_printer : ('a, 'b, 'c) argument_printer; +} + +val argument_extend : name:string -> ('a, 'b, 'c) tactic_argument -> + ('a, 'b, 'c) Genarg.genarg_type * 'a Pcoq.Entry.t diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index ae05cf5459..dd6319d5c4 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -32,7 +32,7 @@ Ltac zchange := Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. -Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true). +Ltac zchecker_abstract := abstract (zchange ; vm_cast_no_check (eq_refl true)). Ltac zchecker := zchecker_no_abstract. diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 158ddb589b..5f01f981ef 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -53,12 +53,11 @@ 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 "plugins/micromega/micromega.ml" *) -(* Recursive Extraction *) -(* List.map simpl_cone (*map_cone indexes*) *) -(* denorm Qpower vm_add *) -(* n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. *) - +(*Extraction "micromega.ml" +(*Recursive Extraction*) 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: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index ddf4064a03..2880a05d8d 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -179,6 +179,8 @@ Definition qunsat := check_inconsistent 0 Qeq_bool Qle_bool. 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 QTautoChecker (f : BFormula (Formula Q)) (w: list QWitness) : bool := diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 892858e63f..f341a04e03 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -162,8 +162,8 @@ Declare Equivalent Keys psub RingMicromega.psub. Definition padd := padd Z0 Z.add Zeq_bool. Declare Equivalent Keys padd RingMicromega.padd. -Definition norm := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. -Declare Equivalent Keys norm RingMicromega.norm. +Definition normZ := norm 0 1 Z.add Z.mul Z.sub Z.opp Zeq_bool. +Declare Equivalent Keys normZ RingMicromega.norm. Definition eval_pol := eval_pol Z.add Z.mul (fun x => x). Declare Equivalent Keys eval_pol RingMicromega.eval_pol. @@ -180,7 +180,7 @@ Proof. apply (eval_pol_add Zsor ZSORaddon). Qed. -Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (norm e) . +Lemma eval_pol_norm : forall env e, eval_expr env e = eval_pol env (normZ e) . Proof. intros. apply (eval_pol_norm Zsor ZSORaddon). @@ -188,8 +188,8 @@ Qed. Definition xnormalise (t:Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil @@ -225,8 +225,8 @@ Qed. Definition xnegate (t:RingMicromega.Formula Z) : list (NFormula Z) := let (lhs,o,rhs) := t in - let lhs := norm lhs in - let rhs := norm rhs in + let lhs := normZ lhs in + let rhs := normZ rhs in match o with | OpEq => (psub lhs rhs,Equal) :: nil | OpNEq => ((psub lhs (padd rhs (Pc 1))),NonStrict)::((psub rhs (padd lhs (Pc 1))),NonStrict)::nil diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 3a9709b6ce..af292c088f 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -28,109 +28,80 @@ module Mc = Micromega module Ml2C = Mutils.CamlToCoq module C2Ml = Mutils.CoqToCaml +let use_simplex = ref true + open Mutils type 'a number_spec = { - bigint_to_number : big_int -> 'a; - number_to_num : 'a -> num; - zero : 'a; - unit : 'a; - mult : 'a -> 'a -> 'a; - eqb : 'a -> 'a -> bool -} + bigint_to_number : big_int -> 'a; + number_to_num : 'a -> num; + zero : 'a; + unit : 'a; + mult : 'a -> 'a -> 'a; + eqb : 'a -> 'a -> bool + } let z_spec = { - bigint_to_number = Ml2C.bigint ; - number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); - zero = Mc.Z0; - unit = Mc.Zpos Mc.XH; - mult = Mc.Z.mul; - eqb = Mc.zeq_bool -} - + bigint_to_number = Ml2C.bigint ; + number_to_num = (fun x -> Big_int (C2Ml.z_big_int x)); + zero = Mc.Z0; + unit = Mc.Zpos Mc.XH; + mult = Mc.Z.mul; + eqb = Mc.zeq_bool + } + let q_spec = { - bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); - number_to_num = C2Ml.q_to_num; - zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; - unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; - mult = Mc.qmult; - eqb = Mc.qeq_bool -} + bigint_to_number = (fun x -> {Mc.qnum = Ml2C.bigint x; Mc.qden = Mc.XH}); + number_to_num = C2Ml.q_to_num; + zero = {Mc.qnum = Mc.Z0;Mc.qden = Mc.XH}; + unit = {Mc.qnum = (Mc.Zpos Mc.XH) ; Mc.qden = Mc.XH}; + mult = Mc.qmult; + eqb = Mc.qeq_bool + } let dev_form n_spec p = - let rec dev_form p = - match p with - | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) - | Mc.PEX v -> Poly.variable (C2Ml.positive v) - | Mc.PEmul(p1,p2) -> - let p1 = dev_form p1 in - let p2 = dev_form p2 in - Poly.product p1 p2 - | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) - | Mc.PEopp p -> Poly.uminus (dev_form p) - | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) - | Mc.PEpow(p,n) -> - let p = dev_form p in - let n = C2Ml.n n in - let rec pow n = - if Int.equal n 0 - then Poly.constant (n_spec.number_to_num n_spec.unit) - else Poly.product p (pow (n-1)) in - pow n in - dev_form p + let rec dev_form p = + match p with + | Mc.PEc z -> Poly.constant (n_spec.number_to_num z) + | Mc.PEX v -> Poly.variable (C2Ml.positive v) + | Mc.PEmul(p1,p2) -> + let p1 = dev_form p1 in + let p2 = dev_form p2 in + Poly.product p1 p2 + | Mc.PEadd(p1,p2) -> Poly.addition (dev_form p1) (dev_form p2) + | Mc.PEopp p -> Poly.uminus (dev_form p) + | Mc.PEsub(p1,p2) -> Poly.addition (dev_form p1) (Poly.uminus (dev_form p2)) + | Mc.PEpow(p,n) -> + let p = dev_form p in + let n = C2Ml.n n in + let rec pow n = + if Int.equal n 0 + then Poly.constant (n_spec.number_to_num n_spec.unit) + else Poly.product p (pow (n-1)) in + pow n in + dev_form p let rec fixpoint f x = - let y' = f x in - if Pervasives.(=) y' x then y' - else fixpoint f y' + let y' = f x in + if Pervasives.(=) y' x then y' + else fixpoint f y' let rec_simpl_cone n_spec e = - let simpl_cone = - Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in - - let rec rec_simpl_cone = function - | Mc.PsatzMulE(t1, t2) -> - simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) - | Mc.PsatzAdd(t1,t2) -> - simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) - | x -> simpl_cone x in - rec_simpl_cone e + let simpl_cone = + Mc.simpl_cone n_spec.zero n_spec.unit n_spec.mult n_spec.eqb in + + let rec rec_simpl_cone = function + | Mc.PsatzMulE(t1, t2) -> + simpl_cone (Mc.PsatzMulE (rec_simpl_cone t1, rec_simpl_cone t2)) + | Mc.PsatzAdd(t1,t2) -> + simpl_cone (Mc.PsatzAdd (rec_simpl_cone t1, rec_simpl_cone t2)) + | x -> simpl_cone x in + rec_simpl_cone e let simplify_cone n_spec c = fixpoint (rec_simpl_cone n_spec) c -let factorise_linear_cone c = - - let rec cone_list c l = - match c with - | Mc.PsatzAdd (x,r) -> cone_list r (x::l) - | _ -> c :: l in - - let factorise c1 c2 = - match c1 , c2 with - | Mc.PsatzMulC(x,y) , Mc.PsatzMulC(x',y') -> - if Pervasives.(=) x x' then Some (Mc.PsatzMulC(x, Mc.PsatzAdd(y,y'))) else None - | Mc.PsatzMulE(x,y) , Mc.PsatzMulE(x',y') -> - if Pervasives.(=) x x' then Some (Mc.PsatzMulE(x, Mc.PsatzAdd(y,y'))) else None - | _ -> None in - - let rec rebuild_cone l pending = - match l with - | [] -> (match pending with - | None -> Mc.PsatzZ - | Some p -> p - ) - | e::l -> - (match pending with - | None -> rebuild_cone l (Some e) - | Some p -> (match factorise p e with - | None -> Mc.PsatzAdd(p, rebuild_cone l (Some e)) - | Some f -> rebuild_cone l (Some f) ) - ) in - - (rebuild_cone (List.sort Pervasives.compare (cone_list c [])) None) - (* The binding with Fourier might be a bit obsolete @@ -147,956 +118,917 @@ let factorise_linear_cone c = This is a linear problem: each monomial is considered as a variable. Hence, we can use fourier. - The variable c is at index 0 -*) - -open Mfourier + The variable c is at index 1 + *) (* fold_left followed by a rev ! *) -let constrain_monomial mn l = - let coeffs = List.fold_left (fun acc p -> (Poly.get mn p)::acc) [] l in - if Pervasives.(=) mn Monomial.const - then - { coeffs = Vect.from_list ((Big_int unit_big_int):: (List.rev coeffs)) ; +let constrain_variable v l = + let coeffs = List.fold_left (fun acc p -> (Vect.get v p.coeffs)::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int zero_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } - else - { coeffs = Vect.from_list ((Big_int zero_big_int):: (List.rev coeffs)) ; + + + +let constrain_constant l = + let coeffs = List.fold_left (fun acc p -> minus_num p.cst ::acc) [] l in + { coeffs = Vect.from_list ((Big_int zero_big_int):: (Big_int unit_big_int):: (List.rev coeffs)) ; op = Eq ; cst = Big_int zero_big_int } - let positivity l = - let rec xpositivity i l = - match l with - | [] -> [] - | (_,Mc.Equal)::l -> xpositivity (i+1) l - | (_,_)::l -> - {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; - op = Ge ; - cst = Int 0 } :: (xpositivity (i+1) l) - in - xpositivity 0 l + let rec xpositivity i l = + match l with + | [] -> [] + | c::l -> match c.op with + | Eq -> xpositivity (i+1) l + | _ -> + {coeffs = Vect.update (i+1) (fun _ -> Int 1) Vect.null ; + op = Ge ; + cst = Int 0 } :: (xpositivity (i+1) l) + in + xpositivity 1 l + + +let cstr_of_poly (p,o) = + let (c,l) = Vect.decomp_cst p in + {coeffs = l; op = o ; cst = minus_num c} + + + +let variables_of_cstr c = Vect.variables c.coeffs -module MonSet = Set.Make(Monomial) (* If the certificate includes at least one strict inequality, the obtained polynomial can also be 0 *) -let build_linear_system l = - - (* Gather the monomials: HINT add up of the polynomials ==> This does not work anymore *) - let l' = List.map fst l in - - let monomials = - List.fold_left (fun acc p -> - Poly.fold (fun m _ acc -> MonSet.add m acc) p acc) - (MonSet.singleton Monomial.const) l' - in (* For each monomial, compute a constraint *) - let s0 = - MonSet.fold (fun mn res -> (constrain_monomial mn l')::res) monomials [] in - (* I need at least something strictly positive *) - let strict = { - coeffs = Vect.from_list ((Big_int unit_big_int):: - (List.map (fun (x,y) -> - match y with Mc.Strict -> - Big_int unit_big_int - | _ -> Big_int zero_big_int) l)); - op = Ge ; cst = Big_int unit_big_int } in + +let build_dual_linear_system l = + + let variables = + List.fold_left (fun acc p -> ISet.union acc (variables_of_cstr p)) ISet.empty l in + (* For each monomial, compute a constraint *) + let s0 = + ISet.fold (fun mn res -> (constrain_variable mn l)::res) variables [] in + let c = constrain_constant l in + + (* I need at least something strictly positive *) + let strict = { + coeffs = Vect.from_list ((Big_int zero_big_int) :: (Big_int unit_big_int):: + (List.map (fun c -> if is_strict c then Big_int unit_big_int else Big_int zero_big_int) l)); + op = Ge ; cst = Big_int unit_big_int } in (* Add the positivity constraint *) - {coeffs = Vect.from_list ([Big_int unit_big_int]) ; - op = Ge ; - cst = Big_int zero_big_int}::(strict::(positivity l)@s0) - -(* For Q, this is a pity that the certificate has been scaled - -- at a lower layer, certificates are using nums... *) -let make_certificate n_spec (cert,li) = - let bint_to_cst = n_spec.bigint_to_number in - match cert with - | [] -> failwith "empty_certificate" - | e::cert' -> - (* let cst = match compare_big_int e zero_big_int with - | 0 -> Mc.PsatzZ - | 1 -> Mc.PsatzC (bint_to_cst e) - | _ -> failwith "positivity error" - in *) - let rec scalar_product cert l = - match cert with - | [] -> Mc.PsatzZ - | c::cert -> - match l with - | [] -> failwith "make_certificate(1)" - | i::l -> - let r = scalar_product cert l in - match compare_big_int c zero_big_int with - | -1 -> Mc.PsatzAdd ( - Mc.PsatzMulC (Mc.Pc ( bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) - | 0 -> r - | _ -> Mc.PsatzAdd ( - Mc.PsatzMulE (Mc.PsatzC (bint_to_cst c), Mc.PsatzIn (Ml2C.nat i)), - r) in - (factorise_linear_cone - (simplify_cone n_spec (scalar_product cert' li))) - - -exception Strict - -module MonMap = Map.Make(Monomial) - -let primal l = - let vr = ref 0 in - - let vect_of_poly map p = - Poly.fold (fun mn vl (map,vect) -> - if Pervasives.(=) mn Monomial.const - then (map,vect) - else - let (mn,m) = try (MonMap.find mn map,map) with Not_found -> let res = (!vr, MonMap.add mn !vr map) in incr vr ; res in - (m,if Int.equal (sign_num vl) 0 then vect else (mn,vl)::vect)) p (map,[]) in - - let op_op = function Mc.NonStrict -> Ge |Mc.Equal -> Eq | _ -> raise Strict in - - let cmp x y = Int.compare (fst x) (fst y) in - - snd (List.fold_right (fun (p,op) (map,l) -> - let (mp,vect) = vect_of_poly map p in - let cstr = {coeffs = List.sort cmp vect; op = op_op op ; cst = minus_num (Poly.get Monomial.const p)} in - - (mp,cstr::l)) l (MonMap.empty,[])) - -let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = - (* List.iter (fun (p,op) -> Printf.fprintf stdout "%a %s 0\n" Poly.pp p (string_of_op op) ) l ; *) - - let sys = build_linear_system l in - - try - match Fourier.find_point sys with - | Inr _ -> None - | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) - (* should not use rats_to_ints *) - with x when CErrors.noncritical x -> - if debug - then (Printf.printf "raw certificate %s" (Printexc.to_string x); - flush stdout) ; - None - - -let raw_certificate l = - try - let p = primal l in - match Fourier.find_point p with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; - let cert = List.map (fun (x,n) -> x+1,n) (fst (List.hd (Proof.mk_proof p prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; - Some (rats_to_ints (Vect.to_list cert)) + {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) + + +(** [direct_linear_prover l] does not handle strict inegalities *) +let fourier_linear_prover l = + match Mfourier.Fourier.find_point l with + | Inr prf -> + if debug then Printf.printf "AProof : %a\n" Mfourier.pp_proof prf ; + let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Mfourier.Proof.mk_proof l prf))) in + if debug then Printf.printf "CProof : %a" Vect.pp cert ; + (*Some (rats_to_ints (Vect.to_list cert))*) + Some (Vect.normalise cert) | Inl _ -> None - with Strict -> + + +let direct_linear_prover l = + if !use_simplex + then Simplex.find_unsat_certificate 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 + +let optimise v l = + if !use_simplex + then Simplex.optimise v l + else Mfourier.Fourier.optimise v l + + + +let dual_raw_certificate l = + if debug + then begin + Printf.printf "dual_raw_certificate\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) l + end; + + let sys = build_dual_linear_system l in + + if debug then begin + Printf.printf "dual_system\n"; + List.iter (fun c -> Printf.fprintf stdout "%a\n" output_cstr c) sys + end; + + try + match find_point sys with + | None -> None + | Some cert -> + match Vect.choose cert with + | None -> failwith "dual_raw_certificate: empty_certificate" + | Some _ -> + (*Some (rats_to_ints (Vect.to_list (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))))*) + Some (Vect.normalise (Vect.decr_var 2 (Vect.set 1 (Int 0) cert))) + (* should not use rats_to_ints *) + with x when CErrors.noncritical x -> + if debug + then (Printf.printf "dual raw certificate %s" (Printexc.to_string x); + flush stdout) ; + None + + + +let simple_linear_prover l = + try + direct_linear_prover l + with Strict -> (* Fourier elimination should handle > *) - dual_raw_certificate l + 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) -let simple_linear_prover l = - let (lc,li) = List.split l in - match raw_certificate lc with - | None -> None (* No certificate *) - | Some cert -> Some (cert,li) - +let linear_prover_cstr sys = + let (sysi,prfi) = List.split sys in -let linear_prover n_spec l = - let build_system n_spec l = - let li = List.combine l (CList.interval 0 (List.length l -1)) in - let (l1,l') = List.partition - (fun (x,_) -> if Pervasives.(=) (snd x) Mc.NonEqual then true else false) li in - List.map - (fun ((x,y),i) -> match y with - Mc.NonEqual -> failwith "cannot happen" - | y -> ((dev_form n_spec x, y),i)) l' in - let l' = build_system n_spec l in - simple_linear_prover (*n_spec*) l' + + match simple_linear_prover sysi with + | None -> None + | Some cert -> Some (proof_of_farkas (env_of_list prfi) cert) + +let linear_prover_cstr = + if debug + then + fun sys -> + Printf.printf "<linear_prover"; flush stdout ; + let res = linear_prover_cstr sys in + Printf.printf ">"; flush stdout ; + res + else linear_prover_cstr -let linear_prover n_spec l = - try linear_prover n_spec l - with x when CErrors.noncritical x -> - (print_string (Printexc.to_string x); None) let compute_max_nb_cstr l d = - let len = List.length l in - max len (max d (len * d)) + let len = List.length l in + max len (max d (len * d)) -let linear_prover_with_cert prfdepth spec l = - max_nb_cstr := compute_max_nb_cstr l prfdepth ; - match linear_prover spec l with - | None -> None - | Some cert -> Some (make_certificate spec cert) -let nlinear_prover prfdepth (sys: (Mc.q Mc.pExpr * Mc.op1) list) = - LinPoly.MonT.clear (); - max_nb_cstr := compute_max_nb_cstr sys prfdepth ; - (* Assign a proof to the initial hypotheses *) - let sys = List.mapi (fun i c -> (c,Mc.PsatzIn (Ml2C.nat i))) sys in +let develop_constraint z_spec (e,k) = + (dev_form z_spec e, + match k with + | Mc.NonStrict -> Ge + | Mc.Equal -> Eq + | Mc.Strict -> Gt + | _ -> assert false + ) + +(** A single constraint can be unsat for the following reasons: + - 0 >= c for c a negative constant + - 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 *) - (* Add all the product of hypotheses *) - let prod = all_pairs (fun ((c,o),p) ((c',o'),p') -> - ((Mc.PEmul(c,c') , Mc.opMult o o') , Mc.PsatzMulE(p,p'))) sys in +exception FoundProof of prf_rule + + +(** [check_sat] + - detects constraints that are not satisfiable; + - normalises constraints and generate cuts. + *) + +let check_int_sat (cstr,prf) = + let {coeffs=coeffs ; op=op ; cst=cst} = cstr in + match Vect.choose coeffs with + | None -> + if eval_op op (Int 0) cst then Tauto else Unsat prf + | _ -> + let gcdi = Vect.gcd coeffs in + let gcd = Big_int gcdi in + if eq_num gcd (Int 1) + then Normalise(cstr,prf) + else + if Int.equal (sign_num (mod_num cst gcd)) 0 + then (* We can really normalise *) + begin + assert (sign_num gcd >=1 ) ; + let cstr = { + coeffs = Vect.div gcd coeffs; + op = op ; cst = cst // gcd + } in + Normalise(cstr,Gcd(gcdi,prf)) + (* Normalise(cstr,CutPrf prf)*) + end + else + match op with + | Eq -> Unsat (CutPrf prf) + | Ge -> + let cstr = { + coeffs = Vect.div gcd coeffs; + op = op ; cst = ceiling_num (cst // gcd) + } in Cut(cstr,CutPrf prf) + | Gt -> failwith "check_sat : Unexpected operator" + + +let apply_and_normalise check f psys = + List.fold_left (fun acc pc' -> + match f pc' with + | None -> pc'::acc + | Some pc' -> + match check pc' with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc + ) [] 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 - (* Only filter those have a meaning *) - let prod = List.fold_left (fun l ((c,o),p) -> match o with - | None -> l - | Some o -> ((c,o),p) :: l) [] prod in - - let sys = sys @ prod in - - let square = - (* Collect the squares and state that they are positive *) - let pols = List.map (fun ((p,_),_) -> dev_form q_spec p) sys in - let square = - List.fold_left (fun acc p -> - Poly.fold - (fun m _ acc -> - match Monomial.sqrt m with - | None -> acc - | Some s -> MonMap.add s m acc) p acc) MonMap.empty pols in - - let pol_of_mon m = - Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc q_spec.unit) in - - let norm0 = - Mc.norm q_spec.zero q_spec.unit Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool in + | 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)) + + + + +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 + match o with + | Eq -> begin + match + List.filter (fun v -> List.for_all (is_linear_for v) sys) (LinPoly.search_all_linear pred p) + with + | [] -> None + | v::_ -> Some v (* make a choice *) + end + | _ -> None + + +let elim_simple_linear_equality sys0 = + + let elim sys = + let (oeq,sys') = extract (is_linear_substitution sys) sys in + match oeq with + | None -> None + | Some(v,pc) -> simplify (WithProof.linear_pivot sys0 pc v) sys' in + + iterate_until_stable elim sys0 + + +let saturate_linear_equality_non_linear sys0 = + let (l,_) = extract_all (is_substitution false) sys0 in + let rec elim l acc = + match l with + | [] -> acc + | (v,pc)::l' -> + let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in + elim l' (nc@acc) in + elim l [] + + + +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 + +let square_of_var i = + let x = LinPoly.var i in + ((LinPoly.product x x,Ge),(Square x)) + +(** [nlinear_preprocess sys] augments the system [sys] by performing some limited non-linear reasoning. + For instance, it asserts that the x² ≥0 but also that if c₁ ≥ 0 ∈ sys and c₂ ≥ 0 ∈ sys then c₁ × c₂ ≥ 0. + The resulting system is linearised. + *) + +let nlinear_preprocess (sys:WithProof.t list) = + + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in + + if is_linear then sys + else + let collect_square = + List.fold_left (fun acc ((p,_),_) -> MonMap.union (fun k e1 e2 -> Some e1) acc (LinPoly.collect_square p)) MonMap.empty sys in + 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 + + let collect_vars = List.fold_left (fun acc p -> ISet.union acc (LinPoly.variables (fst (fst p)))) ISet.empty sys in + + let sys = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in + + let sys = sys @ (all_pairs WithProof.product sys) in - MonMap.fold (fun s m acc -> ((pol_of_mon m , Mc.NonStrict), Mc.PsatzSquare(norm0 (pol_of_mon s)))::acc) square [] in + if debug then begin + Printf.fprintf stdout "Preprocessed\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end ; + + List.map (WithProof.annot "P") sys + - let sys = sys @ square in +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 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 + | Some cert -> + Some (cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) - (* Call the linear prover without the proofs *) - let sys_no_prf = List.map fst sys in - match linear_prover q_spec sys_no_prf with - | None -> None - | Some cert -> - let cert = make_certificate q_spec cert in - let rec map_psatz = function - | Mc.PsatzIn n -> snd (List.nth sys (C2Ml.nat n)) - | Mc.PsatzSquare c -> Mc.PsatzSquare c - | Mc.PsatzMulC(c,p) -> Mc.PsatzMulC(c, map_psatz p) - | Mc.PsatzMulE(p1,p2) -> Mc.PsatzMulE(map_psatz p1,map_psatz p2) - | Mc.PsatzAdd(p1,p2) -> Mc.PsatzAdd(map_psatz p1,map_psatz p2) - | Mc.PsatzC c -> Mc.PsatzC c - | Mc.PsatzZ -> Mc.PsatzZ in - Some (map_psatz cert) +let linear_prover_with_cert prfdepth sys = + let sys = develop_constraints prfdepth q_spec sys in + (* let sys = nlinear_preprocess sys in *) + let sys = List.map (fun (c,p) -> cstr_of_poly c,p) sys in + + match linear_prover_cstr sys with + | None -> None + | Some cert -> + Some (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 *) -let develop_constraint z_spec (e,k) = - match k with - | Mc.NonStrict -> (dev_form z_spec e , Ge) - | Mc.Equal -> (dev_form z_spec e , Eq) - | _ -> assert false - open Sos_types let rec scale_term t = - match t with - | Zero -> unit_big_int , Zero - | Const n -> (denominator n) , Const (Big_int (numerator n)) - | Var n -> unit_big_int , Var n - | Inv _ -> failwith "scale_term : not implemented" - | Opp t -> let s, t = scale_term t in s, Opp t - | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - let e = mult_big_int g (mult_big_int s1' s2') in - if Int.equal (compare_big_int e unit_big_int) 0 - then (unit_big_int, Add (y1,y2)) - else e, Add (Mul(Const (Big_int s2'), y1), + match t with + | Zero -> unit_big_int , Zero + | Const n -> (denominator n) , Const (Big_int (numerator n)) + | Var n -> unit_big_int , Var n + | Opp t -> let s, t = scale_term t in s, Opp t + | Add(t1,t2) -> let s1,y1 = scale_term t1 and s2,y2 = scale_term t2 in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + let e = mult_big_int g (mult_big_int s1' s2') in + if Int.equal (compare_big_int e unit_big_int) 0 + then (unit_big_int, Add (y1,y2)) + else e, Add (Mul(Const (Big_int s2'), y1), Mul (Const (Big_int s1'), y2)) - | Sub _ -> failwith "scale term: not implemented" - | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in - mult_big_int s1 s2 , Mul (y1, y2) - | Pow(t,n) -> let s,t = scale_term t in - power_big_int_positive_int s n , Pow(t,n) - | _ -> failwith "scale_term : not implemented" + | Sub _ -> failwith "scale term: not implemented" + | Mul(y,z) -> let s1,y1 = scale_term y and s2,y2 = scale_term z in + mult_big_int s1 s2 , Mul (y1, y2) + | Pow(t,n) -> let s,t = scale_term t in + power_big_int_positive_int s n , Pow(t,n) let scale_term t = - let (s,t') = scale_term t in - s,t' + let (s,t') = scale_term t in + s,t' let rec scale_certificate pos = match pos with - | Axiom_eq i -> unit_big_int , Axiom_eq i - | Axiom_le i -> unit_big_int , Axiom_le i - | Axiom_lt i -> unit_big_int , Axiom_lt i - | Monoid l -> unit_big_int , Monoid l - | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) - | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) - | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) - | Square t -> let s,t' = scale_term t in - mult_big_int s s , Square t' - | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in - mult_big_int s1 s2 , Eqmul (y1,y2) - | Sum (y, z) -> let s1,y1 = scale_certificate y - and s2,y2 = scale_certificate z in - let g = gcd_big_int s1 s2 in - let s1' = div_big_int s1 g in - let s2' = div_big_int s2 g in - mult_big_int g (mult_big_int s1' s2'), - Sum (Product(Rational_le (Big_int s2'), y1), - Product (Rational_le (Big_int s1'), y2)) - | Product (y, z) -> - let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in - mult_big_int s1 s2 , Product (y1,y2) + | Axiom_eq i -> unit_big_int , Axiom_eq i + | Axiom_le i -> unit_big_int , Axiom_le i + | Axiom_lt i -> unit_big_int , Axiom_lt i + | Monoid l -> unit_big_int , Monoid l + | Rational_eq n -> (denominator n) , Rational_eq (Big_int (numerator n)) + | Rational_le n -> (denominator n) , Rational_le (Big_int (numerator n)) + | Rational_lt n -> (denominator n) , Rational_lt (Big_int (numerator n)) + | Square t -> let s,t' = scale_term t in + mult_big_int s s , Square t' + | Eqmul (t, y) -> let s1,y1 = scale_term t and s2,y2 = scale_certificate y in + mult_big_int s1 s2 , Eqmul (y1,y2) + | Sum (y, z) -> let s1,y1 = scale_certificate y + and s2,y2 = scale_certificate z in + let g = gcd_big_int s1 s2 in + let s1' = div_big_int s1 g in + let s2' = div_big_int s2 g in + mult_big_int g (mult_big_int s1' s2'), + Sum (Product(Rational_le (Big_int s2'), y1), + Product (Rational_le (Big_int s1'), y2)) + | Product (y, z) -> + let s1,y1 = scale_certificate y and s2,y2 = scale_certificate z in + mult_big_int s1 s2 , Product (y1,y2) open Micromega let rec term_to_q_expr = function - | Const n -> PEc (Ml2C.q n) - | Zero -> PEc ( Ml2C.q (Int 0)) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) - | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) - | Opp p -> PEopp (term_to_q_expr p) - | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) - | _ -> failwith "term_to_q_expr: not implemented" + | Const n -> PEc (Ml2C.q n) + | Zero -> PEc ( Ml2C.q (Int 0)) + | Var s -> PEX (Ml2C.index + (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul(p1,p2) -> PEmul(term_to_q_expr p1, term_to_q_expr p2) + | Add(p1,p2) -> PEadd(term_to_q_expr p1, term_to_q_expr p2) + | Opp p -> PEopp (term_to_q_expr p) + | Pow(t,n) -> PEpow (term_to_q_expr t,Ml2C.n n) + | Sub(t1,t2) -> PEsub (term_to_q_expr t1, term_to_q_expr t2) let term_to_q_pol e = Mc.norm_aux (Ml2C.q (Int 0)) (Ml2C.q (Int 1)) Mc.qplus Mc.qmult Mc.qminus Mc.qopp Mc.qeq_bool (term_to_q_expr e) let rec product l = - match l with - | [] -> Mc.PsatzZ - | [i] -> Mc.PsatzIn (Ml2C.nat i) - | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) + match l with + | [] -> Mc.PsatzZ + | [i] -> Mc.PsatzIn (Ml2C.nat i) + | i ::l -> Mc.PsatzMulE(Mc.PsatzIn (Ml2C.nat i), product l) let q_cert_of_pos pos = - let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) - | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.q n) - | Square t -> Mc.PsatzSquare (term_to_q_pol t) - | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) - | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in - simplify_cone q_spec (_cert_of_pos pos) + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.q n) + | Square t -> Mc.PsatzSquare (term_to_q_pol t) + | Eqmul (t, y) -> Mc.PsatzMulC(term_to_q_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + simplify_cone q_spec (_cert_of_pos pos) let rec term_to_z_expr = function - | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) - | Zero -> PEc ( Z0) - | Var s -> PEX (Ml2C.index - (int_of_string (String.sub s 1 (String.length s - 1)))) - | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) - | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) - | Opp p -> PEopp (term_to_z_expr p) - | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) - | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) - | _ -> failwith "term_to_z_expr: not implemented" + | Const n -> PEc (Ml2C.bigint (big_int_of_num n)) + | Zero -> PEc ( Z0) + | Var s -> PEX (Ml2C.index + (int_of_string (String.sub s 1 (String.length s - 1)))) + | Mul(p1,p2) -> PEmul(term_to_z_expr p1, term_to_z_expr p2) + | Add(p1,p2) -> PEadd(term_to_z_expr p1, term_to_z_expr p2) + | Opp p -> PEopp (term_to_z_expr p) + | Pow(t,n) -> PEpow (term_to_z_expr t,Ml2C.n n) + | Sub(t1,t2) -> PEsub (term_to_z_expr t1, term_to_z_expr t2) let term_to_z_pol e = Mc.norm_aux (Ml2C.z 0) (Ml2C.z 1) Mc.Z.add Mc.Z.mul Mc.Z.sub Mc.Z.opp Mc.zeq_bool (term_to_z_expr e) let z_cert_of_pos pos = - let s,pos = (scale_certificate pos) in - let rec _cert_of_pos = function - Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) - | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) - | Monoid l -> product l - | Rational_eq n | Rational_le n | Rational_lt n -> - if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else - Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) - | Square t -> Mc.PsatzSquare (term_to_z_pol t) - | Eqmul (t, y) -> - let is_unit = - match t with - | Const n -> n =/ Int 1 - | _ -> false in - if is_unit - then _cert_of_pos y - else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) - | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) - | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in - simplify_cone z_spec (_cert_of_pos pos) + let s,pos = (scale_certificate pos) in + let rec _cert_of_pos = function + Axiom_eq i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_le i -> Mc.PsatzIn (Ml2C.nat i) + | Axiom_lt i -> Mc.PsatzIn (Ml2C.nat i) + | Monoid l -> product l + | Rational_eq n | Rational_le n | Rational_lt n -> + if Int.equal (compare_num n (Int 0)) 0 then Mc.PsatzZ else + Mc.PsatzC (Ml2C.bigint (big_int_of_num n)) + | Square t -> Mc.PsatzSquare (term_to_z_pol t) + | Eqmul (t, y) -> + let is_unit = + match t with + | Const n -> n =/ Int 1 + | _ -> false in + if is_unit + then _cert_of_pos y + else Mc.PsatzMulC(term_to_z_pol t, _cert_of_pos y) + | Sum (y, z) -> Mc.PsatzAdd (_cert_of_pos y, _cert_of_pos z) + | Product (y, z) -> Mc.PsatzMulE (_cert_of_pos y, _cert_of_pos z) in + simplify_cone z_spec (_cert_of_pos pos) (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. -*) + *) open Mutils -open Mfourier open Num open Big_int open Polynomial -module Env = -struct - - let id_of_hyp hyp l = - let rec xid_of_hyp i l = - match l with - | [] -> failwith "id_of_hyp" - | hyp'::l -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l in - xid_of_hyp 0 l - -end +type prf_sys = (cstr * prf_rule) list -let coq_poly_of_linpol (p,c) = - - let pol_of_mon m = - Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(Ml2C.positive x),Ml2C.n v),p)) m (Mc.PEc (Mc.Zpos Mc.XH)) in - - List.fold_left (fun acc (x,v) -> - let mn = LinPoly.MonT.retrieve x in - Mc.PEadd(Mc.PEmul(Mc.PEc (Ml2C.bigint (numerator v)), pol_of_mon mn),acc)) (Mc.PEc (Ml2C.bigint (numerator c))) p - - - - -let rec cmpl_prf_rule env = function - | Hyp i | Def i -> Mc.PsatzIn (Ml2C.nat (Env.id_of_hyp i env)) - | Cst i -> Mc.PsatzC (Ml2C.bigint i) - | Zero -> Mc.PsatzZ - | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl_prf_rule env p1, cmpl_prf_rule env p2) - | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl_prf_rule env p1 , cmpl_prf_rule env p2) - | MulC(lp,p) -> let lp = Mc.norm0 (coq_poly_of_linpol lp) in - Mc.PsatzMulC(lp,cmpl_prf_rule env p) - | Square lp -> Mc.PsatzSquare (Mc.norm0 (coq_poly_of_linpol lp)) - | _ -> failwith "Cuts should already be compiled" - - -let rec cmpl_proof env = function - | Done -> Mc.DoneProof - | Step(i,p,prf) -> - begin - match p with - | CutPrf p' -> - Mc.CutProof(cmpl_prf_rule env p', cmpl_proof (i::env) prf) - | _ -> Mc.RatProof(cmpl_prf_rule env p,cmpl_proof (i::env) prf) - end - | Enum(i,p1,_,p2,l) -> - Mc.EnumProof(cmpl_prf_rule env p1,cmpl_prf_rule env p2,List.map (cmpl_proof (i::env)) l) - - -let compile_proof env prf = - let id = 1 + proof_max_id prf in - let _,prf = normalise_proof id prf in - if debug then Printf.fprintf stdout "compiled proof %a\n" output_proof prf; - cmpl_proof env prf - -type prf_sys = (cstr_compat * prf_rule) list - - -let xlinear_prover sys = - match Fourier.find_point sys with - | Inr prf -> - if debug then Printf.printf "AProof : %a\n" pp_proof prf ; - let cert = (*List.map (fun (x,n) -> x+1,n)*) (fst (List.hd (Proof.mk_proof sys prf))) in - if debug then Printf.printf "CProof : %a" Vect.pp_vect cert ; - Some (rats_to_ints (Vect.to_list cert)) - | Inl _ -> None - - -let proof_of_farkas prf cert = - (* Printf.printf "\nproof_of_farkas %a , %a \n" (pp_list output_prf_rule) prf (pp_list output_bigint) cert ; *) - let rec mk_farkas acc prf cert = - match prf, cert with - | _ , [] -> acc - | [] , _ -> failwith "proof_of_farkas : not enough hyps" - | p::prf,c::cert -> - mk_farkas (add_proof (mul_proof c p) acc) prf cert in - let res = mk_farkas Zero prf cert in - (*Printf.printf "==> %a" output_prf_rule res ; *) - res - - -let linear_prover sys = - let (sysi,prfi) = List.split sys in - match xlinear_prover sysi with - | None -> None - | Some cert -> Some (proof_of_farkas prfi cert) - -let linear_prover = - if debug - then - fun sys -> - Printf.printf "<linear_prover"; flush stdout ; - let res = linear_prover sys in - Printf.printf ">"; flush stdout ; - res - else linear_prover - - - - -(** A single constraint can be unsat for the following reasons: - - 0 >= c for c a negative constant - - 0 = c for c a non-zero constant - - e = c when the coeffs of e are all integers and c is rational -*) - -type checksat = -| Tauto (* Tautology *) -| Unsat of prf_rule (* Unsatisfiable *) -| Cut of cstr_compat * prf_rule (* Cutting plane *) -| Normalise of cstr_compat * prf_rule (* coefficients are relatively prime *) - - -(** [check_sat] - - detects constraints that are not satisfiable; - - normalises constraints and generate cuts. -*) - -let check_sat (cstr,prf) = - let {coeffs=coeffs ; op=op ; cst=cst} = cstr in - match coeffs with - | [] -> - if eval_op op (Int 0) cst then Tauto else Unsat prf - | _ -> - let gcdi = (gcd_list (List.map snd coeffs)) in - let gcd = Big_int gcdi in - if eq_num gcd (Int 1) - then Normalise(cstr,prf) - else - if Int.equal (sign_num (mod_num cst gcd)) 0 - then (* We can really normalise *) - begin - assert (sign_num gcd >=1 ) ; - let cstr = { - coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; - op = op ; cst = cst // gcd - } in - Normalise(cstr,Gcd(gcdi,prf)) - (* Normalise(cstr,CutPrf prf)*) - end - else - match op with - | Eq -> Unsat (CutPrf prf) - | Ge -> - let cstr = { - coeffs = List.map (fun (x,v) -> (x, v // gcd)) coeffs; - op = op ; cst = ceiling_num (cst // gcd) - } in Cut(cstr,CutPrf prf) (** Proof generating pivoting over variable v *) let pivot v (c1,p1) (c2,p2) = - let {coeffs = v1 ; op = op1 ; cst = n1} = c1 - and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in + let {coeffs = v1 ; op = op1 ; cst = n1} = c1 + and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in (* Could factorise gcd... *) - let xpivot cv1 cv2 = - ( - {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; - op = Proof.add_op op1 op2 ; - cst = n1 */ cv1 +/ n2 */ cv2 }, - - AddPrf(mul_proof (numerator cv1) p1,mul_proof (numerator cv2) p2)) in - - match Vect.get v v1 , Vect.get v v2 with - | None , _ | _ , None -> None - | Some a , Some b -> - if Int.equal ((sign_num a) * (sign_num b)) (-1) - then - let cv1 = abs_num b - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else - if op1 == Eq - then - let cv1 = minus_num (b */ (Int (sign_num a))) - and cv2 = abs_num a in - Some (xpivot cv1 cv2) - else if op2 == Eq - then - let cv1 = abs_num b - and cv2 = minus_num (a */ (Int (sign_num b))) in - Some (xpivot cv1 cv2) - else None (* op2 could be Eq ... this might happen *) - -exception FoundProof of prf_rule + let xpivot cv1 cv2 = + ( + {coeffs = Vect.add (Vect.mul cv1 v1) (Vect.mul cv2 v2) ; + op = opAdd op1 op2 ; + cst = n1 */ cv1 +/ n2 */ cv2 }, + + AddPrf(mul_cst_proof cv1 p1,mul_cst_proof cv2 p2)) in + + match Vect.get v v1 , Vect.get v v2 with + | Int 0 , _ | _ , Int 0 -> None + | a , b -> + if Int.equal ((sign_num a) * (sign_num b)) (-1) + then + let cv1 = abs_num b + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else + if op1 == Eq + then + let cv1 = minus_num (b */ (Int (sign_num a))) + and cv2 = abs_num a in + Some (xpivot cv1 cv2) + else if op2 == Eq + then + let cv1 = abs_num b + and cv2 = minus_num (a */ (Int (sign_num b))) in + Some (xpivot cv1 cv2) + else None (* op2 could be Eq ... this might happen *) + let simpl_sys sys = - List.fold_left (fun acc (c,p) -> - match check_sat (c,p) with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc) [] sys + List.fold_left (fun acc (c,p) -> + match check_int_sat (c,p) with + | Tauto -> acc + | Unsat prf -> raise (FoundProof prf) + | Cut(c,p) -> (c,p)::acc + | Normalise (c,p) -> (c,p)::acc) [] sys (** [ext_gcd a b] is the extended Euclid algorithm. [ext_gcd a b = (x,y,g)] iff [ax+by=g] Source: http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm -*) + *) let rec ext_gcd a b = - if Int.equal (sign_big_int b) 0 - then (unit_big_int,zero_big_int) - else - let (q,r) = quomod_big_int a b in - let (s,t) = ext_gcd b r in - (t, sub_big_int s (mult_big_int q t)) + if Int.equal (sign_big_int b) 0 + then (unit_big_int,zero_big_int) + else + let (q,r) = quomod_big_int a b in + let (s,t) = ext_gcd b r in + (t, sub_big_int s (mult_big_int q t)) let extract_coprime (c1,p1) (c2,p2) = - let rec exist2 vect1 vect2 = - match vect1 , vect2 with - | _ , [] | [], _ -> None - | (v1,n1)::vect1' , (v2, n2) :: vect2' -> - if Pervasives.(=) v1 v2 - then - if Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0 - then Some (v1,n1,n2) - else - exist2 vect1' vect2' - else - if v1 < v2 - then exist2 vect1' vect2 - else exist2 vect1 vect2' in - - if c1.op == Eq && c2.op == Eq - then exist2 c1.coeffs c2.coeffs - else None + if c1.op == Eq && c2.op == Eq + then Vect.exists2 (fun n1 n2 -> + Int.equal (compare_big_int (gcd_big_int (numerator n1) (numerator n2)) unit_big_int) 0) + c1.coeffs c2.coeffs + else None let extract2 pred l = - let rec xextract2 rl l = - match l with - | [] -> (None,rl) (* Did not find *) - | e::l -> - match extract (pred e) l with - | None,_ -> xextract2 (e::rl) l - | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in - - xextract2 [] l + let rec xextract2 rl l = + match l with + | [] -> (None,rl) (* Did not find *) + | e::l -> + match extract (pred e) l with + | None,_ -> xextract2 (e::rl) l + | Some (r,e'),l' -> Some (r,e,e'), List.rev_append rl l' in + xextract2 [] l -let extract_coprime_equation psys = - extract2 extract_coprime psys +let extract_coprime_equation psys = + extract2 extract_coprime psys -let apply_and_normalise f psys = - List.fold_left (fun acc pc' -> - match f pc' with - | None -> pc'::acc - | Some pc' -> - match check_sat pc' with - | Tauto -> acc - | Unsat prf -> raise (FoundProof prf) - | Cut(c,p) -> (c,p)::acc - | Normalise (c,p) -> (c,p)::acc - ) [] psys -let pivot_sys v pc psys = apply_and_normalise (pivot v pc) psys +let pivot_sys v pc psys = apply_and_normalise check_int_sat (pivot v pc) psys let reduce_coprime psys = - let oeq,sys = extract_coprime_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> - let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in - let l1' = Big_int l1 and l2' = Big_int l2 in - let cstr = - {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); - op = Eq ; - cst = (l1' */ c1.cst) +/ (l2' */ c2.cst) - } in - let prf = add_proof (mul_proof (numerator l1') p1) (mul_proof (numerator l2') p2) in - - Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) + let oeq,sys = extract_coprime_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some((v,n1,n2),(c1,p1),(c2,p2) ) -> + let (l1,l2) = ext_gcd (numerator n1) (numerator n2) in + let l1' = Big_int l1 and l2' = Big_int l2 in + let cstr = + {coeffs = Vect.add (Vect.mul l1' c1.coeffs) (Vect.mul l2' c2.coeffs); + 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 + + Some (pivot_sys v (cstr,prf) ((c1,p1)::sys)) (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - Some (fst (List.find (fun (_,n) -> n =/ (Int 1) || n=/ (Int (-1))) cstr.coeffs)) - with Not_found -> None - else None in - - let (oeq,sys) = extract is_unary_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(pivot_sys v pc sys) - -let reduce_non_lin_unary psys = - - let is_unary_equation (cstr,prf) = - if cstr.op == Eq - then - try - let x = fst (List.find (fun (x,n) -> (n =/ (Int 1) || n=/ (Int (-1))) && Monomial.is_var (LinPoly.MonT.retrieve x) ) cstr.coeffs) in - let x' = LinPoly.MonT.retrieve x in - if List.for_all (fun (y,_) -> Pervasives.(=) y x || Int.equal (snd (Monomial.div (LinPoly.MonT.retrieve y) x')) 0) cstr.coeffs - then Some x - else None - with Not_found -> None - else None in - - - let (oeq,sys) = extract is_unary_equation psys in - match oeq with - | None -> None (* Nothing to do *) - | Some(v,pc) -> - Some(apply_and_normalise (LinPoly.pivot_eq v pc) sys) + let is_unary_equation (cstr,prf) = + if cstr.op == Eq + then + Vect.find (fun v n -> if n =/ (Int 1) || n=/ (Int (-1)) then Some v else None) cstr.coeffs + else None in + + let (oeq,sys) = extract is_unary_equation psys in + match oeq with + | None -> None (* Nothing to do *) + | Some(v,pc) -> + Some(pivot_sys v pc sys) + let reduce_var_change psys = - let rec rel_prime vect = - match vect with - | [] -> None - | (x,v)::vect -> - let v = numerator v in - try - let (x',v') = List.find (fun (_,v') -> - let v' = numerator v' in - eq_big_int (gcd_big_int v v') unit_big_int) vect in - Some ((x,v),(x',numerator v')) - with Not_found -> rel_prime vect in - - let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in - - let (oeq,sys) = extract rel_prime psys in - - match oeq with - | None -> None - | Some(((x,v),(x',v')),(c,p)) -> - let (l1,l2) = ext_gcd v v' in - let l1,l2 = Big_int l1 , Big_int l2 in - - let get v vect = - match Vect.get v vect with - | None -> Int 0 - | Some n -> n in - - let pivot_eq (c',p') = - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let vx = get x coeffs in - let vx' = get x' coeffs in - 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(([], m),p),p')) in - - Some (apply_and_normalise pivot_eq sys) - -let iterate_until_stable f x = - let rec iter x = - match f x with - | None -> x - | Some x' -> iter x' in - iter x - -let rec app_funs l x = - match l with - | [] -> None - | f::fl -> - match f x with - | None -> app_funs fl x - | Some x' -> Some x' + let rec rel_prime vect = + match Vect.choose vect with + | None -> None + | Some(x,v,vect) -> + let v = numerator v in + match Vect.find (fun x' v' -> + let v' = numerator v' in + if eq_big_int (gcd_big_int v v') unit_big_int + then Some(x',v') else None) vect with + | Some(x',v') -> Some ((x,v),(x', v')) + | None -> rel_prime vect in + + let rel_prime (cstr,prf) = if cstr.op == Eq then rel_prime cstr.coeffs else None in + + let (oeq,sys) = extract rel_prime psys in + + match oeq with + | None -> None + | Some(((x,v),(x',v')),(c,p)) -> + let (l1,l2) = ext_gcd v v' in + let l1,l2 = Big_int l1 , Big_int l2 in + + + let pivot_eq (c',p') = + let {coeffs = coeffs ; op = op ; cst = cst} = c' in + let vx = Vect.get x coeffs in + let vx' = Vect.get x' coeffs in + 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 + + Some (apply_and_normalise check_int_sat pivot_eq sys) + let reduction_equations psys = - iterate_until_stable (app_funs - [reduce_unary ; reduce_coprime ; - reduce_var_change (*; reduce_pivot*)]) psys + iterate_until_stable (app_funs + [reduce_unary ; reduce_coprime ; + reduce_var_change (*; reduce_pivot*)]) psys -let reduction_non_lin_equations psys = - iterate_until_stable (app_funs - [reduce_non_lin_unary (*; reduce_coprime ; - reduce_var_change ; reduce_pivot *)]) psys - (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) +(** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = - let is_small (v,i) = - match Itv.range i with - | None -> false - | Some i -> i <=/ (Int 1) in - - let select_best (x1,i1) (x2,i2) = - if Itv.smaller_itv i1 i2 - then (x1,i1) else (x2,i2) in - - (* For lia, there are no equations => these precautions are not needed *) - (* For nlia, there are equations => do not enumerate over equations! *) - let all_planes sys = - let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in - match eq with - | [] -> List.rev_map (fun c -> c.coeffs) ineq - | _ -> - List.fold_left (fun acc c -> - if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq - then acc else c.coeffs ::acc) [] ineq in - - let smallest_interval = - List.fold_left - (fun acc vect -> - if is_small acc - then acc - else - match Fourier.optimise vect sys with - | None -> acc - | Some i -> - if debug then Printf.printf "Found a new bound %a" Vect.pp_vect vect ; - select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in - let smallest_interval = - match smallest_interval - with - | (x,(Some i, Some j)) -> Some(i,x,j) - | x -> None (* This should not be possible *) - in - match smallest_interval with - | Some (lb,e,ub) -> - let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in - let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in - (match - (* x <= ub -> x > ub *) - xlinear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), - (* lb <= x -> lb > x *) - xlinear_prover - ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) - with - | Some cub , Some clb -> Some(List.tl clb,(lb,e,ub), List.tl cub) - | _ -> failwith "Interval without proof" - ) - | None -> None + let is_small (v,i) = + match Itv.range i with + | None -> false + | Some i -> i <=/ (Int 1) in + + let select_best (x1,i1) (x2,i2) = + if Itv.smaller_itv i1 i2 + then (x1,i1) else (x2,i2) in + + (* For lia, there are no equations => these precautions are not needed *) + (* For nlia, there are equations => do not enumerate over equations! *) + let all_planes sys = + let (eq,ineq) = List.partition (fun c -> c.op == Eq) sys in + match eq with + | [] -> List.rev_map (fun c -> c.coeffs) ineq + | _ -> + List.fold_left (fun acc c -> + if List.exists (fun c' -> Vect.equal c.coeffs c'.coeffs) eq + then acc else c.coeffs ::acc) [] ineq in + + let smallest_interval = + List.fold_left + (fun acc vect -> + if is_small acc + then acc + else + match optimise vect sys with + | None -> acc + | Some i -> + if debug then Printf.printf "Found a new bound %a in %a" Vect.pp vect Itv.pp i; + select_best (vect,i) acc) (Vect.null, (None,None)) (all_planes sys) in + let smallest_interval = + match smallest_interval + with + | (x,(Some i, Some j)) -> Some(i,x,j) + | x -> None (* This should not be possible *) + in + match smallest_interval with + | Some (lb,e,ub) -> + let (lbn,lbd) = (sub_big_int (numerator lb) unit_big_int, denominator lb) in + let (ubn,ubd) = (add_big_int unit_big_int (numerator ub) , denominator ub) in + (match + (* x <= ub -> x > ub *) + direct_linear_prover ({coeffs = Vect.mul (Big_int ubd) e ; op = Ge ; cst = Big_int ubn} :: sys), + (* lb <= x -> lb > x *) + direct_linear_prover + ({coeffs = Vect.mul (minus_num (Big_int lbd)) e ; op = Ge ; cst = minus_num (Big_int lbn)} :: sys) + with + | Some cub , Some clb -> Some(List.tl (Vect.to_list clb),(lb,e,ub), List.tl (Vect.to_list cub)) + | _ -> failwith "Interval without proof" + ) + | None -> None let check_sys sys = - List.for_all (fun (c,p) -> List.for_all (fun (_,n) -> sign_num n <> 0) c.coeffs) sys + List.for_all (fun (c,p) -> Vect.for_all (fun _ n -> sign_num n <> 0) c.coeffs) sys let xlia (can_enum:bool) reduction_equations sys = - - let rec enum_proof (id:int) (sys:prf_sys) : proof option = - 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 ? *) - | Some(prf1,(lb,e,ub),prf2) -> - if debug then Printf.printf "Found interval: %a in [%s;%s] -> " Vect.pp_vect 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 prf prf1,e, proof_of_farkas prf prf2,prfl)) - | None -> None - ) - and start_enum id e clb cub sys = - if clb >/ cub - then Some [] - 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 start_enum id e (clb +/ (Int 1)) cub sys with - | None -> None - | Some l -> Some (prf::l) - - and aux_lia (id:int) (sys:prf_sys) : proof option = - assert (check_sys sys) ; - if debug then Printf.printf "xlia: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; - try - let sys = reduction_equations sys in - if debug then - Printf.printf "after reduction: %a \n" (pp_list (fun o (c,_) -> output_cstr o c)) sys ; - match linear_prover sys with - | Some prf -> Some (Step(id,prf,Done)) - | None -> if can_enum then enum_proof id sys else None - with FoundProof prf -> + let rec enum_proof (id:int) (sys:prf_sys) : ProofFormat.proof option = + 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 ? *) + | 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 + ) + + and start_enum id e clb cub sys = + if clb >/ cub + then Some [] + 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 start_enum id e (clb +/ (Int 1)) cub sys with + | None -> None + | Some l -> Some (prf::l) + + and aux_lia (id:int) (sys:prf_sys) : ProofFormat.proof option = + assert (check_sys sys) ; + if debug then Printf.printf "xlia: %a \n" (pp_list ";" (fun o (c,_) -> output_cstr o c)) sys ; + try + let sys = reduction_equations sys in + 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 + with FoundProof prf -> (* [reduction_equations] can find a proof *) - Some(Step(id,prf,Done)) in + Some(Step(id,prf,Done)) in (* let sys' = List.map (fun (p,o) -> Mc.norm0 p , o) sys in*) - let id = List.length sys in - let orpf = - try - let sys = simpl_sys sys in - aux_lia id sys - with FoundProof pr -> Some(Step(id,pr,Done)) in - match orpf with - | None -> None - | Some prf -> - (*Printf.printf "direct proof %a\n" output_proof prf ; *) - let env = List.mapi (fun i _ -> i) sys in - let prf = compile_proof env prf in - (*try + let id = 1 + (List.fold_left + (fun acc (_,r) -> max acc (ProofFormat.pr_rule_max_id r)) 0 sys) in + let orpf = + try + let sys = simpl_sys sys in + aux_lia id sys + with FoundProof pr -> Some(Step(id,pr,Done)) in + match orpf with + | None -> None + | Some prf -> + let env = CList.interval 0 (id - 1) in + if debug then begin + Printf.fprintf stdout "direct proof %a\n" output_proof prf; + flush stdout; + end; + let prf = compile_proof env prf in + (*try if Mc.zChecker sys' prf then Some prf else raise Certificate.BadCertificate with Failure s -> (Printf.printf "%s" s ; Some prf) - *) Some prf - - -let cstr_compat_of_poly (p,o) = - let (v,c) = LinPoly.linpol_of_pol p in - {coeffs = v ; op = o ; cst = minus_num c } - + *) Some 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 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) + +let xlia env0 en red sys = + if !use_simplex then xlia_simplex env0 sys + else xlia en red sys + + +let dump_file = ref None + +let gen_bench (tac, prover) can_enum prfdepth sys = + let res = prover can_enum prfdepth sys in + (match !dump_file with + | None -> () + | Some file -> + begin + let o = open_out (Filename.temp_file ~temp_dir:(Sys.getcwd ()) file ".v") in + let sys = develop_constraints prfdepth z_spec sys in + Printf.fprintf o "Require Import ZArith Lia. Open Scope Z_scope.\n"; + Printf.fprintf o "Goal %a.\n" (LinPoly.pp_goal "Z") (List.map fst sys) ; + begin + match res with + | None -> + Printf.fprintf o "Proof.\n intros. Fail %s.\nAbort.\n" tac + | Some res -> + Printf.fprintf o "Proof.\n intros. %s.\nQed.\n" tac + end + ; + flush o ; + close_out o ; + end); + res let lia (can_enum:bool) (prfdepth:int) sys = - LinPoly.MonT.clear (); - max_nb_cstr := compute_max_nb_cstr sys prfdepth ; - let sys = List.map (develop_constraint z_spec) sys in - let (sys:cstr_compat list) = List.map cstr_compat_of_poly sys in - let sys = List.mapi (fun i c -> (c,Hyp i)) sys in - xlia can_enum reduction_equations sys + let sys = develop_constraints prfdepth z_spec sys in + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + + 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' +let make_cstr_system sys = + List.map (fun ((p,o),prf) -> (cstr_of_poly (p,o), prf)) sys let nlia enum prfdepth sys = - LinPoly.MonT.clear (); - max_nb_cstr := compute_max_nb_cstr sys prfdepth; - let sys = List.map (develop_constraint z_spec) sys in - let sys = List.mapi (fun i c -> (c,Hyp i)) sys in - - let is_linear = List.for_all (fun ((p,_),_) -> Poly.is_linear p) sys in - - let collect_square = - List.fold_left (fun acc ((p,_),_) -> Poly.fold - (fun m _ acc -> - match Monomial.sqrt m with - | None -> acc - | Some s -> MonMap.add s m acc) p acc) MonMap.empty sys in - let sys = MonMap.fold (fun s m acc -> - let s = LinPoly.linpol_of_pol (Poly.add s (Int 1) (Poly.constant (Int 0))) in - let m = Poly.add m (Int 1) (Poly.constant (Int 0)) in - ((m, Ge), (Square s))::acc) collect_square sys in - - (* List.iter (fun ((p,_),_) -> Printf.printf "square %a\n" Poly.pp p) gen_square*) - - let sys = - if is_linear then sys - else sys @ (all_sym_pairs (fun ((c,o),p) ((c',o'),p') -> - ((Poly.product c c',opMult o o'), MulPrf(p,p'))) sys) in + let sys = develop_constraints prfdepth z_spec sys in + let is_linear = List.for_all (fun ((p,_),_) -> LinPoly.is_linear p) sys in + + if debug then begin + Printf.fprintf stdout "Input problem\n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + end; + + if is_linear + then xlia (List.map fst sys) enum reduction_equations (make_cstr_system sys) + else + (* + let sys1 = elim_every_substitution sys in + No: if a wrong equation is chosen, the proof may fail. + It would only be safe if the variable is linear... + *) + let sys1 = elim_simple_linear_equality sys in + let sys2 = saturate_linear_equality_non_linear sys1 in + let sys3 = nlinear_preprocess (sys1@sys2) in + + let sys4 = make_cstr_system ((*sys2@*)sys3) in + (* [reduction_equations] is too brutal - there should be some non-linear reasoning *) + xlia (List.map fst sys) enum reduction_equations sys4 + +(* For regression testing, if bench = true generate a Coq goal *) + +let lia can_enum prfdepth sys = + gen_bench ("lia",lia) can_enum prfdepth sys + +let nlia enum prfdepth sys = + gen_bench ("nia",nlia) enum prfdepth sys + - let sys = List.map (fun (c,p) -> cstr_compat_of_poly c,p) sys in - assert (check_sys sys) ; - xlia enum (if is_linear then reduction_equations else reduction_non_lin_equations) sys diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index 13d50d1eee..e925f1bc5e 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -10,13 +10,33 @@ module Mc = Micromega -type 'a number_spec +(** [use_simplex] is bound to the Coq option Simplex. + If set, use the Simplex method, otherwise use Fourier *) +val use_simplex : bool ref + +(** [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 + +(** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz + +(** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) 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 + +(** [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 + +(** [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 + +(** [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 linear_prover_with_cert : int -> 'a number_spec -> - ('a Mc.pExpr * Mc.op1) list -> 'a Mc.psatz option -val q_spec : Mc.q number_spec diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e0a369ca5f..402e8b91e6 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,7 +12,7 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules ISet, M, Mc, Env, Cache, CacheZ *) +(* - Modules M, Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-20011 *) (* *) @@ -44,7 +44,7 @@ let lia_enum = ref true let lia_proof_depth = ref max_depth let get_lia_option () = - (!lia_enum,!lia_proof_depth) + (!Certificate.use_simplex,!lia_enum,!lia_proof_depth) let get_lra_option () = !lra_proof_depth @@ -70,10 +70,32 @@ let _ = optread = (fun () -> !lia_enum); optwrite = (fun x -> lia_enum := x) } in + + let solver_opt = + { + optdepr = false; + optname = "Use the Simplex instead of Fourier elimination"; + optkey = ["Simplex"]; + optread = (fun () -> !Certificate.use_simplex); + optwrite = (fun x -> Certificate.use_simplex := x) + } in + + let dump_file_opt = + { + optdepr = false; + optname = "Generate Coq goals in file from calls to 'lia' 'nia'"; + optkey = ["Dump"; "Arith"]; + optread = (fun () -> !Certificate.dump_file); + optwrite = (fun x -> Certificate.dump_file := x) + } in + + let _ = declare_bool_option solver_opt in + let _ = declare_stringopt_option dump_file_opt in let _ = declare_int_option (int_opt ["Lra"; "Depth"] lra_proof_depth) in let _ = declare_int_option (int_opt ["Lia"; "Depth"] lia_proof_depth) in let _ = declare_bool_option lia_enum_opt in () + (** * Initialize a tag type to the Tag module declaration (see Mutils). @@ -288,11 +310,6 @@ let rec add_term t0 = function xcnf true f -(** - * MODULE: Ordered set of integers. - *) - -module ISet = Set.Make(Int) (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of @@ -340,6 +357,8 @@ struct ["Coq";"Reals" ; "Rpow_def"]; ["LRing_normalise"]] +[@@@ocaml.warning "-3"] + let coq_modules = Coqlib.(init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules @ mic_modules) @@ -362,6 +381,8 @@ struct let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules + [@@@ocaml.warning "+3"] + let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module let r_constant = gen_constant_in_modules "ZMicromega" r_modules @@ -1937,7 +1958,9 @@ let really_call_csdpcert : provername -> micromega_polys -> Sos_types.positivste ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in match ((command cmdname [|cmdname|] (provername,poly)) : csdp_certificate) with - | F str -> failwith str + | F str -> + if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; + raise (failwith str) | S res -> res (** @@ -2047,7 +2070,7 @@ let compact_pt pt f = let lift_pexpr_prover p l = p (List.map (fun (e,o) -> Mc.denorm e , o) l) module CacheZ = PHashtable(struct - type prover_option = bool * int + type prover_option = bool * bool* int type t = prover_option * ((Mc.z Mc.pol * Mc.op1) list) let equal = (=) @@ -2060,8 +2083,8 @@ module CacheQ = PHashtable(struct let hash = Hashtbl.hash end) -let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) +let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) +let memo_nlia = CacheZ.memo ".nia.cache" (fun ((_,ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) @@ -2069,7 +2092,7 @@ let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certifi let linear_prover_Q = { name = "linear prover"; get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; @@ -2080,7 +2103,7 @@ let linear_prover_Q = { let linear_prover_R = { name = "linear prover"; get_option = get_lra_option ; - prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o Certificate.q_spec) l) ; + prover = (fun (o,l) -> lift_pexpr_prover (Certificate.linear_prover_with_cert o ) l) ; hyps = hyps_of_cone ; compact = compact_cone ; pp_prf = pp_psatz pp_q ; diff --git a/plugins/micromega/itv.ml b/plugins/micromega/itv.ml new file mode 100644 index 0000000000..dc1df7ec9f --- /dev/null +++ b/plugins/micromega/itv.ml @@ -0,0 +1,80 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Intervals (extracted from mfourier.ml) *) + +open Num + (** The type of intervals is *) + type interval = num option * num option + (** None models the absence of bound i.e. infinity *) + (** As a result, + - None , None -> \]-oo,+oo\[ + - None , Some v -> \]-oo,v\] + - Some v, None -> \[v,+oo\[ + - Some v, Some v' -> \[v,v'\] + Intervals needs to be explicitly normalised. + *) + + let pp o (n1,n2) = + (match n1 with + | None -> output_string o "]-oo" + | Some n -> Printf.fprintf o "[%s" (string_of_num n) + ); + output_string o ","; + (match n2 with + | None -> output_string o "+oo[" + | Some n -> Printf.fprintf o "%s]" (string_of_num n) + ) + + + + (** if then interval [itv] is empty, [norm_itv itv] returns [None] + otherwise, it returns [Some itv] *) + + let norm_itv itv = + match itv with + | Some a , Some b -> if a <=/ b then Some itv else None + | _ -> Some itv + +(** [inter i1 i2 = None] if the intersection of intervals is empty + [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) + let inter i1 i2 = + let (l1,r1) = i1 + and (l2,r2) = i2 in + + let inter f o1 o2 = + match o1 , o2 with + | None , None -> None + | Some _ , None -> o1 + | None , Some _ -> o2 + | Some n1 , Some n2 -> Some (f n1 n2) in + + norm_itv (inter max_num l1 l2 , inter min_num r1 r2) + + let range = function + | None,_ | _,None -> None + | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) + + + let smaller_itv i1 i2 = + match range i1 , range i2 with + | None , _ -> false + | _ , None -> true + | Some i , Some j -> i <=/ j + + +(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) +let in_bound bnd v = + let (l,r) = bnd in + match l , r with + | None , None -> true + | None , Some a -> v <=/ a + | Some a , None -> a <=/ v + | Some a , Some b -> a <=/ v && v <=/ b diff --git a/plugins/micromega/itv.mli b/plugins/micromega/itv.mli new file mode 100644 index 0000000000..31f6a89fe2 --- /dev/null +++ b/plugins/micromega/itv.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) +open Num + +type interval = num option * num option +val pp : out_channel -> interval -> unit +val inter : interval -> interval -> interval option +val range : interval -> num option +val smaller_itv : interval -> interval -> bool +val in_bound : interval -> num -> bool +val norm_itv : interval -> interval option diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 3328abdab7..baf8c82355 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + open Util open Num open Polynomial @@ -8,66 +18,6 @@ let debug = false let compare_float (p : float) q = Pervasives.compare p q (** Implementation of intervals *) -module Itv = -struct - - (** The type of intervals is *) - type interval = num option * num option - (** None models the absence of bound i.e. infinity *) - (** As a result, - - None , None -> \]-oo,+oo\[ - - None , Some v -> \]-oo,v\] - - Some v, None -> \[v,+oo\[ - - Some v, Some v' -> \[v,v'\] - Intervals needs to be explicitly normalised. - *) - - (** if then interval [itv] is empty, [norm_itv itv] returns [None] - otherwise, it returns [Some itv] *) - - let norm_itv itv = - match itv with - | Some a , Some b -> if a <=/ b then Some itv else None - | _ -> Some itv - -(** [inter i1 i2 = None] if the intersection of intervals is empty - [inter i1 i2 = Some i] if [i] is the intersection of the intervals [i1] and [i2] *) - let inter i1 i2 = - let (l1,r1) = i1 - and (l2,r2) = i2 in - - let inter f o1 o2 = - match o1 , o2 with - | None , None -> None - | Some _ , None -> o1 - | None , Some _ -> o2 - | Some n1 , Some n2 -> Some (f n1 n2) in - - norm_itv (inter max_num l1 l2 , inter min_num r1 r2) - - let range = function - | None,_ | _,None -> None - | Some i,Some j -> Some (floor_num j -/ceiling_num i +/ (Int 1)) - - - let smaller_itv i1 i2 = - match range i1 , range i2 with - | None , _ -> false - | _ , None -> true - | Some i , Some j -> i <=/ j - - -(** [in_bound bnd v] checks whether [v] is within the bounds [bnd] *) -let in_bound bnd v = - let (l,r) = bnd in - match l , r with - | None , None -> true - | None , Some a -> v <=/ a - | Some a , None -> a <=/ v - | Some a , Some b -> a <=/ v && v <=/ b - - -end open Itv type vector = Vect.t @@ -84,8 +34,6 @@ type proof = | Elim of var * proof * proof | And of proof * proof -let max_nb_cstr = ref max_int - type system = { sys : cstr_info ref System.t ; vars : ISet.t @@ -126,7 +74,7 @@ let pp_cstr o (vect,bnd) = | None -> () | Some n -> Printf.fprintf o "%s <= " (string_of_num n)) ; - pp_vect o vect ; + Vect.pp o vect ; (match r with | None -> output_string o"\n" | Some n -> Printf.fprintf o "<=%s\n" (string_of_num n)) @@ -185,30 +133,23 @@ let normalise_cstr vect cinfo = match norm_itv cinfo.bound with | None -> Contradiction | Some (l,r) -> - match vect with - | [] -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction - | (_,n)::_ -> Cstr( - (if n <>/ Int 1 then List.map (fun (x,nx) -> (x,nx // n)) vect else vect), + match Vect.choose vect with + | None -> if Itv.in_bound (l,r) (Int 0) then Redundant else Contradiction + | Some (_,n,_) -> Cstr(Vect.div n vect, let divn x = x // n in if Int.equal (sign_num n) 1 then{cinfo with bound = (Option.map divn l , Option.map divn r) } else {cinfo with pos = cinfo.neg ; neg = cinfo.pos ; bound = (Option.map divn r , Option.map divn l)}) -(** For compatibility, there is an external representation of constraints *) +(** For compatibility, there is an external representation of constraints *) -let eval_op = function - | Eq -> (=/) - | Ge -> (>=/) let count v = - let rec count n p v = - match v with - | [] -> (n,p) - | (_,vl)::v -> let sg = sign_num vl in - assert (sg <> 0) ; - if Int.equal sg 1 then count n (p+1) v else count (n+1) p v in - count 0 0 v + Vect.fold (fun (n,p) _ vl -> + let sg = sign_num vl in + assert (sg <> 0) ; + if Int.equal sg 1 then (n,p+1)else (n+1, p)) (0,0) v let norm_cstr {coeffs = v ; op = o ; cst = c} idx = @@ -217,7 +158,9 @@ let norm_cstr {coeffs = v ; op = o ; cst = c} idx = normalise_cstr v {pos = p ; neg = n ; bound = (match o with | Eq -> Some c , Some c - | Ge -> Some c , None) ; + | Ge -> Some c , None + | Gt -> raise Polynomial.Strict + ) ; prf = Assum idx } @@ -237,7 +180,7 @@ let load_system l = | Redundant -> vrs | Cstr(vect,info) -> xadd_cstr vect info sys ; - List.fold_left (fun s (v,_) -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in + Vect.fold (fun s v _ -> ISet.add v s) vrs cstr.coeffs) ISet.empty li in {sys = sys ;vars = vars} @@ -255,27 +198,7 @@ let system_list sys = let add (v1,c1) (v2,c2) = assert (c1 <>/ Int 0 && c2 <>/ Int 0) ; - - let rec xadd v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if Int.equal x1 x2 - then - let n' = (n1 // c1) +/ (n2 // c2) in - if n' =/ Int 0 then xadd v1' v2' - else - let res = xadd v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = xadd v1' v2 in - (x1, n1 // c1)::res - else let res = xadd v1 v2' in - (x2, n2 // c2)::res - | [] , [] -> [] - | [] , _ -> List.map (fun (x,vl) -> (x,vl // c2)) v2 - | _ , [] -> List.map (fun (x,vl) -> (x,vl // c1)) v1 in - - let res = xadd v1 v2 in + let res = mul_add (Int 1 // c1) v1 (Int 1 // c2) v2 in (res, count res) let add (v1,c1) (v2,c2) = @@ -294,9 +217,9 @@ let add (v1,c1) (v2,c2) = let split x (vect: vector) info (l,m,r) = match get x vect with - | None -> (* The constraint does not mention [x], store it in m *) + | Int 0 -> (* The constraint does not mention [x], store it in m *) (l,(vect,info)::m,r) - | Some vl -> (* otherwise *) + | vl -> (* otherwise *) let cons_bound lst bd = match bd with @@ -352,7 +275,8 @@ let project vr sys = let project_using_eq vr c vect bound prf (vect',info') = match get vr vect' with - | Some c2 -> + | Int 0 -> (vect',info') + | c2 -> let c1 = if c2 >=/ Int 0 then minus_num c else c in let c2 = abs_num c2 in @@ -367,10 +291,10 @@ let project_using_eq vr c vect bound prf (vect',info') = (Option.map f l , Option.map f r) in (vres,{neg = n ; pos = p ; bound = bndres ; prf = Elim(vr,prf,info'.prf)}) - | None -> (vect',info') + let elim_var_using_eq vr vect cst prf sys = - let c = Option.get (get vr vect) in + let c = get vr vect in let elim_var = project_using_eq vr c vect cst prf in @@ -397,16 +321,13 @@ module IMap = CMap.Make(Int) The function returns as second argument, a sub-vector consisting in the variables that are not in [map]. *) let eval_vect map vect = - let rec xeval_vect vect sum rst = - match vect with - | [] -> (sum,rst) - | (v,vl)::vect -> - try - let val_v = IMap.find v map in - xeval_vect vect (sum +/ (val_v */ vl)) rst - with - Not_found -> xeval_vect vect sum ((v,vl)::rst) in - xeval_vect vect (Int 0) [] + Vect.fold (fun (sum,rst) v vl -> + try + let val_v = IMap.find v map in + (sum +/ (val_v */ vl), rst) + with + Not_found -> (sum, Vect.set v vl rst)) (Int 0,Vect.null) vect + (** [restrict_bound n sum itv] returns the interval of [x] @@ -427,11 +348,13 @@ let restrict_bound n sum (itv:interval) = let bound_of_variable map v sys = System.fold (fun vect iref bnd -> let sum,rst = eval_vect map vect in - let vl = match get v rst with - | None -> Int 0 - | Some v -> v in + let vl = Vect.get v rst in match inter bnd (restrict_bound vl sum (!iref).bound) with - | None -> failwith "bound_of_variable: impossible" + | None -> + Printf.fprintf stdout "bound_of_variable: eval_vecr %a = %s,%a\n" + Vect.pp vect (Num.string_of_num sum) Vect.pp rst ; + Printf.fprintf stdout "current interval: %a\n" Itv.pp (!iref).bound; + failwith "bound_of_variable: impossible" | Some itv -> itv) sys (None,None) @@ -458,12 +381,13 @@ let solve_sys black_v choose_eq choose_variable sys sys_l = let rec solve_sys sys sys_l = if debug then Printf.printf "S #%i size %i\n" (System.length sys.sys) (size sys.sys); + if debug then Printf.printf "solve_sys :\n %a" pp_system sys.sys ; let eqs = choose_eq sys in try let (v,vect,cst,ln) = fst (List.find (fun ((v,_,_,_),_) -> v <> black_v) eqs) in if debug then - (Printf.printf "\nE %a = %s variable %i\n" pp_vect vect (string_of_num cst) v ; + (Printf.printf "\nE %a = %s variable %i\n" Vect.pp vect (string_of_num cst) v ; flush stdout); let sys' = elim_var_using_eq v vect cst ln sys in solve_sys sys' ((v,sys)::sys_l) @@ -503,9 +427,9 @@ struct match l with | [] -> (ltl, n,z,p) | (l1,info) ::rl -> - match l1 with - | [] -> xpart rl (([],info)::ltl) n (info.neg+info.pos+z) p - | (vr,vl)::rl1 -> + match Vect.choose l1 with + | None -> xpart rl ((Vect.null,info)::ltl) n (info.neg+info.pos+z) p + | Some(vr, vl, rl1) -> if Int.equal v vr then let cons_bound lst bd = @@ -557,24 +481,26 @@ struct | _ -> false let rec unroll_until v l = - match l with - | [] -> (false,[]) - | (i,_)::rl -> if Int.equal i v + match Vect.choose l with + | None -> (false,Vect.null) + | Some(i,_,rl) -> if Int.equal i v then (true,rl) else if i < v then unroll_until v rl else (false,l) + let rec choose_simple_equation eqs = match eqs with | [] -> None | (vect,a,prf,ln)::eqs -> - match vect with - | [i,_] -> Some (i,vect,a,prf,ln) - | _ -> choose_simple_equation eqs + match Vect.choose vect with + | Some(i,v,rst) -> if Vect.is_null rst + then Some (i,vect,a,prf,ln) + else choose_simple_equation eqs + | _ -> choose_simple_equation eqs - - let choose_primal_equation eqs sys_l = + let choose_primal_equation eqs (sys_l: (Vect.t *cstr_info) list) = (* Counts the number of equations referring to variable [v] -- It looks like nb_cst is dead... @@ -586,9 +512,9 @@ struct else nb_eq) 0 sys_l in let rec find_var vect = - match vect with - | [] -> None - | (i,_)::vect -> + match Vect.choose vect with + | None -> None + | Some(i,_,vect) -> let nb_eq = is_primal_equation_var i in if Int.equal nb_eq 2 then Some i else find_var vect in @@ -638,9 +564,9 @@ struct let cost_eq eq const prf ln acc_costs = let rec cost_eq eqr sysl costs = - match eqr with - | [] -> costs - | (v,_) ::eqr -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in + match Vect.choose eqr with + | None -> costs + | Some(v,_,eqr) -> let (cst,tlsys) = estimate_cost v (ln-1) sysl 0 [] in cost_eq eqr tlsys (((v,eq,const,prf),cst)::costs) in cost_eq eq sys_l acc_costs in @@ -692,10 +618,10 @@ struct in let map = rebuild_solution l IMap.empty in - let vect = List.rev (IMap.fold (fun v i vect -> (v,i)::vect) map []) in -(* Printf.printf "SOLUTION %a" pp_vect vect ; *) - let res = Inl vect in - res + let vect = IMap.fold (fun v i vect -> Vect.set v i vect) map Vect.null in + if debug then Printf.printf "SOLUTION %a" Vect.pp vect ; + let res = Inl vect in + res end @@ -735,8 +661,8 @@ struct and {coeffs = v2 ; op = op2 ; cst = n2} = c2 in match Vect.get v v1 , Vect.get v v2 with - | None , _ | _ , None -> None - | Some a , Some b -> + | Int 0 , _ | _ , Int 0 -> None + | a , b -> if Int.equal ((sign_num a) * (sign_num b)) (-1) then Some (add (p1,abs_num a) (p2,abs_num b) , @@ -768,7 +694,7 @@ struct | Cstr(v,info) -> Inl ((prf,cstr,v,info)::acc)) (Inl []) l - type oproof = (vector * cstr_compat * num) option + type oproof = (vector * cstr * num) option let merge_proof (oleft:oproof) (prf,cstr,v,info) (oright:oproof) = let (l,r) = info.bound in @@ -789,9 +715,9 @@ struct if l <=/ r then Inl (oleft,oright) else (* There is a contradiction - it should show up by scaling up the vectors - any pivot should do*) - match cstrr.coeffs with - | [] -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) - | (v,_)::_ -> + match Vect.choose cstrr.coeffs with + | None -> Inr (add (prfl,Int 1) (prfr,Int 1), cstrr) (* this is wrong *) + | Some(v,_,_) -> match pivot v (prfl,cstrl) (prfr,cstrr) with | None -> failwith "merge_proof : pivot is not possible" | Some x -> Inr x @@ -804,7 +730,7 @@ let mk_proof hyps prf = let rec mk_proof prf = match prf with - | Assum i -> [ ([i, Int 1] , List.nth hyps i) ] + | Assum i -> [ (Vect.set i (Int 1) Vect.null , List.nth hyps i) ] | Elim(v,prf1,prf2) -> let prfsl = mk_proof prf1 diff --git a/plugins/micromega/mfourier.mli b/plugins/micromega/mfourier.mli index f1d8edeab6..45a81cc118 100644 --- a/plugins/micromega/mfourier.mli +++ b/plugins/micromega/mfourier.mli @@ -8,25 +8,18 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module Itv : sig - - type interval = Num.num option * Num.num option - val range : interval -> Num.num option - val smaller_itv : interval -> interval -> bool - -end - module IMap : CSig.MapS with type key = int type proof module Fourier : sig - val find_point : Polynomial.cstr_compat list -> - ((IMap.key * Num.num) list, proof) Util.union - val optimise : Polynomial.Vect.t -> - Polynomial.cstr_compat list -> + val find_point : Polynomial.cstr list -> + (Vect.t, proof) Util.union + + val optimise : Vect.t -> + Polynomial.cstr list -> Itv.interval option end @@ -35,15 +28,11 @@ val pp_proof : out_channel -> proof -> unit module Proof : sig - val mk_proof : Polynomial.cstr_compat list -> - proof -> (Polynomial.Vect.t * Polynomial.cstr_compat) list + val mk_proof : Polynomial.cstr list -> + proof -> (Vect.t * Polynomial.cstr) list val add_op : Polynomial.op -> Polynomial.op -> Polynomial.op end -val max_nb_cstr : int ref - -val eval_op : Polynomial.op -> Num.num -> Num.num -> bool - exception TimeOut diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 52c6ef983d..f67f1da146 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1484,17 +1484,17 @@ let psub1 = let padd1 = padd0 Z0 Z.add zeq_bool -(** val norm0 : z pExpr -> z pol **) +(** val normZ : z pExpr -> z pol **) -let norm0 = +let normZ = norm Z0 (Zpos XH) Z.add Z.mul Z.sub Z.opp zeq_bool (** val xnormalise0 : z formula -> z nFormula list **) let xnormalise0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 (padd1 rhs0 (Pc (Zpos XH)))),NonStrict)::(((psub1 rhs0 @@ -1516,8 +1516,8 @@ let normalise t0 = let xnegate0 t0 = let { flhs = lhs; fop = o; frhs = rhs } = t0 in - let lhs0 = norm0 lhs in - let rhs0 = norm0 rhs in + let lhs0 = normZ lhs in + let rhs0 = normZ rhs in (match o with | OpEq -> ((psub1 lhs0 rhs0),Equal)::[] | OpNEq -> @@ -1707,6 +1707,12 @@ let qunsat = let qdeduce = nformula_plus_nformula { qnum = Z0; qden = XH } qplus qeq_bool +(** val normQ : q pExpr -> q pol **) + +let normQ = + norm { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus qmult + qminus qopp qeq_bool + (** val qTautoChecker : q formula bFormula -> qWitness list -> bool **) let qTautoChecker f w = diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 9619781786..72c2bf7da3 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -151,8 +151,7 @@ val mkPinj : positive -> 'a1 pol -> 'a1 pol val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol -val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol +val mkPX : 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val mkXi : 'a1 -> 'a1 -> positive -> 'a1 pol @@ -164,49 +163,27 @@ 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 @@ -220,16 +197,12 @@ 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 = | TT @@ -251,32 +224,22 @@ val tt : 'a1 cnf val ff : 'a1 cnf -val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option +val add_term : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 clause option -val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> - 'a1 clause option +val or_clause : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> 'a1 clause option -val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 - cnf +val or_clause_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 cnf -val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf +val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 cnf val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf -val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf +val xcnf : ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 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 -> 'a2 cnf) -> ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool @@ -307,32 +270,24 @@ type 'c psatz = val map_option : ('a1 -> 'a2 option) -> 'a1 option -> 'a2 option -val map_option2 : - ('a1 -> 'a2 -> 'a3 option) -> 'a1 option -> 'a2 option -> 'a3 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 + '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 @@ -345,36 +300,27 @@ 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 -> 'a1 + nFormula 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 -> 'a1 + nFormula cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -384,9 +330,7 @@ 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 type q = { qnum : z; qden : positive } @@ -431,7 +375,7 @@ val psub1 : z pol -> z pol -> z pol val padd1 : z pol -> z pol -> z pol -val norm0 : z pExpr -> z pol +val normZ : z pExpr -> z pol val xnormalise0 : z formula -> z nFormula list @@ -487,6 +431,8 @@ val qunsat : q nFormula -> bool val qdeduce : q nFormula -> q nFormula -> q nFormula option +val normQ : q pExpr -> q pol + val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = diff --git a/plugins/micromega/micromega_plugin.mlpack b/plugins/micromega/micromega_plugin.mlpack index ed253da3fd..2baf6608a4 100644 --- a/plugins/micromega/micromega_plugin.mlpack +++ b/plugins/micromega/micromega_plugin.mlpack @@ -1,8 +1,11 @@ -Sos_types Mutils +Itv +Vect +Sos_types Micromega Polynomial Mfourier +Simplex Certificate Persistent_cache Coq_micromega diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 9d03560b71..809731ecc4 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -19,11 +19,23 @@ (* *) (************************************************************************) -let rec pp_list f o l = + +module ISet = Set.Make(Int) + +module IMap = + struct + include Map.Make(Int) + + let from k m = + let (_,_,r) = split (k-1) m in + r + end + +let rec pp_list s f o l = match l with | [] -> () - | e::l -> f o e ; output_string o ";" ; pp_list f o l - + | [e] -> f o e + | e::l -> f o e ; output_string o s ; pp_list s f o l let finally f rst = try @@ -41,16 +53,7 @@ let rec try_any l x = | None -> try_any l x | x -> x -let all_sym_pairs f l = - let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in - - let rec xpairs acc l = - match l with - | [] -> acc - | e::l -> xpairs (pair_with acc e l) l in - xpairs [] l - -let all_pairs f l = +let all_pairs f l = let pair_with acc e l = List.fold_left (fun acc x -> (f e x) ::acc) acc l in let rec xpairs acc l = @@ -79,6 +82,12 @@ let extract pred l = | _ -> (fd, e::sys) ) (None,[]) 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 + open Num open Big_int @@ -97,27 +106,22 @@ let numerator = function | Int i -> Big_int.big_int_of_int i | Big_int i -> i -let rec ppcm_list c l = - match l with - | [] -> c - | e::l -> ppcm_list (ppcm c (denominator e)) l +let iterate_until_stable f x = + let rec iter x = + match f x with + | None -> x + | Some x' -> iter x' in + iter x -let rec rec_gcd_list c l = +let rec app_funs l x = match l with - | [] -> c - | e::l -> rec_gcd_list (gcd_big_int c (numerator e)) l - -let gcd_list l = - let res = rec_gcd_list zero_big_int l in - if Int.equal (compare_big_int res zero_big_int) 0 - then unit_big_int else res + | [] -> None + | f::fl -> + match f x with + | None -> app_funs fl x + | Some x' -> Some x' -let rats_to_ints l = - let c = ppcm_list unit_big_int l in - List.map (fun x -> (div_big_int (mult_big_int (numerator x) c) - (denominator x))) l -(* assoc_pos j [a0...an] = [j,a0....an,j+n],j+n+1 *) (** * MODULE: Coq to Caml data-structure mappings *) diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 094429ea18..e92f086886 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -8,6 +8,18 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) + +module ISet : Set.S with type elt = int + +module IMap : +sig + include Map.S with type key = int + + (** [from k m] returns the submap of [m] with keys greater or equal k *) + val from : key -> 'elt t -> 'elt t + +end + val numerator : Num.num -> Big_int.big_int val denominator : Num.num -> Big_int.big_int @@ -30,7 +42,7 @@ end module TagSet : CSig.SetS with type elt = Tag.t -val pp_list : (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit +val pp_list : string -> (out_channel -> 'a -> unit) -> out_channel -> 'a list -> unit module CamlToCoq : sig @@ -56,15 +68,18 @@ module CoqToCaml : sig end -val rats_to_ints : Num.num list -> Big_int.big_int list +val ppcm : Big_int.big_int -> Big_int.big_int -> Big_int.big_int val all_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list -val all_sym_pairs : ('a -> 'a -> 'b) -> 'a list -> 'b list val try_any : (('a -> 'b option) * 'c) list -> 'a -> 'b option val is_sublist : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool -val gcd_list : Num.num list -> Big_int.big_int - 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 iterate_until_stable : ('a -> 'a option) -> 'a -> 'a + +val app_funs : ('a -> 'b option) list -> 'a -> 'b option + val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index ee5a0458e8..0209030b64 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -19,11 +19,6 @@ module type PHashtable = type 'a t type key - val create : int -> string -> 'a t - (** [create i f] creates an empty persistent table - with initial size i associated with file [f] *) - - val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it migth segault. @@ -37,11 +32,6 @@ module type PHashtable = (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) - val close : 'a t -> unit - (** [close tbl] is closing the table. - Once closed, a table cannot be used. - i.e, find,add will raise UnboundTable *) - val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) @@ -71,14 +61,6 @@ struct } -let create i f = - let flags = [O_WRONLY; O_TRUNC;O_CREAT] in - { - outch = out_channel_of_descr (openfile f flags 0o666); - status = Open ; - htbl = Table.create i - } - let finally f rst = try let res = f () in @@ -181,15 +163,6 @@ let open_in f = end -let close t = - let {outch = outch ; status = status ; htbl = tbl} = t in - match t.status with - | Closed -> () (* don't do it twice *) - | Open -> - close_out outch ; - Table.clear tbl ; - t.status <- Closed - let add t k e = let {outch = outch ; status = status ; htbl = tbl} = t in if status == Closed diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index 240fa490fc..4e7a388aaf 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -15,11 +15,6 @@ module type PHashtable = type 'a t type key - val create : int -> string -> 'a t - (** [create i f] creates an empty persistent table - with initial size i associated with file [f] *) - - val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it migth segault. @@ -33,11 +28,6 @@ module type PHashtable = (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) - val close : 'a t -> unit - (** [close tbl] is closing the table. - Once closed, a table cannot be used. - i.e, find,add will raise UnboundTable *) - val memo : string -> (key -> 'a) -> (key -> 'a) (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 1d18a26f33..76e7769e82 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -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-20018 *) (* *) (************************************************************************) @@ -18,6 +18,10 @@ open Num module Utils = Mutils open Utils +module Mc = Micromega + +let max_nb_cstr = ref max_int + type var = int let debug = false @@ -25,652 +29,870 @@ let debug = false let (<+>) = add_num let (<*>) = mult_num - module Monomial : sig - type t - val const : t - val is_const : t -> bool - val var : var -> t - val is_var : t -> bool - val prod : t -> t -> t - val exp : t -> int -> t - val div : t -> t -> t * int - val compare : t -> t -> int - val pp : out_channel -> t -> unit - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a - val sqrt : t -> t option + type t + val const : t + val is_const : t -> bool + val var : var -> t + val is_var : t -> bool + val get_var : t -> var option + val prod : t -> t -> t + val exp : t -> int -> t + val div : t -> t -> t * int + val compare : t -> t -> int + val pp : out_channel -> t -> unit + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + val sqrt : t -> t option + val variables : t -> ISet.t end - = -struct - (* A monomial is represented by a multiset of variables *) - module Map = Map.Make(Int) - open Map - - type t = int Map.t - - let pp o m = Map.iter - (fun k v -> - if v = 1 then Printf.fprintf o "x%i." k - else Printf.fprintf o "x%i^%i." k v) m - - - (* The monomial that corresponds to a constant *) - let const = Map.empty - - let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 - - (* Total ordering of monomials *) - let compare: t -> t -> int = - fun m1 m2 -> - let s1 = sum_degree m1 - and s2 = sum_degree m2 in - if Int.equal s1 s2 then Map.compare Int.compare m1 m2 - else Int.compare s1 s2 - - let is_const m = (m = Map.empty) - - (* The monomial 'x' *) - let var x = Map.add x 1 Map.empty - - let is_var m = - try - not (Map.fold (fun _ i fk -> - if fk = true (* first key *) - then - if i = 1 then false - else raise Not_found - else raise Not_found) m true) - with Not_found -> false - - let sqrt m = - if is_const m then None - else - try - Some (Map.fold (fun v i acc -> - let i' = i / 2 in - if i mod 2 = 0 - then add v i' m - else raise Not_found) m const) - with Not_found -> None - - (* Get the degre of a variable in a monomial *) - let find x m = try find x m with Not_found -> 0 - - (* Product of monomials *) - let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 - - - let exp m n = - let rec exp acc n = - if n = 0 then acc - else exp (prod acc m) (n - 1) in - - exp const n - - - (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) - let div m1 m2 = - let n = fold (fun x i n -> let i' = find x m1 in - let nx = i' / i in - min n nx) m2 max_int in - - let mr = fold (fun x i' m -> - let i = find x m2 in - let ir = i' - i * n in - if ir = 0 then m - else add x ir m) m1 empty in - (mr,n) - - - let fold = fold + = struct + (* A monomial is represented by a multiset of variables *) + module Map = Map.Make(Int) + open Map + + type t = int Map.t + + let is_singleton m = + try + let (k,v) = choose m in + let (l,e,r) = split k m in + if is_empty l && is_empty r + then Some(k,v) else None + with Not_found -> None + + let pp o m = + let pp_elt o (k,v)= + if v = 1 then Printf.fprintf o "x%i" k + else Printf.fprintf o "x%i^%i" k v in + + let rec pp_list o l = + match l with + [] -> () + | [e] -> pp_elt o e + | e::l -> Printf.fprintf o "%a*%a" pp_elt e pp_list l in + + pp_list o (Map.bindings m) + + + + (* The monomial that corresponds to a constant *) + let const = Map.empty + + let sum_degree m = Map.fold (fun _ n s -> s + n) m 0 + + (* Total ordering of monomials *) + let compare: t -> t -> int = + fun m1 m2 -> + let s1 = sum_degree m1 + and s2 = sum_degree m2 in + if Int.equal s1 s2 then Map.compare Int.compare m1 m2 + else Int.compare s1 s2 + + let is_const m = (m = Map.empty) + + (* The monomial 'x' *) + let var x = Map.add x 1 Map.empty + + let is_var m = + match is_singleton m with + | None -> false + | Some (_,i) -> i = 1 + + let get_var m = + match is_singleton m with + | None -> None + | Some (k,i) -> if i = 1 then Some k else None + + + let sqrt m = + if is_const m then None + else + try + Some (Map.fold (fun v i acc -> + let i' = i / 2 in + if i mod 2 = 0 + then add v i' acc + else raise Not_found) m const) + with Not_found -> None + + + (* Get the degre of a variable in a monomial *) + let find x m = try find x m with Not_found -> 0 + + (* Product of monomials *) + let prod m1 m2 = Map.fold (fun k d m -> add k ((find k m) + d) m) m1 m2 + + let exp m n = + let rec exp acc n = + if n = 0 then acc + else exp (prod acc m) (n - 1) in + + exp const n + + (* [div m1 m2 = mr,n] such that mr * (m2)^n = m1 *) + let div m1 m2 = + let n = fold (fun x i n -> let i' = find x m1 in + let nx = i' / i in + min n nx) m2 max_int in + + let mr = fold (fun x i' m -> + let i = find x m2 in + let ir = i' - i * n in + if ir = 0 then m + else add x ir m) m1 empty in + (mr,n) + + + let variables m = fold (fun v i acc -> ISet.add v acc) m ISet.empty + + let fold = fold end +module MonMap = + struct + include Map.Make(Monomial) + + let union f = merge + (fun x v1 v2 -> + match v1 , v2 with + | None , None -> None + | Some v , None | None , Some v -> Some v + | Some v1 , Some v2 -> f x v1 v2) + end + +let pp_mon o (m, i) = + if Monomial.is_const m + then if eq_num (Int 0) i then () + else Printf.fprintf o "%s" (string_of_num i) + else + match i with + | Int 1 -> Monomial.pp o m + | Int -1 -> Printf.fprintf o "-%a" Monomial.pp m + | Int 0 -> () + | _ -> Printf.fprintf o "%s*%a" (string_of_num i) Monomial.pp m + + + module Poly : - (* A polynomial is a map of monomials *) - (* - This is probably a naive implementation +(* A polynomial is a map of monomials *) +(* + This is probably a naive implementation (expected to be fast enough - Coq is probably the bottleneck) *The new ring contribution is using a sparse Horner representation. - *) + *) sig - type t - val get : Monomial.t -> t -> num - val variable : var -> t - val add : Monomial.t -> num -> t -> t - val constant : num -> t - val product : t -> t -> t - val addition : t -> t -> t - val uminus : t -> t - val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a - val is_linear : t -> bool -end = -struct - (*normalisation bug : 0*x ... *) - module P = Map.Make(Monomial) - open P - - type t = num P.t - - (* Get the coefficient of monomial mn *) - let get : Monomial.t -> t -> num = - fun mn p -> try find mn p with Not_found -> (Int 0) - - - (* The polynomial 1.x *) - let variable : var -> t = - fun x -> add (Monomial.var x) (Int 1) empty - - (*The constant polynomial *) - let constant : num -> t = - fun c -> add (Monomial.const) c empty - - (* The addition of a monomial *) - - let add : Monomial.t -> num -> t -> t = - fun mn v p -> + type t + val pp : out_channel -> t -> unit + val get : Monomial.t -> t -> num + val variable : var -> t + val add : Monomial.t -> num -> t -> t + val constant : num -> t + val product : t -> t -> t + val addition : t -> t -> t + val uminus : t -> t + val fold : (Monomial.t -> num -> 'a -> 'a) -> t -> 'a -> 'a + val factorise : var -> t -> t * t +end = struct + (*normalisation bug : 0*x ... *) + module P = Map.Make(Monomial) + open P + + type t = num P.t + + + let pp o p = P.iter (fun mn i -> Printf.fprintf o "%a + " pp_mon (mn, i)) p + + + (* Get the coefficient of monomial mn *) + let get : Monomial.t -> t -> num = + fun mn p -> try find mn p with Not_found -> (Int 0) + + + (* The polynomial 1.x *) + let variable : var -> t = + fun x -> add (Monomial.var x) (Int 1) empty + + (*The constant polynomial *) + let constant : num -> t = + fun c -> add (Monomial.const) c empty + + (* The addition of a monomial *) + + let add : Monomial.t -> num -> t -> t = + fun mn v p -> if sign_num v = 0 then p else let vl = (get mn p) <+> v in - if sign_num vl = 0 then - remove mn p - else add mn vl p + if sign_num vl = 0 then + remove mn p + else add mn vl p - (** Design choice: empty is not a polynomial - I do not remember why .... - **) + (** Design choice: empty is not a polynomial + I do not remember why .... + **) - (* The product by a monomial *) - let mult : Monomial.t -> num -> t -> t = - fun mn v p -> - if sign_num v = 0 + (* The product by a monomial *) + let mult : Monomial.t -> num -> t -> t = + fun mn v p -> + if sign_num v = 0 then constant (Int 0) else fold (fun mn' v' res -> P.add (Monomial.prod mn mn') (v<*>v') res) p empty - let addition : t -> t -> t = - fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 - + let addition : t -> t -> t = + fun p1 p2 -> fold (fun mn v p -> add mn v p) p1 p2 + - let product : t -> t -> t = - fun p1 p2 -> - fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty + let product : t -> t -> t = + fun p1 p2 -> + fold (fun mn v res -> addition (mult mn v p2) res ) p1 empty - let uminus : t -> t = - fun p -> map (fun v -> minus_num v) p + let uminus : t -> t = + fun p -> map (fun v -> minus_num v) p - let fold = P.fold + let fold = P.fold - let is_linear p = P.fold (fun m _ acc -> acc && (Monomial.is_const m || Monomial.is_var m)) p true + let factorise x p = + let x = Monomial.var x in + P.fold (fun m v (px,cx) -> + let (m1,i) = Monomial.div m x in + if i = 0 + then (px, add m v cx) + else + let mx = Monomial.prod m1 (Monomial.exp x (i-1)) in + (add mx v px,cx) ) p (constant (Int 0) , constant (Int 0)) -(* let is_linear p = - let res = is_linear p in - Printf.printf "is_linear %a = %b\n" pp p res ; res -*) end -module Vect = - struct - (** [t] is the type of vectors. - A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - - variables indexes are ordered (x1 <c ... < xn - - values are all non-zero - *) - type var = int - type t = (var * num) list - -(** [equal v1 v2 = true] if the vectors are syntactically equal. *) - - let rec equal v1 v2 = - match v1 , v2 with - | [] , [] -> true - | [] , _ -> false - | _::_ , [] -> false - | (i1,n1)::v1 , (i2,n2)::v2 -> - (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 - - let hash v = - let rec hash i = function - | [] -> i - | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in - Hashtbl.hash (hash 0 v ) - - - let null = [] - - let pp_vect o vect = - List.iter (fun (v,n) -> Printf.printf "%sx%i + " (string_of_num n) v) vect - - let from_list (l: num list) = - let rec xfrom_list i l = - match l with - | [] -> [] - | e::l -> - if e <>/ Int 0 - then (i,e)::(xfrom_list (i+1) l) - else xfrom_list (i+1) l in - - xfrom_list 0 l - - let zero_num = Int 0 - - - let to_list m = - let rec xto_list i l = - match l with - | [] -> [] - | (x,v)::l' -> - if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in - xto_list 0 m - - - let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst - - let rec update i f t = - match t with - | [] -> cons i (f zero_num) [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k (f v) l - | -1 -> cons i (f zero_num) t - | 1 -> (k,v) ::(update i f l) - | _ -> failwith "compare_num" - - let rec set i n t = - match t with - | [] -> cons i n [] - | (k,v)::l -> - match Int.compare i k with - | 0 -> cons k n l - | -1 -> cons i n t - | 1 -> (k,v) :: (set i n l) - | _ -> failwith "compare_num" - - let mul z t = - match z with - | Int 0 -> [] - | Int 1 -> t - | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t - - - let rec add v1 v2 = - match v1 , v2 with - | (x1,n1)::v1' , (x2,n2)::v2' -> - if x1 = x2 - then - let n' = n1 +/ n2 in - if n' =/ Int 0 then add v1' v2' - else - let res = add v1' v2' in - (x1,n') ::res - else if x1 < x2 - then let res = add v1' v2 in - (x1, n1)::res - else let res = add v1 v2' in - (x2, n2)::res - | [] , [] -> [] - | [] , _ -> v2 - | _ , [] -> v1 - - - - - let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical - [ - (fun () -> Int.compare (fst x) (fst y)); - (fun () -> compare_num (snd x) (snd y))]) - - (** [tail v vect] returns - - [None] if [v] is not a variable of the vector [vect] - - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] - and [rst] is the remaining of the vector - We exploit that vectors are ordered lists - *) - let rec tail (v:var) (vect:t) = - match vect with - | [] -> None - | (v',vl)::vect' -> - match Int.compare v' v with - | 0 -> Some (vl,vect) (* Ok, found *) - | -1 -> tail v vect' (* Might be in the tail *) - | _ -> None (* Hopeless *) - - let get v vect = - match tail v vect with - | None -> None - | Some(vl,_) -> Some vl - - - let rec fresh v = - match v with - | [] -> 1 - | [v,_] -> v + 1 - | _::v -> fresh v - - end type vector = Vect.t -type cstr_compat = {coeffs : vector ; op : op ; cst : num} -and op = |Eq | Ge +type cstr = {coeffs : vector ; op : op ; cst : num} +and op = |Eq | Ge | Gt -let string_of_op = function Eq -> "=" | Ge -> ">=" +exception Strict -let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" Vect.pp_vect coeffs (string_of_op op) (string_of_num cst) +let is_strict c = Pervasives.(=) c.op Gt -let opMult o1 o2 = - match o1, o2 with - | Eq , Eq -> Eq - | Eq , Ge | Ge , Eq -> Ge - | Ge , Ge -> Ge - -open Big_int - -type prf_rule = - | Hyp of int - | Def of int - | Cst of big_int - | Zero - | Square of (Vect.t * num) - | MulC of (Vect.t * num) * prf_rule - | Gcd of big_int * prf_rule - | MulPrf of prf_rule * prf_rule - | AddPrf of prf_rule * prf_rule - | CutPrf of prf_rule - -type proof = - | Done - | Step of int * prf_rule * proof - | Enum of int * prf_rule * Vect.t * prf_rule * proof list - - -let rec output_prf_rule o = function - | Hyp i -> Printf.fprintf o "Hyp %i" i - | Def i -> Printf.fprintf o "Def %i" i - | Cst c -> Printf.fprintf o "Cst %s" (string_of_big_int c) - | Zero -> Printf.fprintf o "Zero" - | Square _ -> Printf.fprintf o "( )^2" - | MulC(p,pr) -> Printf.fprintf o "P * %a" 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) - -let rec output_proof o = function - | Done -> Printf.fprintf o "." - | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf - | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i - output_prf_rule p1 Vect.pp_vect v output_prf_rule p2 - (pp_list output_proof) pl - -let rec pr_rule_max_id = function - | Hyp i | Def i -> i - | Cst _ | Zero | Square _ -> -1 - | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p - | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) - -let rec proof_max_id = function - | Done -> -1 - | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) - | Enum(i,p1,_,p2,l) -> - let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in - List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l - -let rec pr_rule_def_cut id = function - | MulC(p,prf) -> - let (bds,id',prf') = pr_rule_def_cut id prf in - (bds, id', MulC(p,prf')) - | MulPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,MulPrf(p1,p2)) - | AddPrf(p1,p2) -> - let (bds1,id,p1) = pr_rule_def_cut id p1 in - let (bds2,id,p2) = pr_rule_def_cut id p2 in - (bds2@bds1,id,AddPrf(p1,p2)) - | CutPrf p -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Gcd(c,p) -> - let (bds,id,p) = pr_rule_def_cut id p in - ((id,p)::bds,id+1,Def id) - | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) - - -(* Do not define top-level cuts *) -let pr_rule_def_cut id = function - | CutPrf p -> - let (bds,ids,p') = pr_rule_def_cut id p in - bds,ids, CutPrf p' - | p -> pr_rule_def_cut id p - - -let rec implicit_cut p = - match p with - | CutPrf p -> implicit_cut p - | _ -> p - - -let rec normalise_proof id prf = - match prf with - | Done -> (id,Done) - | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) - | Step(i,p,prf) -> - let bds,id,p' = pr_rule_def_cut id p in - let (id,prf) = normalise_proof id prf in - let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Step(i,p',prf)) bds in - - (id,prf) - | Enum(i,p1,v,p2,pl) -> - (* Why do I have top-level cuts ? *) -(* let p1 = implicit_cut p1 in - let p2 = implicit_cut p2 in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - Enum(i,p1,v,p2,prfs)) -*) +let eval_op = function + | Eq -> (=/) + | Ge -> (>=/) + | Gt -> (>/) - let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in - let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in - (List.fold_left max 0 ids , - List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) - (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) +let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" -let normalise_proof id prf = - let res = normalise_proof id prf in - if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; - res +let output_cstr o { coeffs ; op ; cst } = + Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (string_of_num cst) +let opMult o1 o2 = + match o1, o2 with + | Eq , _ | _ , Eq -> Eq + | Ge , _ | _ , Ge -> Ge + | Gt , Gt -> Gt -let add_proof x y = - match x, y with - | Zero , p | p , Zero -> p - | _ -> AddPrf(x,y) +let opAdd o1 o2 = + match o1, o2 with + | Eq , x | x , Eq -> x + | Gt , x | x , Gt -> Gt + | Ge , Ge -> Ge -let mul_proof c p = - match sign_big_int c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> MulC(([],Big_int c),p) (* [p] should represent an equality *) - | 1 -> - if eq_big_int c unit_big_int - then p - else MulPrf(Cst c,p) - | _ -> assert false -let mul_proof_ext (p,c) prf = - match p with - | [] -> mul_proof (numerator c) prf - | _ -> MulC((p,c),prf) - +module LinPoly = struct + (** A linear polynomial a0 + a1.x1 + ... + an.xn + By convention, the constant a0 is the coefficient of the variable 0. + *) -module LinPoly = -struct - type t = Vect.t * num + type t = Vect.t - module MonT = - struct + module MonT = struct module MonoMap = Map.Make(Monomial) module IntMap = Map.Make(Int) - + (** A hash table might be preferable but requires a hash function. *) let (index_of_monomial : int MonoMap.t ref) = ref (MonoMap.empty) let (monomial_of_index : Monomial.t IntMap.t ref) = ref (IntMap.empty) let fresh = ref 0 - let clear () = + let clear () = index_of_monomial := MonoMap.empty; - monomial_of_index := IntMap.empty ; + monomial_of_index := IntMap.empty ; fresh := 0 - let register m = + let register m = try - MonoMap.find m !index_of_monomial - with Not_found -> - begin - let res = !fresh in - index_of_monomial := MonoMap.add m res !index_of_monomial ; - monomial_of_index := IntMap.add res m !monomial_of_index ; - incr fresh ; res - end + MonoMap.find m !index_of_monomial + with Not_found -> + begin + let res = !fresh in + index_of_monomial := MonoMap.add m res !index_of_monomial ; + monomial_of_index := IntMap.add res m !monomial_of_index ; + incr fresh ; res + end let retrieve i = IntMap.find i !monomial_of_index + let _ = register Monomial.const - end + end - let normalise (v,c) = - (List.sort (fun x y -> Int.compare (fst x) (fst y)) v , c) + let var v = Vect.set (MonT.register (Monomial.var v)) (Int 1) Vect.null + let of_monomial m = + let v = MonT.register m in + Vect.set v (Int 1) Vect.null - let output_mon o (x,v) = - Printf.fprintf o "%s.%a +" (string_of_num v) Monomial.pp (MonT.retrieve x) + let linpol_of_pol p = + Poly.fold + (fun mon num vct -> + let vr = MonT.register mon in + Vect.set vr num vct) p Vect.null + let pol_of_linpol v = + Vect.fold (fun p vr n -> Poly.add (MonT.retrieve vr) n p) (Poly.constant (Int 0)) v + let coq_poly_of_linpol cst p = - let output_cstr o {coeffs = coeffs ; op = op ; cst = cst} = - Printf.fprintf o "%a %s %s" (pp_list output_mon) coeffs (string_of_op op) (string_of_num cst) + let pol_of_mon m = + Monomial.fold (fun x v p -> Mc.PEmul(Mc.PEpow(Mc.PEX(CamlToCoq.positive x),CamlToCoq.n v),p)) m (Mc.PEc (cst (Int 1))) in + Vect.fold (fun acc x v -> + let mn = MonT.retrieve x in + Mc.PEadd(Mc.PEmul(Mc.PEc (cst v), pol_of_mon mn),acc)) (Mc.PEc (cst (Int 0))) p + let pp_var o vr = + try + Monomial.pp o (MonT.retrieve vr) (* this is a non-linear variable *) + with Not_found -> Printf.fprintf o "v%i" vr - let linpol_of_pol p = - let (v,c) = - Poly.fold - (fun mon num (vct,cst) -> - if Monomial.is_const mon then (vct,num) - else - let vr = MonT.register mon in - ((vr,num)::vct,cst)) p ([], Int 0) in - normalise (v,c) - let mult v m (vect,c) = - if Monomial.is_const m - then - (Vect.mul v vect, v <*> c) - else - if sign_num v <> 0 - then - let hd = - if sign_num c <> 0 - then [MonT.register m,v <*> c] - else [] in - - let vect = hd @ (List.map (fun (x,n) -> - let x = MonT.retrieve x in - let x_m = MonT.register (Monomial.prod m x) in - (x_m, v <*> n)) vect ) in - normalise (vect , Int 0) - else ([],Int 0) + let pp o p = Vect.pp_gen pp_var o p + + let constant c = + if sign_num c = 0 + then Vect.null + else Vect.set 0 c Vect.null - let mult v m (vect,c) = - let (vect',c') = mult v m (vect,c) in - if debug then - Printf.printf "mult %s %a (%a,%s) -> (%a,%s)\n" (string_of_num v) Monomial.pp m - (pp_list output_mon) vect (string_of_num c) - (pp_list output_mon) vect' (string_of_num c') ; - (vect',c') + let is_linear p = + Vect.for_all (fun v _ -> + let mn = (MonT.retrieve v) in + Monomial.is_var mn || Monomial.is_const mn) p - let make_lin_pol v mon = - if Monomial.is_const mon - then [] , v - else [MonT.register mon, v],Int 0 + let factorise x p = + let (px,cx) = Poly.factorise x (pol_of_linpol p) in + (linpol_of_pol px, linpol_of_pol cx) - + let is_linear_for x p = + 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 xpivot_eq (c,prf) x v (c',prf') = - if debug then Printf.printf "xpivot_eq {%a} %a %s {%a}\n" - output_cstr c - Monomial.pp (MonT.retrieve x) - (string_of_num v) output_cstr c' ; + let search_all_linear p l = + Vect.fold (fun acc x v -> + if p v + then + let x' = MonT.retrieve x in + match Monomial.get_var x' with + | None -> acc + | Some x -> + if is_linear_for x l + then x::acc + else acc + else acc) [] l - let {coeffs = coeffs ; op = op ; cst = cst} = c' in - let m = MonT.retrieve x in - let apply_pivot (vqn,q,n) (c',prf') = - (* Morally, we have (Vect.get (q*x^n) c'.coeffs) = vmn with n >=0 *) + let product p1 p2 = + linpol_of_pol (Poly.product (pol_of_linpol p1) (pol_of_linpol p2)) - let cc' = abs_num v in - let cc_num = Int (- (sign_num v)) <*> vqn in - let cc_mon = Monomial.prod q (Monomial.exp m (n-1)) in + let addition p1 p2 = Vect.add p1 p2 - let (c_coeff,c_cst) = mult cc_num cc_mon (c.coeffs, minus_num c.cst) in - - let c' = {coeffs = Vect.add (Vect.mul cc' c'.coeffs) c_coeff ; op = op ; cst = (minus_num c_cst) <+> (cc' <*> c'.cst)} in - let prf' = add_proof - (mul_proof_ext (make_lin_pol cc_num cc_mon) prf) - (mul_proof (numerator cc') prf') in + let variables p = Vect.fold + (fun acc v _ -> + ISet.union (Monomial.variables (MonT.retrieve v)) acc) ISet.empty p - if debug then Printf.printf "apply_pivot -> {%a}\n" output_cstr c' ; - (c',prf') in + let pp_goal typ o l = + let vars = List.fold_left (fun acc p -> ISet.union acc (variables (fst p))) ISet.empty l in + let pp_vars o i = ISet.iter (fun v -> Printf.fprintf o "(x%i : %s) " v typ) vars in - let cmp (q,n) (q',n') = - if n < n' then -1 - else if n = n' then Monomial.compare q q' - else 1 in + Printf.fprintf o "forall %a\n" pp_vars vars ; + List.iteri (fun i (p,op) -> Printf.fprintf o "(H%i : %a %s 0)\n" i pp p (string_of_op op)) l; + Printf.fprintf o ", False\n" - - let find_pivot (c',prf') = - let (v,q,n) = List.fold_left - (fun (v,q,n) (x,v') -> - let x = MonT.retrieve x in - let (q',n') = Monomial.div x m in - if cmp (q,n) (q',n') = -1 then (v',q',n') else (v,q,n)) (Int 0, Monomial.const,0) c'.coeffs in - if n > 0 then Some (v,q,n) else None in - let rec pivot (q,n) (c',prf') = - match find_pivot (c',prf') with - | None -> (c',prf') - | Some(v,q',n') -> - if cmp (q',n') (q,n) = -1 - then pivot (q',n') (apply_pivot (v,q',n') (c',prf')) - else (c',prf') in - pivot (Monomial.const,max_int) (c',prf') - let pivot_eq x (c,prf) = - match Vect.get x c.coeffs with - | None -> (fun x -> None) - | Some v -> fun cp' -> Some (xpivot_eq (c,prf) x v cp') + let collect_square p = + Vect.fold (fun acc v _ -> + let m = (MonT.retrieve v) in + match Monomial.sqrt m with + | None -> acc + | Some s -> MonMap.add s m acc + ) MonMap.empty p end + +module ProofFormat = struct + open Big_int + + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule + + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list + + + let rec output_prf_rule o = function + | Annot(s,p) -> Printf.fprintf o "(%a)@%s" output_prf_rule p s + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | 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 + | 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) + + let rec output_proof o = function + | Done -> Printf.fprintf o "." + | Step(i,p,pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Enum(i,p1,v,p2,pl) -> Printf.fprintf o "%i{%a<=%a<=%a}%a" i + output_prf_rule p1 Vect.pp v output_prf_rule p2 + (pp_list ";" output_proof) pl + + let rec pr_rule_max_id = function + | Annot(_,p) -> pr_rule_max_id p + | Hyp i | Def i -> i + | Cst _ | Zero | Square _ -> -1 + | MulC(_,p) | CutPrf p | Gcd(_,p) -> pr_rule_max_id p + | MulPrf(p1,p2)| AddPrf(p1,p2) -> max (pr_rule_max_id p1) (pr_rule_max_id p2) + + let rec proof_max_id = function + | Done -> -1 + | Step(i,pr,prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Enum(i,p1,_,p2,l) -> + let m = max (pr_rule_max_id p1) (pr_rule_max_id p2) in + List.fold_left (fun i prf -> max i (proof_max_id prf)) (max i m) l + + + let rec pr_rule_def_cut id = function + | Annot(_,p) -> pr_rule_def_cut id p + | MulC(p,prf) -> + let (bds,id',prf') = pr_rule_def_cut id prf in + (bds, id', MulC(p,prf')) + | MulPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,MulPrf(p1,p2)) + | AddPrf(p1,p2) -> + let (bds1,id,p1) = pr_rule_def_cut id p1 in + let (bds2,id,p2) = pr_rule_def_cut id p2 in + (bds2@bds1,id,AddPrf(p1,p2)) + | CutPrf p -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Gcd(c,p) -> + let (bds,id,p) = pr_rule_def_cut id p in + ((id,p)::bds,id+1,Def id) + | Square _|Cst _|Def _|Hyp _|Zero as x -> ([],id,x) + + + (* Do not define top-level cuts *) + let pr_rule_def_cut id = function + | CutPrf p -> + let (bds,ids,p') = pr_rule_def_cut id p in + bds,ids, CutPrf p' + | p -> pr_rule_def_cut id p + + + let rec implicit_cut p = + match p with + | CutPrf p -> implicit_cut p + | _ -> p + + + let rec pr_rule_collect_hyps pr = + match pr with + | Annot(_,pr) -> pr_rule_collect_hyps pr + | Hyp i | Def i -> ISet.add i ISet.empty + | Cst _ | Zero | Square _ -> ISet.empty + | MulC(_,pr) | Gcd(_,pr)| CutPrf pr -> pr_rule_collect_hyps pr + | MulPrf(p1,p2) | AddPrf(p1,p2) -> ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + + let simplify_proof p = + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step(i,pr,Done) -> (p, ISet.add i (pr_rule_collect_hyps pr)) + | Step(i,pr,prf) -> + let (prf',hyps) = simplify_proof prf in + if not (ISet.mem i hyps) + then (prf',hyps) + else + (Step(i,pr,prf'), ISet.add i (ISet.union (pr_rule_collect_hyps pr) hyps)) + | Enum(i,p1,v,p2,pl) -> + let (pl,hl) = List.split (List.map simplify_proof pl) in + let hyps = List.fold_left ISet.union ISet.empty hl in + (Enum(i,p1,v,p2,pl),ISet.add i (ISet.union (ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2)) hyps)) in + fst (simplify_proof p) + + + let rec normalise_proof id prf = + match prf with + | Done -> (id,Done) + | Step(i,Gcd(c,p),Done) -> normalise_proof id (Step(i,p,Done)) + | Step(i,p,prf) -> + let bds,id,p' = pr_rule_def_cut id p in + let (id,prf) = normalise_proof id prf in + let prf = List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Step(i,p',prf)) bds in + + (id,prf) + | Enum(i,p1,v,p2,pl) -> + (* Why do I have top-level cuts ? *) + (* let p1 = implicit_cut p1 in + let p2 = implicit_cut p2 in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + Enum(i,p1,v,p2,prfs)) + *) + + let bds1,id,p1' = pr_rule_def_cut id (implicit_cut p1) in + let bds2,id,p2' = pr_rule_def_cut id (implicit_cut p2) in + let (ids,prfs) = List.split (List.map (normalise_proof id) pl) in + (List.fold_left max 0 ids , + List.fold_left (fun acc (i,p) -> Step(i, CutPrf p,acc)) + (Enum(i,p1',v,p2',prfs)) (bds2@bds1)) + + + let normalise_proof id prf = + let prf = simplify_proof prf in + let res = normalise_proof id prf in + if debug then Printf.printf "normalise_proof %a -> %a" output_proof prf output_proof (snd res) ; + res + + + + let add_proof x y = + match x, y with + | Zero , p | p , Zero -> p + | _ -> 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 mul_proof p1 p2 = + match p1 , p2 with + | Zero , _ | _ , Zero -> Zero + | Cst (Int 1) , p | p , Cst (Int 1) -> p + | _ , _ -> MulPrf(p1,p2) + + + let proof_of_farkas env vect = + Vect.fold (fun prf x n -> + add_proof (mul_cst_proof n (IMap.find x env)) prf) Zero vect + + + + module Env = struct + + let rec string_of_int_list l = + match l with + | [] -> "" + | i::l -> Printf.sprintf "%i,%s" i (string_of_int_list l) + + + let id_of_hyp hyp l = + let rec xid_of_hyp i l' = + match l' with + | [] -> failwith (Printf.sprintf "id_of_hyp %i %s" hyp (string_of_int_list l)) + | hyp'::l' -> if Pervasives.(=) hyp hyp' then i else xid_of_hyp (i+1) l' in + xid_of_hyp 0 l + + end + + let cmpl_prf_rule norm (cst:num-> 'a) env prf = + let rec cmpl = + function + | Annot(s,p) -> cmpl p + | Hyp i | Def i -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp i env)) + | Cst i -> Mc.PsatzC (cst i) + | Zero -> Mc.PsatzZ + | MulPrf(p1,p2) -> Mc.PsatzMulE(cmpl p1, cmpl p2) + | AddPrf(p1,p2) -> Mc.PsatzAdd(cmpl p1 , cmpl p2) + | MulC(lp,p) -> let lp = norm (LinPoly.coq_poly_of_linpol cst lp) in + Mc.PsatzMulC(lp,cmpl p) + | Square lp -> Mc.PsatzSquare (norm (LinPoly.coq_poly_of_linpol cst lp)) + | _ -> failwith "Cuts should already be compiled" in + cmpl prf + + + + + let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (numerator x)) env r + + let rec cmpl_proof env = function + | Done -> Mc.DoneProof + | Step(i,p,prf) -> + begin + match p with + | CutPrf p' -> + Mc.CutProof(cmpl_prf_rule_z env p', cmpl_proof (i::env) prf) + | _ -> Mc.RatProof(cmpl_prf_rule_z env p,cmpl_proof (i::env) prf) + end + | Enum(i,p1,_,p2,l) -> + Mc.EnumProof(cmpl_prf_rule_z env p1,cmpl_prf_rule_z env p2,List.map (cmpl_proof (i::env)) l) + + + let compile_proof env prf = + let id = 1 + proof_max_id prf in + let _,prf = normalise_proof id prf in + cmpl_proof env prf + + let rec eval_prf_rule env = function + | Annot(s,p) -> eval_prf_rule env p + | Hyp i | Def i -> env i + | Cst n -> (Vect.set 0 n Vect.null, + match Num.compare_num n (Int 0) with + | 0 -> Ge + | 1 -> Gt + | _ -> failwith "eval_prf_rule : negative constant" + ) + | Zero -> (Vect.null, Ge) + | Square v -> (LinPoly.product v v,Ge) + | MulC(v, p) -> + let (p1,o) = eval_prf_rule env p in + begin match o with + | Eq -> (LinPoly.product v p1,Eq) + | _ -> + Printf.fprintf stdout "MulC(%a,%a) invalid 2d arg %a %s" Vect.pp v output_prf_rule p Vect.pp p1 (string_of_op o); + failwith "eval_prf_rule : not an equality" + end + | Gcd(g,p) -> let (v,op) = eval_prf_rule env p in + (Vect.div (Big_int g) v, op) + | MulPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.product v1 v2, opMult o1 o2) + | AddPrf(p1,p2) -> + let (v1,o1) = eval_prf_rule env p1 in + let (v2,o2) = eval_prf_rule env p2 in + (LinPoly.addition v1 v2, opAdd o1 o2) + | CutPrf p -> eval_prf_rule env p + + + let is_unsat (p,o) = + let (c,r) = Vect.decomp_cst p in + if Vect.is_null r + then not (eval_op o c (Int 0)) + else false + + let rec eval_proof env p = + match p with + | Done -> failwith "Proof is not finished" + | Step(i, prf, rst) -> + let (p,o) = eval_prf_rule (fun i -> IMap.find i env) prf in + if is_unsat (p,o) then true + else + if Pervasives.(=) rst Done + then + begin + Printf.fprintf stdout "Last inference %a %s\n" LinPoly.pp p (string_of_op o); + false + end + else eval_proof (IMap.add i (p,o) env) rst + | Enum(i,r1,v,r2,l) -> let _ = eval_prf_rule (fun i -> IMap.find i env) r1 in + let _ = eval_prf_rule (fun i -> IMap.find i env) r2 in + (* Should check bounds *) + failwith "Not implemented" + +end + +module WithProof = struct + + type t = ((LinPoly.t * op) * ProofFormat.prf_rule) + + let annot s (p,prf) = (p, ProofFormat.Annot(s,prf)) + + 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 + + exception InvalidProof + + let zero = ((Vect.null,Eq), ProofFormat.Zero) + + + let of_cstr (c,prf) = + (Vect.set 0 (Num.minus_num (c.cst)) c.coeffs,c.op), prf + + let product : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((LinPoly.product p1 p2 , opMult o1 o2), ProofFormat.mul_proof prf1 prf2) + + let addition : t -> t -> t = fun ((p1,o1),prf1) ((p2,o2),prf2) -> + ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + + let mult p ((p1,o1),prf1) = + match o1 with + | Eq -> ((LinPoly.product p p1,o1), ProofFormat.MulC(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) + else raise InvalidProof + + + let cutting_plane ((p,o),prf) = + let (c,p') = Vect.decomp_cst p in + let g = (Vect.gcd p') in + if (Big_int.eq_big_int Big_int.unit_big_int g) || c =/ Int 0 || + not (Big_int.eq_big_int (denominator c) Big_int.unit_big_int) + then None (* Nothing to do *) + else + let c1 = c // (Big_int g) in + let c1' = Num.floor_num c1 in + if c1 =/ c1' + then None + else + match o with + | Eq -> Some ((Vect.set 0 (Int (-1)) Vect.null,Eq), ProofFormat.Gcd(g,prf)) + | Gt -> failwith "cutting_plane ignore strict constraints" + | Ge -> + (* This is a non-trivial common divisor *) + Some ((Vect.set 0 c1' (Vect.div (Big_int g) p),o),ProofFormat.Gcd(g, prf)) + + + let construct_sign p = + let (c,p') = Vect.decomp_cst p in + if Vect.is_null p' + then + Some (begin match sign_num c with + | 0 -> (true, Eq, ProofFormat.Zero) + | 1 -> (true,Gt, ProofFormat.Cst c) + | _ (*-1*) -> (false,Gt, ProofFormat.Cst (minus_num c)) + end) + else None + + + let get_sign l p = + match construct_sign p with + | None -> begin + try + let ((p',o),prf) = + List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (true,o,prf) + with Not_found -> + let p = Vect.uminus p in + try + let ((p',o),prf) = List.find (fun ((p',o),prf) -> Vect.equal p p') l in + Some (false,o,prf) + with Not_found -> None + end + | Some s -> Some s + + + let mult_sign : bool -> t -> t = fun b ((p,o),prf) -> + if b then ((p,o),prf) + else ((Vect.uminus p,o),prf) + + + let rec linear_pivot sys ((lp1,op1), prf1) x ((lp2,op2), prf2) = + + (* lp1 = a1.x + b1 *) + let (a1,b1) = LinPoly.factorise x lp1 in + + (* lp2 = a2.x + b2 *) + let (a2,b2) = LinPoly.factorise x lp2 in + + if Vect.is_null a2 + then (* We are done *) + Some ((lp2,op2),prf2) + else + match op1,op2 with + | Eq , (Ge|Gt) -> begin + match get_sign sys a1 with + | None -> None (* Impossible to pivot without sign information *) + | Some(b,o,prf) -> + let sa1 = mult_sign b ((a1,o),prf) in + let sa2 = if b then (Vect.uminus a2) else a2 in + + let ((lp2,op2),prf2) = + addition (product sa1 ((lp2,op2),prf2)) + (mult sa2 ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + end + | Eq , Eq -> + let ((lp2,op2),prf2) = addition (mult a1 ((lp2,op2),prf2)) + (mult (Vect.uminus a2) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + + | (Ge | Gt) , (Ge| Gt) -> begin + match get_sign sys a1 , get_sign sys a2 with + | Some(b1,o1,p1) , Some(b2,o2,p2) -> + if b1 <> b2 + then + let ((lp2,op2),prf2) = + addition (product (mult_sign b1 ((a1,o1), p1)) ((lp2,op2),prf2)) + (product (mult_sign b2 ((a2,o2), p2)) ((lp1,op1),prf1)) in + linear_pivot sys ((lp1,op1),prf1) x ((lp2,op2),prf2) + else None + | _ -> None + end + | (Ge|Gt) , Eq -> failwith "pivot: equality as second argument" + +end + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 4c095202ab..f5e9a9f34c 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -8,111 +8,317 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +open Mutils + +module Mc = Micromega + +val max_nb_cstr : int ref + type var = int module Monomial : sig - + (** A monomial is represented by a multiset of variables *) type t + + (** [fold f m acc] + folds over the variables with multiplicities *) val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a + + (** [const] + @return the empty monomial i.e. without any variable *) val const : t + + (** [var x] + @return the monomial x^1 *) + val var : var -> t + + (** [sqrt m] + @return [Some r] iff r^2 = m *) val sqrt : t -> t option + + (** [is_var m] + @return [true] iff m = x^1 for some variable x *) val is_var : t -> bool + + (** [div m1 m2] + @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) val div : t -> t -> t * int + (** [compare m1 m2] provides a total order over monomials*) val compare : t -> t -> int + (** [variables m] + @return the set of variables with (strictly) positive multiplicities *) + val variables : t -> ISet.t +end + +module MonMap : sig + include Map.S with type key = Monomial.t + + val union : (Monomial.t -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t end module Poly : sig + (** Representation of polonomial with rational coefficient. + a1.m1 + ... + c where + - ai are rational constants (num type) + - mi are monomials + - c is a rational constant + + *) type t + (** [constant c] + @return the constant polynomial c *) val constant : Num.num -> t + + (** [variable x] + @return the polynomial 1.x^1 *) val variable : var -> t + + (** [addition p1 p2] + @return the polynomial p1+p2 *) val addition : t -> t -> t + + (** [product p1 p2] + @return the polynomial p1*p2 *) val product : t -> t -> t + + (** [uminus p] + @return the polynomial -p i.e product by -1 *) val uminus : t -> t + + (** [get mi p] + @return the coefficient ai of the monomial mi. *) val get : Monomial.t -> t -> Num.num - val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a - val is_linear : t -> bool + (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) + val fold : (Monomial.t -> Num.num -> 'a -> 'a) -> t -> 'a -> 'a + + (** [add m n p] + @return the polynomial n*m + p *) val add : Monomial.t -> Num.num -> t -> t end -module Vect : sig +type cstr = {coeffs : Vect.t ; op : op ; cst : Num.num} (** Representation of linear constraints *) +and op = Eq | Ge | Gt - type var = int - type t = (var * Num.num) list - val hash : t -> int - val equal : t -> t -> bool - val compare : t -> t -> int - val pp_vect : 'a -> t -> unit +val eval_op : op -> Num.num -> Num.num -> bool + +(*val opMult : op -> op -> op*) + +val opAdd : op -> op -> op + +(** [is_strict c] + @return whether the constraint is strict i.e. c.op = Gt *) +val is_strict : cstr -> bool + +exception Strict + +module LinPoly : sig + (** Linear(ised) polynomials represented as a [Vect.t] + i.e a sorted association list. + The constant is the coefficient of the variable 0 + + Each linear polynomial can be interpreted as a multi-variate polynomial. + There is a bijection mapping between a linear variable and a monomial + (see module [MonT]) + *) + + type t = Vect.t + + (** Each variable of a linear polynomial is mapped to a monomial. + This is done using the monomial tables of the module MonT. *) + + module MonT : sig + (** [clear ()] clears the mapping. *) + val clear : unit -> unit + + (** [retrieve x] + @return the monomial corresponding to the variable [x] *) + val retrieve : int -> Monomial.t + + end + + (** [linpol_of_pol p] linearise the polynomial p *) + val linpol_of_pol : Poly.t -> t - val get : var -> t -> Num.num option - val set : var -> Num.num -> t -> t - val fresh : (int * 'a) list -> int - val update : Int.t -> (Num.num -> Num.num) -> - (Int.t * Num.num) list -> (Int.t * Num.num) list - val null : t + (** [var x] + @return 1.y where y is the variable index of the monomial x^1. + *) + val var : var -> t - val from_list : Num.num list -> t - val to_list : t -> Num.num list + (** [coq_poly_of_linpol c p] + @param p is a multi-variate polynomial. + @param c maps a rational to a Coq polynomial coefficient. + @return the coq expression corresponding to polynomial [p].*) + val coq_poly_of_linpol : (Num.num -> 'a) -> t -> 'a Mc.pExpr - val add : t -> t -> t - val mul : Num.num -> t -> t + (** [of_monomial m] + @returns 1.x where x is the variable (index) for monomial m *) + val of_monomial : Monomial.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_linear p] + @return whether the multi-variate polynomial is linear. *) + val is_linear : t -> bool + + (** [is_linear_for x p] + @return true if the polynomial is linear in x + i.e can be written c*x+r where c is a constant and r is independent from x *) + val is_linear_for : var -> t -> bool + + (** [constant c] + @return the constant polynomial c + *) + val constant : Num.num -> t + + (** [search_linear pred p] + @return a variable x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + + val search_linear : (Num.num -> bool) -> t -> var option + + (** [search_all_linear pred p] + @return all the variables x such p = a.x + b such that + p is linear in x i.e x does not occur in b and + a is a constant such that [pred a] *) + val search_all_linear : (Num.num -> bool) -> t -> var list + + (** [product p q] + @return the product of the polynomial [p*q] *) + val product : t -> t -> t + + (** [factorise x p] + @return [a,b] such that [p = a.x + b] + and [x] does not occur in [b] *) + val factorise : var -> t -> t * t + + (** [collect_square p] + @return a mapping m such that m[s] = s^2 + for every s^2 that is a monomial of [p] *) + val collect_square : t -> Monomial.t MonMap.t + + + (** [pp_var o v] pretty-prints a monomial indexed by v. *) + val pp_var : out_channel -> var -> unit + + (** [pp o p] pretty-prints a polynomial. *) + val pp : out_channel -> t -> unit + + (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) + val pp_goal : string -> out_channel -> (t * op) list -> unit end -type cstr_compat = {coeffs : Vect.t ; op : op ; cst : Num.num} -and op = Eq | Ge +module ProofFormat : sig + (** Proof format used by the proof-generating procedures. + It is fairly close to Coq format but a bit more liberal. -type prf_rule = - | Hyp of int - | Def of int - | Cst of Big_int.big_int - | Zero - | Square of (Vect.t * Num.num) - | MulC of (Vect.t * Num.num) * prf_rule - | Gcd of Big_int.big_int * prf_rule - | MulPrf of prf_rule * prf_rule - | AddPrf of prf_rule * prf_rule - | CutPrf of prf_rule + It is used for proofs over Z, Q, R. + However, certain constructions e.g. [CutPrf] are only relevant for Z. + *) -type proof = - | Done - | Step of int * prf_rule * proof - | Enum of int * prf_rule * Vect.t * prf_rule * proof list + type prf_rule = + | Annot of string * prf_rule + | Hyp of int + | Def of int + | Cst of Num.num + | Zero + | Square of Vect.t + | MulC of Vect.t * prf_rule + | Gcd of Big_int.big_int * prf_rule + | MulPrf of prf_rule * prf_rule + | AddPrf of prf_rule * prf_rule + | CutPrf of prf_rule -val proof_max_id : proof -> int + type proof = + | Done + | Step of int * prf_rule * proof + | Enum of int * prf_rule * Vect.t * prf_rule * proof list -val normalise_proof : int -> proof -> int * proof + val pr_rule_max_id : prf_rule -> int -val output_proof : out_channel -> proof -> unit + val proof_max_id : proof -> int -val add_proof : prf_rule -> prf_rule -> prf_rule -val mul_proof : Big_int.big_int -> prf_rule -> prf_rule + val normalise_proof : int -> proof -> int * proof -module LinPoly : sig + val output_prf_rule : out_channel -> prf_rule -> unit - type t = Vect.t * Num.num + val output_proof : out_channel -> proof -> unit - module MonT : sig + val add_proof : prf_rule -> prf_rule -> prf_rule - val clear : unit -> unit - val retrieve : int -> Monomial.t + val mul_cst_proof : Num.num -> prf_rule -> prf_rule - end + val mul_proof : prf_rule -> prf_rule -> prf_rule - val pivot_eq : Vect.var -> - cstr_compat * prf_rule -> - cstr_compat * prf_rule -> (cstr_compat * prf_rule) option + val compile_proof : int list -> proof -> Micromega.zArithProof - val linpol_of_pol : Poly.t -> t + val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> + (Num.num -> 'a) -> (int list) -> prf_rule -> 'a Micromega.psatz + + val proof_of_farkas : prf_rule IMap.t -> Vect.t -> prf_rule + + val eval_prf_rule : (int -> LinPoly.t * op) -> prf_rule -> LinPoly.t * op + + val eval_proof : (LinPoly.t * op) IMap.t -> proof -> bool end -val output_cstr : out_channel -> cstr_compat -> unit +val output_cstr : out_channel -> cstr -> unit val opMult : op -> op -> op + +(** [module WithProof] constructs polynomials packed with the proof that their sign is correct. *) +module WithProof : +sig + + type t = (LinPoly.t * op) * ProofFormat.prf_rule + + (** [InvalidProof] is raised if the operation is invalid. *) + exception InvalidProof + + val annot : string -> t -> t + + val of_cstr : cstr * ProofFormat.prf_rule -> t + + (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) + val output : out_channel -> t -> unit + + (** [zero] represents the tautology (0=0) *) + val zero : t + + (** [product p q] + @return the polynomial p*q with its sign and proof *) + val product : t -> t -> t + + (** [addition p q] + @return the polynomial p+q with its sign and proof *) + val addition : t -> t -> t + + (** [mult p q] + @return the polynomial p*q with its sign and proof. + @raise InvalidProof if p is not a constant and p is not an equality *) + val mult : LinPoly.t -> t -> t + + (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) + val cutting_plane : t -> t option + + (** [linear_pivot sys p x q] + @return the polynomial [q] where [x] is eliminated using the polynomial [p] + The pivoting operation is only defined if + - p is linear in x i.e p = a.x+b and x neither occurs in a and b + - The pivoting also requires some sign conditions for [a] + *) + val linear_pivot : t list -> t -> Vect.var -> t -> t option + +end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml new file mode 100644 index 0000000000..8d8c6ea90b --- /dev/null +++ b/plugins/micromega/simplex.ml @@ -0,0 +1,621 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** A naive simplex *) +open Polynomial +open Num +open Util +open Mutils + +let debug = false + +type iset = unit IMap.t + +type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. + All variables >= than a threshold rst are restricted.*) +module Restricted = + struct + type t = + { + base : int; (** All variables above [base] are restricted *) + exc : int option (** Except [exc] which is currently optimised *) + } + + let pp o {base;exc} = + Printf.fprintf o ">= %a " LinPoly.pp_var base; + match exc with + | None ->Printf.fprintf o "-" + | Some x ->Printf.fprintf o "-%a" LinPoly.pp_var base + + let is_exception (x:var) (r:t) = + match r.exc with + | None -> false + | Some x' -> x = x' + + let restrict x rst = + if is_exception x rst + then + {base = rst.base;exc= None} + else failwith (Printf.sprintf "Cannot restrict %i" x) + + + let is_restricted x r0 = + x >= r0.base && not (is_exception x r0) + + let make x = {base = x ; exc = None} + + let set_exc x rst = {base = rst.base ; exc = Some x} + + let fold rst f m acc = + IMap.fold (fun k v acc -> + if is_exception k rst then acc + else f k v acc) (IMap.from rst.base m) acc + + end + + + +let pp_row o v = LinPoly.pp o v + +let output_tableau o t = + IMap.iter (fun k v -> + Printf.fprintf o "%a = %a\n" LinPoly.pp_var k pp_row v) t + +let output_vars o m = + IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m + + +(** A tableau is feasible iff for every basic restricted variable xi, + we have ci>=0. + + When all the non-basic variables are set to 0, the value of a basic + variable xi is necessarily ci. If xi is restricted, it is feasible + if ci>=0. + *) + + +let unfeasible (rst:Restricted.t) tbl = + Restricted.fold rst (fun k v m -> + if Vect.get_cst v >=/ Int 0 then m + else IMap.add k () m) tbl IMap.empty + + +let is_feasible rst tb = IMap.is_empty (unfeasible rst tb) + +(** Let a1.x1+...+an.xn be a vector of non-basic variables. + It is maximised if all the xi are restricted + and the ai are negative. + + If xi>= 0 (restricted) and ai is negative, + the maximum for ai.xi is obtained for xi = 0 + + Otherwise, it is possible to make ai.xi arbitrarily big: + - if xi is not restricted, take +/- oo depending on the sign of ai + - if ai is positive, take +oo + *) + +let is_maximised_vect rst v = + Vect.for_all (fun xi ai -> + if ai >/ Int 0 + then false + else Restricted.is_restricted xi rst) v + + +(** [is_maximised rst v] + @return None if the variable is not maximised + @return Some v where v is the maximal value + *) +let is_maximised rst v = + try + let (vl,v) = Vect.decomp_cst v in + if is_maximised_vect rst v + then Some vl + else None + with Not_found -> None + +(** A variable xi is unbounded if for every + equation xj= ...ai.xi ... + if ai < 0 then xj is not restricted. + As a result, even if we + increase the value of xi, it is always + possible to adjust the value of xj without + 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 *) + | Ubnd of var (** Problem is unbounded *) + | Feas (** Problem is feasible *) + +type pivot = + | Done of result + | Pivot of int * int * num + + + + +type simplex = + | Opt of tableau * result + +(** For a row, x = ao.xo+...+ai.xi + a valid pivot variable is such that it can improve the value of xi. + it is the case, if xi is unrestricted (increase if ai> 0, decrease if ai < 0) + xi is restricted but ai > 0 + +This is the entering variable. + *) + +let rec find_pivot_column (rst:Restricted.t) (r:Vect.t) = + match Vect.choose r with + | None -> failwith "find_pivot_column" + | Some(xi,ai,r') -> if ai </ Int 0 + then if Restricted.is_restricted xi rst + then find_pivot_column rst r' (* ai.xi cannot be improved *) + else (xi, -1) (* r is not restricted, sign of ai does not matter *) + else (* ai is positive, xi can be increased *) + (xi,1) + +(** Finding the variable leaving the basis is more subtle because we need to: + - increase the objective function + - make sure that the entering variable has a feasible value + - but also that after pivoting all the other basic variables are still feasible. + This explains why we choose the pivot with the smallest score + *) + +let min_score s (i1,sc1) = + match s with + | None -> Some (i1,sc1) + | Some(i0,sc0) -> + if sc0 </ sc1 then s + else if sc1 </ sc0 then Some (i1,sc1) + else if i0 < i1 then s else Some(i1,sc1) + +let find_pivot_row rst tbl j sgn = + Restricted.fold rst + (fun i' v res -> + let aij = Vect.get j v in + if (Int sgn) */ aij </ Int 0 + then (* This would improve *) + let score' = Num.abs_num ((Vect.get_cst v) // aij) in + min_score res (i',score') + else res) tbl None + +let safe_find err x t = + try + IMap.find x t + with Not_found -> + if debug + then Printf.fprintf stdout "safe_find %s x%i %a\n" err x output_tableau t; + failwith err + + +(** [find_pivot vr t] aims at improving the objective function of the basic variable vr *) +let find_pivot vr (rst:Restricted.t) tbl = + (* Get the objective of the basic variable vr *) + let v = safe_find "find_pivot" vr tbl in + match is_maximised rst v with + | Some mx -> Done (Max mx) (* Maximum is reached; we are done *) + | None -> + (* Extract the vector *) + let (_,v) = Vect.decomp_cst v in + let (j',sgn) = find_pivot_column rst v in + match find_pivot_row rst (IMap.remove vr tbl) j' sgn with + | None -> Done (Ubnd j') + | Some (i',sc) -> Pivot(i', j', sc) + +(** [solve_column c r e] + @param c is a non-basic variable + @param r is a basic variable + @param e is a vector such that r = e + and e is of the form ai.c+e' + @return the vector (-r + e').-1/ai i.e + c = (r - e')/ai + *) + +let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = + let a = Vect.get c e in + if a =/ Int 0 + then failwith "Cannot solve column" + else + let a' = (Int (-1) // a) in + Vect.mul a' (Vect.set r (Int (-1)) (Vect.set c (Int 0) e)) + +(** [pivot_row r c e] + @param c is such that c = e + @param r is a vector r = g.c + r' + @return g.e+r' *) + +let pivot_row (row: Vect.t) (c : var) (e : Vect.t) : Vect.t = + let g = Vect.get c row in + if g =/ Int 0 + then row + else Vect.mul_add g e (Int 1) (Vect.set c (Int 0) row) + +let pivot_with (m : tableau) (v: var) (p : Vect.t) = + IMap.map (fun (r:Vect.t) -> pivot_row r v p) m + +let pivot (m : tableau) (r : var) (c : var) = + let row = safe_find "pivot" r m in + let piv = solve_column c r row in + IMap.add c piv (pivot_with (IMap.remove r m) c piv) + + +let adapt_unbounded vr x rst tbl = + if Vect.get_cst (IMap.find vr tbl) >=/ Int 0 + then tbl + else pivot tbl vr x + +module BaseSet = Set.Make(struct type t = iset let compare = IMap.compare (fun x y -> 0) end) + +let get_base tbl = IMap.mapi (fun k _ -> ()) tbl + +let simplex opt vr rst tbl = + let b = ref BaseSet.empty in + +let rec simplex opt vr rst tbl = + + if debug then begin + let base = get_base tbl in + if BaseSet.mem base !b + then Printf.fprintf stdout "Cycling detected\n" + else b := BaseSet.add base !b + end; + + if debug && not (is_feasible rst tbl) + then + begin + let m = unfeasible rst tbl in + Printf.fprintf stdout "Simplex error\n"; + Printf.fprintf stdout "The current tableau is not feasible\n"; + Printf.fprintf stdout "Restricted >= %a\n" Restricted.pp rst ; + output_tableau stdout tbl; + Printf.fprintf stdout "Error for variables %a\n" output_vars m + end; + + if not opt && (Vect.get_cst (IMap.find vr tbl) >=/ Int 0) + then Opt(tbl,Feas) + else + match find_pivot vr rst tbl with + | Done r -> + begin match r with + | Max _ -> Opt(tbl, r) + | Ubnd x -> + let t' = adapt_unbounded vr x rst tbl in + Opt(t',r) + | Feas -> raise (Invalid_argument "find_pivot") + end + | Pivot(i,j,s) -> + if debug then begin + Printf.fprintf stdout "Find pivot for x%i(%s)\n" vr (string_of_num s); + Printf.fprintf stdout "Leaving variable x%i\n" i; + Printf.fprintf stdout "Entering variable x%i\n" j; + end; + let m' = pivot tbl i j in + simplex opt vr rst m' in + +simplex opt vr rst tbl + + + +type certificate = + | Unsat of Vect.t + | Sat of tableau * var option + +(** [normalise_row t v] + @return a row obtained by pivoting the basic variables of the vector v + *) + +let normalise_row (t : tableau) (v: Vect.t) = + Vect.fold (fun acc vr ai -> try + let e = IMap.find vr t in + Vect.add (Vect.mul ai e) acc + with Not_found -> Vect.add (Vect.set vr ai Vect.null) acc) + Vect.null v + +let normalise_row (t : tableau) (v: Vect.t) = + let v' = normalise_row t v in + if debug then Printf.fprintf stdout "Normalised Optimising %a\n" LinPoly.pp v'; + v' + +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 + then begin Printf.fprintf stdout "Current Tableau\n%a\n" output_tableau t; + Printf.fprintf stdout "Optimising %a=%a\n" LinPoly.pp_var nw LinPoly.pp v + end; + match simplex opt nw rst (add_row nw t v) with + | Opt(t',r) -> (* Look at the optimal *) + match r with + | Ubnd x-> + if debug then Printf.printf "The objective is unbounded (variable %a)\n" LinPoly.pp_var x; + Sat (t',Some x) (* This is sat and we can extract a value *) + | Feas -> Sat (t',None) + | Max n -> + if debug then begin + Printf.printf "The objective is maximised %s\n" (string_of_num n); + Printf.printf "%a = %a\n" LinPoly.pp_var nw pp_row (IMap.find nw t') + end; + + if n >=/ Int 0 + then Sat (t',None) + else + let v' = safe_find "push_real" nw t' in + 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 + *) +open Mutils +open Polynomial + +let fresh_var l = + 1 + + try + (ISet.max_elt (List.fold_left (fun acc c -> ISet.union acc (Vect.variables c.coeffs)) ISet.empty l)) + with Not_found -> 0 + + +(*type varmap = (int * bool) IMap.t*) + + +let make_certificate vm l = + Vect.normalise (Vect.fold (fun acc x n -> + let (x',b) = IMap.find x vm in + Vect.set x' (if b then n else Num.minus_num n) acc) Vect.null l) + + + + + +let eliminate_equalities (vr0:var) (l:Polynomial.cstr list) = + let rec elim idx vr vm l acc = + match l with + | [] -> (vr,vm,acc) + | c::l -> match c.op with + | Ge -> let v = Vect.set 0 (minus_num c.cst) c.coeffs in + elim (idx+1) (vr+1) (IMap.add vr (idx,true) vm) l ((vr,v)::acc) + | Eq -> let v1 = Vect.set 0 (minus_num c.cst) c.coeffs in + let v2 = Vect.mul (Int (-1)) v1 in + let vm = IMap.add vr (idx,true) (IMap.add (vr+1) (idx,false) vm) in + elim (idx+1) (vr+2) vm l ((vr,v1)::(vr+1,v2)::acc) + | Gt -> raise Strict in + elim 0 vr0 IMap.empty l [] + +let find_solution rst tbl = + IMap.fold (fun vr v res -> if Restricted.is_restricted vr rst + then res + else Vect.set vr (Vect.get_cst v) res) tbl Vect.null + +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 solve opt l (rst:Restricted.t) (t:tableau) = + let sol = find_solution rst t in + match choose_conflict sol l with + | None -> Inl (rst,t,None) + | Some((vr,v),l) -> + match push_real opt vr v (Restricted.set_exc vr rst) t with + | Sat (t',x) -> + (* let t' = remove_redundant rst t' in*) + begin + match l with + | [] -> Inl(rst,t', x) + | _ -> solve opt l rst t' + end + | Unsat c -> Inr c + +let find_unsat_certificate (l : Polynomial.cstr list ) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate vm c) + | Inl _ -> None + + + +let find_point (l : Polynomial.cstr list) = + let vr = fresh_var l in + let (_,vm,l') = eliminate_equalities vr l in + + match solve false l' (Restricted.make vr) IMap.empty with + | Inl (rst,t,_) -> Some (find_solution rst t) + | _ -> None + + + +let optimise obj l = + let vr0 = fresh_var l in + let (_,vm,l') = eliminate_equalities (vr0+1) l in + + let bound pos res = + match res with + | Opt(_,Max n) -> Some (if pos then n else minus_num n) + | Opt(_,Ubnd _) -> None + | Opt(_,Feas) -> None + in + + match solve false l' (Restricted.make vr0) IMap.empty with + | Inl (rst,t,_) -> + Some (bound false + (simplex true vr0 rst (add_row vr0 t (Vect.uminus obj))), + bound true + (simplex true vr0 rst (add_row vr0 t obj))) + | _ -> None + + + +open Polynomial + +let env_of_list l = + List.fold_left (fun (i,m) l -> (i+1, IMap.add i l m)) (0,IMap.empty) l + + +open ProofFormat + +let make_farkas_certificate (env: WithProof.t IMap.t) vm v = + Vect.fold (fun acc x n -> + add_proof acc + begin + try + let (x',b) = IMap.find x vm in + (mul_cst_proof + (if b then n else (Num.minus_num n)) + (snd (IMap.find x' env))) + with Not_found -> (* This is an introduced hypothesis *) + (mul_cst_proof n (snd (IMap.find x env))) + end) Zero v + +let make_farkas_proof (env: WithProof.t IMap.t) vm v = + Vect.fold (fun wp x n -> + WithProof.addition wp begin + try + let (x', b) = IMap.find x vm in + let n = if b then n else Num.minus_num n in + WithProof.mult (Vect.cst n) (IMap.find x' env) + with Not_found -> + 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 nf = Num.floor_num n in + if nf =/ n + 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 integer_solver lp = + let (l,_) = List.split lp in + let vr0 = fresh_var l in + let (vr,vm,l') = eliminate_equalities vr0 l in + + let _,env = env_of_list (List.map WithProof.of_cstr lp) in + + let insert_row vr v rst tbl = + match push_real true vr v rst tbl with + | Sat (t',x) -> Inl (Restricted.restrict vr rst,t',x) + | Unsat c -> Inr c in + + let rec isolve env cr vr res = + match res with + | Inr c -> Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c),Done)) + | Inl (rst,tbl,x) -> + if debug then begin + 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; + end; + let sol = find_solution rst tbl in + + match find_cut env cr (*x*) sol vm rst tbl with + | None -> None + | Some(cr,((v,op),cut)) -> + if Pervasives.(=) op Eq + then (* This is a contradiction *) + Some(Step(vr,CutPrf cut, Done)) + else + let res = insert_row vr v (Restricted.set_exc vr rst) tbl in + let prf = isolve (IMap.add vr ((v,op),Def vr) env) (Some cr) (vr+1) res in + match prf with + | None -> None + | Some p -> Some (Step(vr,CutPrf cut,p)) in + + let res = solve true l' (Restricted.make vr0) IMap.empty in + isolve env None vr res + +let integer_solver lp = + match integer_solver lp with + | None -> None + | Some prf -> if debug + then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf ; + Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli new file mode 100644 index 0000000000..9f87e745eb --- /dev/null +++ b/plugins/micromega/simplex.mli @@ -0,0 +1,18 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) +open Polynomial + +val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option + +val find_point : cstr list -> Vect.t option + +val find_unsat_certificate : cstr list -> Vect.t option + +val integer_solver : (cstr * ProofFormat.prf_rule) list -> ProofFormat.proof option diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 42a41e176c..f2dfaa42a5 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -145,11 +145,6 @@ let diagonal (v:vector) = (* ------------------------------------------------------------------------- *) (* Monomials. *) (* ------------------------------------------------------------------------- *) - -let monomial_eval assig (m:monomial) = - foldl (fun a x k -> a */ power_num (apply assig x) (Int k)) - (Int 1) m;; - let monomial_1 = (undefined:monomial);; let monomial_var x = (x |=> 1 :monomial);; @@ -166,10 +161,6 @@ let monomial_variables m = dom m;; (* ------------------------------------------------------------------------- *) (* Polynomials. *) (* ------------------------------------------------------------------------- *) - -let eval assig (p:poly) = - foldl (fun a m c -> a +/ c */ monomial_eval assig m) (Int 0) p;; - let poly_0 = (undefined:poly);; let poly_isconst (p:poly) = foldl (fun a m c -> m = monomial_1 && a) true p;; @@ -289,17 +280,9 @@ let rec poly_of_term t = match t with | Const n -> poly_const n | Var x -> poly_var x | Opp t1 -> poly_neg (poly_of_term t1) -| Inv t1 -> - let p = poly_of_term t1 in - if poly_isconst p then poly_const(Int 1 // eval undefined p) - else failwith "poly_of_term: inverse of non-constant polyomial" | Add (l, r) -> poly_add (poly_of_term l) (poly_of_term r) | Sub (l, r) -> poly_sub (poly_of_term l) (poly_of_term r) | Mul (l, r) -> poly_mul (poly_of_term l) (poly_of_term r) -| Div (l, r) -> - let p = poly_of_term l and q = poly_of_term r in - if poly_isconst q then poly_cmul (Int 1 // eval undefined q) p - else failwith "poly_of_term: division by non-constant polynomial" | Pow (t, n) -> poly_pow (poly_of_term t) n;; diff --git a/plugins/micromega/sos_types.ml b/plugins/micromega/sos_types.ml index dde1e6c0b0..79d67b6ae9 100644 --- a/plugins/micromega/sos_types.ml +++ b/plugins/micromega/sos_types.ml @@ -11,19 +11,17 @@ (* The type of positivstellensatz -- used to communicate with sos *) open Num -type vname = string;; +type vname = string type term = | Zero | Const of Num.num | Var of vname -| Inv of term | Opp of term | Add of (term * term) | Sub of (term * term) | Mul of (term * term) -| Div of (term * term) -| Pow of (term * int);; +| Pow of (term * int) let rec output_term o t = @@ -31,12 +29,10 @@ let rec output_term o t = | Zero -> output_string o "0" | Const n -> output_string o (string_of_num n) | Var n -> Printf.fprintf o "v%s" n - | Inv t -> Printf.fprintf o "1/(%a)" output_term t | Opp t -> Printf.fprintf o "- (%a)" output_term t | Add(t1,t2) -> Printf.fprintf o "(%a)+(%a)" output_term t1 output_term t2 | Sub(t1,t2) -> Printf.fprintf o "(%a)-(%a)" output_term t1 output_term t2 | Mul(t1,t2) -> Printf.fprintf o "(%a)*(%a)" output_term t1 output_term t2 - | Div(t1,t2) -> Printf.fprintf o "(%a)/(%a)" output_term t1 output_term t2 | Pow(t1,i) -> Printf.fprintf o "(%a)^(%i)" output_term t1 i (* ------------------------------------------------------------------------- *) (* Data structure for Positivstellensatz refutations. *) diff --git a/plugins/micromega/sos_types.mli b/plugins/micromega/sos_types.mli index 050ff1e4f7..aa5fb08489 100644 --- a/plugins/micromega/sos_types.mli +++ b/plugins/micromega/sos_types.mli @@ -10,19 +10,17 @@ (* The type of positivstellensatz -- used to communicate with sos *) -type vname = string;; +type vname = string type term = | Zero | Const of Num.num | Var of vname -| Inv of term | Opp of term | Add of (term * term) | Sub of (term * term) | Mul of (term * term) -| Div of (term * term) -| Pow of (term * int);; +| Pow of (term * int) val output_term : out_channel -> term -> unit @@ -37,6 +35,6 @@ type positivstellensatz = | Monoid of int list | Eqmul of term * positivstellensatz | Sum of positivstellensatz * positivstellensatz - | Product of positivstellensatz * positivstellensatz;; + | Product of positivstellensatz * positivstellensatz val output_psatz : out_channel -> positivstellensatz -> unit diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml new file mode 100644 index 0000000000..b188ab4278 --- /dev/null +++ b/plugins/micromega/vect.ml @@ -0,0 +1,295 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Num +open Mutils + +(** [t] is the type of vectors. + A vector [(x1,v1) ; ... ; (xn,vn)] is such that: + - variables indexes are ordered (x1 < ... < xn + - values are all non-zero + *) +type var = int +type t = (var * num) list + +(** [equal v1 v2 = true] if the vectors are syntactically equal. *) + +let rec equal v1 v2 = + match v1 , v2 with + | [] , [] -> true + | [] , _ -> false + | _::_ , [] -> false + | (i1,n1)::v1 , (i2,n2)::v2 -> + (Int.equal i1 i2) && n1 =/ n2 && equal v1 v2 + +let hash v = + let rec hash i = function + | [] -> i + | (vr,vl)::l -> hash (i + (Hashtbl.hash (vr, float_of_num vl))) l in + Hashtbl.hash (hash 0 v ) + + +let null = [] + +let is_null v = + match v with + | [] | [0,Int 0] -> true + | _ -> false + +let pp_var_num 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 + | [] -> output_string o "0" + | [e] -> pp_var_num pp_var o e + | e::l -> Printf.fprintf o "%a + %a" (pp_var_num pp_var) e (pp_gen pp_var) l + + +let pp_var o v = Printf.fprintf o "x%i" v + +let pp o v = pp_gen pp_var o v + + +let from_list (l: num list) = + let rec xfrom_list i l = + match l with + | [] -> [] + | e::l -> + if e <>/ Int 0 + then (i,e)::(xfrom_list (i+1) l) + else xfrom_list (i+1) l in + + xfrom_list 0 l + +let zero_num = Int 0 + + +let to_list m = + let rec xto_list i l = + match l with + | [] -> [] + | (x,v)::l' -> + if i = x then v::(xto_list (i+1) l') else zero_num ::(xto_list (i+1) l) in + xto_list 0 m + + +let cons i v rst = if v =/ Int 0 then rst else (i,v)::rst + +let rec update i f t = + match t with + | [] -> cons i (f zero_num) [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k (f v) l + | -1 -> cons i (f zero_num) t + | 1 -> (k,v) ::(update i f l) + | _ -> failwith "compare_num" + +let rec set i n t = + match t with + | [] -> cons i n [] + | (k,v)::l -> + match Int.compare i k with + | 0 -> cons k n l + | -1 -> cons i n t + | 1 -> (k,v) :: (set i n l) + | _ -> failwith "compare_num" + +let cst n = if n =/ Int 0 then [] else [0,n] + + +let mul z t = + match z with + | Int 0 -> [] + | Int 1 -> t + | _ -> List.map (fun (i,n) -> (i, mult_num z n)) t + +let div z t = + if z <>/ Int 1 + then List.map (fun (x,nx) -> (x,nx // z)) t + else t + + +let uminus t = List.map (fun (i,n) -> i, minus_num n) t + + +let rec add (ve1:t) (ve2:t) = + match ve1 , ve2 with + | [] , v | v , [] -> v + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = add_num c1 c2 in + if eq_num (Int 0) s + then add l1 l2 + else (v1,s)::(add l1 l2) + else if cmp < 0 then (v1,c1) :: (add l1 ve2) + else (v2,c2) :: (add l2 ve1) + + +let rec xmul_add (n1:num) (ve1:t) (n2:num) (ve2:t) = + match ve1 , ve2 with + | [] , _ -> mul n2 ve2 + | _ , [] -> mul n1 ve1 + | (v1,c1)::l1 , (v2,c2)::l2 -> + let cmp = Pervasives.compare v1 v2 in + if cmp == 0 then + let s = ( n1 */ c1) +/ (n2 */ c2) in + if eq_num (Int 0) s + then xmul_add n1 l1 n2 l2 + else (v1,s)::(xmul_add n1 l1 n2 l2) + else if cmp < 0 then (v1,n1 */ c1) :: (xmul_add n1 l1 n2 ve2) + else (v2,n2 */c2) :: (xmul_add n1 ve1 n2 l2) + +let mul_add n1 ve1 n2 ve2 = + if n1 =/ Int 1 && n2 =/ Int 1 + then add ve1 ve2 + else xmul_add n1 ve1 n2 ve2 + + +let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical + [ + (fun () -> Int.compare (fst x) (fst y)); + (fun () -> compare_num (snd x) (snd y))]) + +(** [tail v vect] returns + - [None] if [v] is not a variable of the vector [vect] + - [Some(vl,rst)] where [vl] is the value of [v] in vector [vect] + and [rst] is the remaining of the vector + We exploit that vectors are ordered lists + *) +let rec tail (v:var) (vect:t) = + match vect with + | [] -> None + | (v',vl)::vect' -> + match Int.compare v' v with + | 0 -> Some (vl,vect) (* Ok, found *) + | -1 -> tail v vect' (* Might be in the tail *) + | _ -> None (* Hopeless *) + +let get v vect = + match tail v vect with + | None -> Int 0 + | Some(vl,_) -> vl + +let is_constant v = + match v with + | [] | [0,_] -> true + | _ -> false + + + +let get_cst vect = + match vect with + | (0,v)::_ -> v + | _ -> Int 0 + +let choose v = + match v with + | [] -> None + | (vr,vl)::rst -> Some (vr,vl,rst) + + +let rec fresh v = + match v with + | [] -> 1 + | [v,_] -> v + 1 + | _::v -> fresh v + + +let variables v = + List.fold_left (fun acc (x,_) -> ISet.add x acc) ISet.empty v + +let decomp_cst v = + match v with + | (0,vl)::v -> vl,v + | _ -> Int 0,v + +let fold f acc v = + List.fold_left (fun acc (v,i) -> f acc v i) acc v + +let fold_error f acc v = + let rec fold acc v = + match v with + | [] -> Some acc + | (x,i)::v' -> match f acc x i with + | None -> None + | Some acc' -> fold acc' v' in + fold acc v + + + +let rec find p v = + match v with + | [] -> None + | (v,n)::v' -> match p v n with + | None -> find p v' + | Some r -> Some r + + +let for_all p l = + List.for_all (fun (v,n) -> p v n) l + + +let decr_var i v = List.map (fun (v,n) -> (v-i,n)) v +let incr_var i v = List.map (fun (v,n) -> (v+i,n)) v + +open Big_int + +let gcd v = + let res = fold (fun c _ n -> + assert (Int.equal (compare_big_int (denominator n) unit_big_int) 0); + gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int res zero_big_int) 0 + then unit_big_int else res + +let normalise v = + let ppcm = fold (fun c _ n -> ppcm c (denominator n)) unit_big_int v in + let gcd = + let gcd = fold (fun c _ n -> gcd_big_int c (numerator n)) zero_big_int v in + if Int.equal (compare_big_int gcd zero_big_int) 0 then unit_big_int else gcd in + List.map (fun (x,v) -> (x, v */ (Big_int ppcm) // (Big_int gcd))) v + +let rec exists2 p vect1 vect2 = + match vect1 , vect2 with + | _ , [] | [], _ -> None + | (v1,n1)::vect1' , (v2, n2) :: vect2' -> + if Int.equal v1 v2 + then + if p n1 n2 + then Some (v1,n1,n2) + else + exists2 p vect1' vect2' + else + if v1 < v2 + then exists2 p vect1' vect2 + else exists2 p vect1 vect2' + +let dotproduct v1 v2 = + let rec dot acc v1 v2 = + match v1, v2 with + | [] , _ | _ , [] -> acc + | (x1,n1)::v1', (x2,n2)::v2' -> + if x1 == x2 + then dot (acc +/ n1 */ n2) v1' v2' + else if x1 < x2 + then dot acc v1' v2 + else dot acc v1 v2' in + dot (Int 0) v1 v2 diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli new file mode 100644 index 0000000000..da6b1e8e9b --- /dev/null +++ b/plugins/micromega/vect.mli @@ -0,0 +1,156 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open Num +open Mutils + +type var = int (** Variables are simply (positive) integers. *) + +type t (** The type of vectors or equivalently linear expressions. + The current implementation is using association lists. + A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression + c + a1.xn + ... an.xn where ai are rational constants and xi are variables. + + Note that the variable 0 has a special meaning and represent a constant. + Moreover, the representation is spare and variables with a zero coefficient + are not represented. + *) + +(** {1 Generic functions} *) + +(** [hash] [equal] and [compare] so that Vect.t can be used as + keys for Set Map and Hashtbl *) + +val hash : t -> int +val equal : t -> t -> bool +val compare : t -> t -> int + +(** {1 Basic accessors and utility functions} *) + +(** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *) +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 + +(** [variables v] returns the set of variables with non-zero coefficients *) +val variables : t -> ISet.t + +(** [get_cst v] returns c i.e. the coefficient of the variable zero *) +val get_cst : t -> num + +(** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) +val decomp_cst : t -> num * t + +(** [cst c] returns the vector v=c+0.x1+...+0.xn *) +val cst : num -> t + +(** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn + *) +val is_constant : t -> bool + +(** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) +val null : t + +(** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) +val is_null : t -> bool + +(** [get xi v] returns the coefficient ai of the variable [xi]. + [get] is also defined for the variable 0 *) +val get : var -> t -> num + +(** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn + i.e. the coefficient of the variable xi is set to ai' *) +val set : var -> num -> t -> 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) *) +val fresh : t -> int + +(** [choose v] decomposes a vector [v] depending on whether it is [null] or not. + @return None if v is [null] + @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. + *) +val choose : t -> (var * num * t) option + +(** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) +val from_list : num list -> t + +(** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] + The list representation is (obviously) not sparsed + and therefore certain ai may be 0 *) +val to_list : t -> num list + +(** [decr_var i v] decrements the variables of the vector [v] by the amount [i]. + Beware, it is only defined if all the variables of v are greater than i + *) +val decr_var : int -> t -> t + +(** [incr_var i v] increments the variables of the vector [v] by the amount [i]. + *) +val incr_var : int -> t -> t + +(** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts + the numerator of a rational value. *) +val gcd : t -> Big_int.big_int + +(** [normalise v] returns a vector with only integer coefficients *) +val normalise : t -> t + + +(** {1 Linear arithmetics} *) + +(** [add v1 v2] is vector addition. + @param v1 is of the form c +a1.x1 +...+an.xn + @param v2 is of the form c'+a1'.x1 +...+an'.xn + @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn + *) +val add : t -> t -> t + +(** [mul a v] is vector multiplication of vector [v] by a scalar [a]. + @return a.v = a.c+a.a1.x1+...+a.an.xn *) +val mul : num -> t -> t + +(** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) +val mul_add : num -> t -> num -> t -> t + +(** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) +val div : num -> t -> t + +(** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) +val uminus : t -> t + +(** {1 Iterators} *) + +(** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) +val fold : ('acc -> var -> num -> 'acc) -> 'acc -> t -> 'acc + +(** [fold_error f acc v] is the same as + [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] + but with early exit... + *) +val fold_error : ('acc -> var -> num -> 'acc option) -> 'acc -> t -> 'acc option + +(** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. + If no such xi ai exists, it returns None *) +val find : (var -> num -> 'c option) -> t -> 'c option + +(** [for_all p v] returns /\_{i>=0} (f xi ai) *) +val for_all : (var -> num -> bool) -> t -> bool + +(** [exists2 p v v'] returns Some(xi,ai,ai') + if p(xi,ai,ai') holds and ai,ai' <> 0. + It returns None if no such pair of coefficient exists. *) +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 diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index d2d4639d2b..11d0a4a44d 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -12,7 +12,6 @@ open CErrors open Util open Constr open Tactics -open Coqlib open Num open Utile @@ -136,36 +135,32 @@ let mul = function | (Const n,q) when eq_num n num_1 -> q | (p,q) -> Mul(p,q) -let gen_constant msg path s = UnivGen.constr_of_global @@ - coq_reference msg path s +let gen_constant n = lazy (UnivGen.constr_of_global (Coqlib.lib_ref n)) -let tpexpr = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PExpr") -let ttconst = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEc") -let ttvar = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEX") -let ttadd = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEadd") -let ttsub = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEsub") -let ttmul = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEmul") -let ttopp = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEopp") -let ttpow = lazy (gen_constant "CC" ["setoid_ring";"Ring_polynom"] "PEpow") +let tpexpr = gen_constant "plugins.setoid_ring.pexpr" +let ttconst = gen_constant "plugins.setoid_ring.const" +let ttvar = gen_constant "plugins.setoid_ring.var" +let ttadd = gen_constant "plugins.setoid_ring.add" +let ttsub = gen_constant "plugins.setoid_ring.sub" +let ttmul = gen_constant "plugins.setoid_ring.mul" +let ttopp = gen_constant "plugins.setoid_ring.opp" +let ttpow = gen_constant "plugins.setoid_ring.pow" -let datatypes = ["Init";"Datatypes"] -let binnums = ["Numbers";"BinNums"] +let tlist = gen_constant "core.list.type" +let lnil = gen_constant "core.list.nil" +let lcons = gen_constant "core.list.cons" -let tlist = lazy (gen_constant "CC" datatypes "list") -let lnil = lazy (gen_constant "CC" datatypes "nil") -let lcons = lazy (gen_constant "CC" datatypes "cons") +let tz = gen_constant "num.Z.type" +let z0 = gen_constant "num.Z.Z0" +let zpos = gen_constant "num.Z.Zpos" +let zneg = gen_constant "num.Z.Zneg" -let tz = lazy (gen_constant "CC" binnums "Z") -let z0 = lazy (gen_constant "CC" binnums "Z0") -let zpos = lazy (gen_constant "CC" binnums "Zpos") -let zneg = lazy(gen_constant "CC" binnums "Zneg") +let pxI = gen_constant "num.pos.xI" +let pxO = gen_constant "num.pos.xO" +let pxH = gen_constant "num.pos.xH" -let pxI = lazy(gen_constant "CC" binnums "xI") -let pxO = lazy(gen_constant "CC" binnums "xO") -let pxH = lazy(gen_constant "CC" binnums "xH") - -let nN0 = lazy (gen_constant "CC" binnums "N0") -let nNpos = lazy(gen_constant "CC" binnums "Npos") +let nN0 = gen_constant "num.N.N0" +let nNpos = gen_constant "num.N.Npos" let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) @@ -545,7 +540,7 @@ let nsatz lpol = let return_term t = let a = - mkApp(gen_constant "CC" ["Init";"Logic"] "eq_refl",[|tllp ();t|]) in + mkApp (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.eq.refl",[|tllp ();t|]) in let a = EConstr.of_constr a in generalize [a] diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index d3cfd75e56..1caa042db6 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -3,116 +3,7 @@ let pr x = if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () -let prn x = - if !Flags.debug then (Format.printf "@[%s\n@]" x; flush(stdout);) else () - let prt0 s = () (* print_string s;flush(stdout)*) -let prt s = - if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () - let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) - -(* Lists *) - -let rec list_mem_eq eq x l = - match l with - [] -> false - |y::l1 -> if (eq x y) then true else (list_mem_eq eq x l1) - -let set_of_list_eq eq l = - let res = ref [] in - List.iter (fun x -> if not (list_mem_eq eq x (!res)) then res:=x::(!res)) l; - List.rev !res - -(********************************************************************** - Eléments minimaux pour un ordre partiel de division. - E est un ensemble, avec une multiplication - et une division partielle div (la fonction div peut échouer), - constant est un prédicat qui définit un sous-ensemble C de E. -*) -(* - Etant donnée une partie A de E, on calcule une partie B de E disjointe de C - telle que: - - les éléments de A sont des produits d'éléments de B et d'un de C. - - B est minimale pour cette propriété. -*) - -let facteurs_liste div constant lp = - let lp = List.filter (fun x -> not (constant x)) lp in - let rec factor lmin lp = (* lmin: ne se divisent pas entre eux *) - match lp with - [] -> lmin - |p::lp1 -> - (let l1 = ref [] in - let p_dans_lmin = ref false in - List.iter (fun q -> try (let r = div p q in - if not (constant r) - then l1:=r::(!l1) - else p_dans_lmin:=true) - with e when CErrors.noncritical e -> ()) - lmin; - if !p_dans_lmin - then factor lmin lp1 - else if (!l1)=[] - (* aucun q de lmin ne divise p *) - then (let l1=ref lp1 in - let lmin1=ref [] in - List.iter (fun q -> try (let r = div q p in - if not (constant r) - then l1:=r::(!l1)) - with e when CErrors.noncritical e -> - lmin1:=q::(!lmin1)) - lmin; - factor (List.rev (p::(!lmin1))) !l1) - (* au moins un q de lmin divise p non trivialement *) - else factor lmin ((!l1)@lp1)) - in - factor [] lp - - -(* On suppose que tout élément de A est produit d'éléments de B et d'un de C: - A et B sont deux tableaux, rend un tableau de couples - (élément de C, listes d'indices l) - tels que A.(i) = l.(i)_1*Produit(B.(j), j dans l.(i)_2) - zero est un prédicat sur E tel que (zero x) => (constant x): - si (zero x) est vrai on ne decompose pas x - c est un élément quelconque de E. -*) -let factorise_tableau div zero c f l1 = - let res = Array.make (Array.length f) (c,[]) in - Array.iteri (fun i p -> - let r = ref p in - let li = ref [] in - if not (zero p) - then - Array.iteri (fun j q -> - try (while true do - let rr = div !r q in - li:=j::(!li); - r:=rr; - done) - with e when CErrors.noncritical e -> ()) - l1; - res.(i)<-(!r,!li)) - f; - (l1,res) - - -(* exemples: - -let l = [1;2;6;24;720] -and div1 = (fun a b -> if a mod b =0 then a/b else failwith "div") -and constant = (fun x -> x<2) -and zero = (fun x -> x=0) - - -let f = facteurs_liste div1 constant l - - -factorise_tableau div1 zero 0 (Array.of_list l) (Array.of_list f) - -*) - - diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli index 9308577e0f..5af7ece5a3 100644 --- a/plugins/nsatz/utile.mli +++ b/plugins/nsatz/utile.mli @@ -1,19 +1,6 @@ (* Printing *) val pr : string -> unit -val prn : string -> unit val prt0 : 'a -> unit -val prt : string -> unit val info : (unit -> string) -> unit val sinfo : string -> unit - -(* Listes *) -val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool -val set_of_list_eq : ('a -> 'a -> bool) -> 'a list -> 'a list - - -val facteurs_liste : ('a -> 'a -> 'a) -> ('a -> bool) -> 'a list -> 'a list -val factorise_tableau : - ('a -> 'b -> 'a) -> - ('a -> bool) -> - 'a -> 'a array -> 'b array -> 'b array * ('a * int list) array diff --git a/plugins/omega/OmegaLemmas.v b/plugins/omega/OmegaLemmas.v index dc86a98998..9593e1225c 100644 --- a/plugins/omega/OmegaLemmas.v +++ b/plugins/omega/OmegaLemmas.v @@ -267,3 +267,49 @@ Proof. intros n; exists (Z.of_nat n); split; trivial. rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg. Qed. + +Register fast_Zplus_assoc_reverse as plugins.omega.fast_Zplus_assoc_reverse. +Register fast_Zplus_assoc as plugins.omega.fast_Zplus_assoc. +Register fast_Zmult_assoc_reverse as plugins.omega.fast_Zmult_assoc_reverse. +Register fast_Zplus_permute as plugins.omega.fast_Zplus_permute. +Register fast_Zplus_comm as plugins.omega.fast_Zplus_comm. +Register fast_Zmult_comm as plugins.omega.fast_Zmult_comm. + +Register OMEGA1 as plugins.omega.OMEGA1. +Register OMEGA2 as plugins.omega.OMEGA2. +Register OMEGA3 as plugins.omega.OMEGA3. +Register OMEGA4 as plugins.omega.OMEGA4. +Register OMEGA5 as plugins.omega.OMEGA5. +Register OMEGA6 as plugins.omega.OMEGA6. +Register OMEGA7 as plugins.omega.OMEGA7. +Register OMEGA8 as plugins.omega.OMEGA8. +Register OMEGA9 as plugins.omega.OMEGA9. +Register fast_OMEGA10 as plugins.omega.fast_OMEGA10. +Register fast_OMEGA11 as plugins.omega.fast_OMEGA11. +Register fast_OMEGA12 as plugins.omega.fast_OMEGA12. +Register fast_OMEGA13 as plugins.omega.fast_OMEGA13. +Register fast_OMEGA14 as plugins.omega.fast_OMEGA14. +Register fast_OMEGA15 as plugins.omega.fast_OMEGA15. +Register fast_OMEGA16 as plugins.omega.fast_OMEGA16. +Register OMEGA17 as plugins.omega.OMEGA17. +Register OMEGA18 as plugins.omega.OMEGA18. +Register OMEGA19 as plugins.omega.OMEGA19. +Register OMEGA20 as plugins.omega.OMEGA20. + +Register fast_Zred_factor0 as plugins.omega.fast_Zred_factor0. +Register fast_Zred_factor1 as plugins.omega.fast_Zred_factor1. +Register fast_Zred_factor2 as plugins.omega.fast_Zred_factor2. +Register fast_Zred_factor3 as plugins.omega.fast_Zred_factor3. +Register fast_Zred_factor4 as plugins.omega.fast_Zred_factor4. +Register fast_Zred_factor5 as plugins.omega.fast_Zred_factor5. +Register fast_Zred_factor6 as plugins.omega.fast_Zred_factor6. + +Register fast_Zmult_plus_distr_l as plugins.omega.fast_Zmult_plus_distr_l. +Register fast_Zmult_opp_comm as plugins.omega.fast_Zmult_opp_comm. +Register fast_Zopp_plus_distr as plugins.omega.fast_Zopp_plus_distr. +Register fast_Zopp_mult_distr_r as plugins.omega.fast_Zopp_mult_distr_r. +Register fast_Zopp_eq_mult_neg_1 as plugins.omega.fast_Zopp_eq_mult_neg_1. +Register fast_Zopp_involutive as plugins.omega.fast_Zopp_involutive. + +Register new_var as plugins.omega.new_var. +Register intro_Z as plugins.omega.intro_Z. diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 094adfda7a..94a3d40441 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -183,7 +183,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t in H | _ => rewrite (Nat2Z.inj_succ a) in H - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in this one hypothesis *) change (Z.of_nat (S a)) with (Z_of_nat' (S a)) in H end @@ -194,7 +194,7 @@ Ltac zify_nat_op := let t := eval compute in (Z.of_nat (S a)) in change (Z.of_nat (S a)) with t | _ => rewrite (Nat2Z.inj_succ a) - | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), + | _ => (* if the [rewrite] fails (most likely a dependent occurrence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in the goal *) change (Z.of_nat (S a)) with (Z_of_nat' (S a)) end diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index abae6940fa..f55458de8d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -193,172 +193,159 @@ let reset_all () = To use the constant Zplus, one must type "Lazy.force coq_Zplus" This is the right way to access to Coq constants in tactics ML code *) -open Coqlib - -let logic_dir = ["Coq";"Logic";"Decidable"] -let coq_modules = - init_modules @arith_modules @ [logic_dir] @ zarith_base_modules - @ [["Coq"; "omega"; "OmegaLemmas"]] - -let gen_constant_in_modules n m s = EConstr.of_constr (UnivGen.constr_of_global @@ gen_reference_in_modules n m s) -let init_constant = gen_constant_in_modules "Omega" init_modules -let constant = gen_constant_in_modules "Omega" coq_modules - -let z_constant = gen_constant_in_modules "Omega" [["Coq";"ZArith"]] -let zbase_constant = - gen_constant_in_modules "Omega" [["Coq";"ZArith";"BinInt"]] +let gen_constant k = lazy (k |> Coqlib.lib_ref |> UnivGen.constr_of_global |> EConstr.of_constr) (* Zarith *) -let coq_xH = lazy (constant "xH") -let coq_xO = lazy (constant "xO") -let coq_xI = lazy (constant "xI") -let coq_Z0 = lazy (constant "Z0") -let coq_Zpos = lazy (constant "Zpos") -let coq_Zneg = lazy (constant "Zneg") -let coq_Z = lazy (constant "Z") -let coq_comparison = lazy (constant "comparison") -let coq_Gt = lazy (constant "Gt") -let coq_Zplus = lazy (zbase_constant "Z.add") -let coq_Zmult = lazy (zbase_constant "Z.mul") -let coq_Zopp = lazy (zbase_constant "Z.opp") -let coq_Zminus = lazy (zbase_constant "Z.sub") -let coq_Zsucc = lazy (zbase_constant "Z.succ") -let coq_Zpred = lazy (zbase_constant "Z.pred") -let coq_Z_of_nat = lazy (zbase_constant "Z.of_nat") -let coq_inj_plus = lazy (z_constant "Nat2Z.inj_add") -let coq_inj_mult = lazy (z_constant "Nat2Z.inj_mul") -let coq_inj_minus1 = lazy (z_constant "Nat2Z.inj_sub") -let coq_inj_minus2 = lazy (constant "inj_minus2") -let coq_inj_S = lazy (z_constant "Nat2Z.inj_succ") -let coq_inj_le = lazy (z_constant "Znat.inj_le") -let coq_inj_lt = lazy (z_constant "Znat.inj_lt") -let coq_inj_ge = lazy (z_constant "Znat.inj_ge") -let coq_inj_gt = lazy (z_constant "Znat.inj_gt") -let coq_inj_neq = lazy (z_constant "inj_neq") -let coq_inj_eq = lazy (z_constant "inj_eq") -let coq_fast_Zplus_assoc_reverse = lazy (constant "fast_Zplus_assoc_reverse") -let coq_fast_Zplus_assoc = lazy (constant "fast_Zplus_assoc") -let coq_fast_Zmult_assoc_reverse = lazy (constant "fast_Zmult_assoc_reverse") -let coq_fast_Zplus_permute = lazy (constant "fast_Zplus_permute") -let coq_fast_Zplus_comm = lazy (constant "fast_Zplus_comm") -let coq_fast_Zmult_comm = lazy (constant "fast_Zmult_comm") -let coq_Zmult_le_approx = lazy (constant "Zmult_le_approx") -let coq_OMEGA1 = lazy (constant "OMEGA1") -let coq_OMEGA2 = lazy (constant "OMEGA2") -let coq_OMEGA3 = lazy (constant "OMEGA3") -let coq_OMEGA4 = lazy (constant "OMEGA4") -let coq_OMEGA5 = lazy (constant "OMEGA5") -let coq_OMEGA6 = lazy (constant "OMEGA6") -let coq_OMEGA7 = lazy (constant "OMEGA7") -let coq_OMEGA8 = lazy (constant "OMEGA8") -let coq_OMEGA9 = lazy (constant "OMEGA9") -let coq_fast_OMEGA10 = lazy (constant "fast_OMEGA10") -let coq_fast_OMEGA11 = lazy (constant "fast_OMEGA11") -let coq_fast_OMEGA12 = lazy (constant "fast_OMEGA12") -let coq_fast_OMEGA13 = lazy (constant "fast_OMEGA13") -let coq_fast_OMEGA14 = lazy (constant "fast_OMEGA14") -let coq_fast_OMEGA15 = lazy (constant "fast_OMEGA15") -let coq_fast_OMEGA16 = lazy (constant "fast_OMEGA16") -let coq_OMEGA17 = lazy (constant "OMEGA17") -let coq_OMEGA18 = lazy (constant "OMEGA18") -let coq_OMEGA19 = lazy (constant "OMEGA19") -let coq_OMEGA20 = lazy (constant "OMEGA20") -let coq_fast_Zred_factor0 = lazy (constant "fast_Zred_factor0") -let coq_fast_Zred_factor1 = lazy (constant "fast_Zred_factor1") -let coq_fast_Zred_factor2 = lazy (constant "fast_Zred_factor2") -let coq_fast_Zred_factor3 = lazy (constant "fast_Zred_factor3") -let coq_fast_Zred_factor4 = lazy (constant "fast_Zred_factor4") -let coq_fast_Zred_factor5 = lazy (constant "fast_Zred_factor5") -let coq_fast_Zred_factor6 = lazy (constant "fast_Zred_factor6") -let coq_fast_Zmult_plus_distr_l = lazy (constant "fast_Zmult_plus_distr_l") -let coq_fast_Zmult_opp_comm = lazy (constant "fast_Zmult_opp_comm") -let coq_fast_Zopp_plus_distr = lazy (constant "fast_Zopp_plus_distr") -let coq_fast_Zopp_mult_distr_r = lazy (constant "fast_Zopp_mult_distr_r") -let coq_fast_Zopp_eq_mult_neg_1 = lazy (constant "fast_Zopp_eq_mult_neg_1") -let coq_fast_Zopp_involutive = lazy (constant "fast_Zopp_involutive") -let coq_Zegal_left = lazy (constant "Zegal_left") -let coq_Zne_left = lazy (constant "Zne_left") -let coq_Zlt_left = lazy (constant "Zlt_left") -let coq_Zge_left = lazy (constant "Zge_left") -let coq_Zgt_left = lazy (constant "Zgt_left") -let coq_Zle_left = lazy (constant "Zle_left") -let coq_new_var = lazy (constant "new_var") -let coq_intro_Z = lazy (constant "intro_Z") - -let coq_dec_eq = lazy (zbase_constant "Z.eq_decidable") -let coq_dec_Zne = lazy (constant "dec_Zne") -let coq_dec_Zle = lazy (zbase_constant "Z.le_decidable") -let coq_dec_Zlt = lazy (zbase_constant "Z.lt_decidable") -let coq_dec_Zgt = lazy (constant "dec_Zgt") -let coq_dec_Zge = lazy (constant "dec_Zge") - -let coq_not_Zeq = lazy (constant "not_Zeq") -let coq_not_Zne = lazy (constant "not_Zne") -let coq_Znot_le_gt = lazy (constant "Znot_le_gt") -let coq_Znot_lt_ge = lazy (constant "Znot_lt_ge") -let coq_Znot_ge_lt = lazy (constant "Znot_ge_lt") -let coq_Znot_gt_le = lazy (constant "Znot_gt_le") -let coq_neq = lazy (constant "neq") -let coq_Zne = lazy (constant "Zne") -let coq_Zle = lazy (zbase_constant "Z.le") -let coq_Zgt = lazy (zbase_constant "Z.gt") -let coq_Zge = lazy (zbase_constant "Z.ge") -let coq_Zlt = lazy (zbase_constant "Z.lt") +let coq_xH = gen_constant "num.pos.xH" +let coq_xO = gen_constant "num.pos.xO" +let coq_xI = gen_constant "num.pos.xI" +let coq_Z0 = gen_constant "num.Z.Z0" +let coq_Zpos = gen_constant "num.Z.Zpos" +let coq_Zneg = gen_constant "num.Z.Zneg" +let coq_Z = gen_constant "num.Z.type" +let coq_comparison = gen_constant "core.comparison.type" +let coq_Gt = gen_constant "core.comparison.Gt" +let coq_Zplus = gen_constant "num.Z.add" +let coq_Zmult = gen_constant "num.Z.mul" +let coq_Zopp = gen_constant "num.Z.opp" +let coq_Zminus = gen_constant "num.Z.sub" +let coq_Zsucc = gen_constant "num.Z.succ" +let coq_Zpred = gen_constant "num.Z.pred" +let coq_Z_of_nat = gen_constant "num.Z.of_nat" +let coq_inj_plus = gen_constant "num.Nat2Z.inj_add" +let coq_inj_mult = gen_constant "num.Nat2Z.inj_mul" +let coq_inj_minus1 = gen_constant "num.Nat2Z.inj_sub" +let coq_inj_minus2 = gen_constant "plugins.omega.inj_minus2" +let coq_inj_S = gen_constant "num.Nat2Z.inj_succ" +let coq_inj_eq = gen_constant "plugins.omega.inj_eq" +let coq_inj_neq = gen_constant "plugins.omega.inj_neq" +let coq_inj_le = gen_constant "plugins.omega.inj_le" +let coq_inj_lt = gen_constant "plugins.omega.inj_lt" +let coq_inj_ge = gen_constant "plugins.omega.inj_ge" +let coq_inj_gt = gen_constant "plugins.omega.inj_gt" +let coq_fast_Zplus_assoc_reverse = gen_constant "plugins.omega.fast_Zplus_assoc_reverse" +let coq_fast_Zplus_assoc = gen_constant "plugins.omega.fast_Zplus_assoc" +let coq_fast_Zmult_assoc_reverse = gen_constant "plugins.omega.fast_Zmult_assoc_reverse" +let coq_fast_Zplus_permute = gen_constant "plugins.omega.fast_Zplus_permute" +let coq_fast_Zplus_comm = gen_constant "plugins.omega.fast_Zplus_comm" +let coq_fast_Zmult_comm = gen_constant "plugins.omega.fast_Zmult_comm" +let coq_Zmult_le_approx = gen_constant "plugins.omega.Zmult_le_approx" +let coq_OMEGA1 = gen_constant "plugins.omega.OMEGA1" +let coq_OMEGA2 = gen_constant "plugins.omega.OMEGA2" +let coq_OMEGA3 = gen_constant "plugins.omega.OMEGA3" +let coq_OMEGA4 = gen_constant "plugins.omega.OMEGA4" +let coq_OMEGA5 = gen_constant "plugins.omega.OMEGA5" +let coq_OMEGA6 = gen_constant "plugins.omega.OMEGA6" +let coq_OMEGA7 = gen_constant "plugins.omega.OMEGA7" +let coq_OMEGA8 = gen_constant "plugins.omega.OMEGA8" +let coq_OMEGA9 = gen_constant "plugins.omega.OMEGA9" +let coq_fast_OMEGA10 = gen_constant "plugins.omega.fast_OMEGA10" +let coq_fast_OMEGA11 = gen_constant "plugins.omega.fast_OMEGA11" +let coq_fast_OMEGA12 = gen_constant "plugins.omega.fast_OMEGA12" +let coq_fast_OMEGA13 = gen_constant "plugins.omega.fast_OMEGA13" +let coq_fast_OMEGA14 = gen_constant "plugins.omega.fast_OMEGA14" +let coq_fast_OMEGA15 = gen_constant "plugins.omega.fast_OMEGA15" +let coq_fast_OMEGA16 = gen_constant "plugins.omega.fast_OMEGA16" +let coq_OMEGA17 = gen_constant "plugins.omega.OMEGA17" +let coq_OMEGA18 = gen_constant "plugins.omega.OMEGA18" +let coq_OMEGA19 = gen_constant "plugins.omega.OMEGA19" +let coq_OMEGA20 = gen_constant "plugins.omega.OMEGA20" +let coq_fast_Zred_factor0 = gen_constant "plugins.omega.fast_Zred_factor0" +let coq_fast_Zred_factor1 = gen_constant "plugins.omega.fast_Zred_factor1" +let coq_fast_Zred_factor2 = gen_constant "plugins.omega.fast_Zred_factor2" +let coq_fast_Zred_factor3 = gen_constant "plugins.omega.fast_Zred_factor3" +let coq_fast_Zred_factor4 = gen_constant "plugins.omega.fast_Zred_factor4" +let coq_fast_Zred_factor5 = gen_constant "plugins.omega.fast_Zred_factor5" +let coq_fast_Zred_factor6 = gen_constant "plugins.omega.fast_Zred_factor6" +let coq_fast_Zmult_plus_distr_l = gen_constant "plugins.omega.fast_Zmult_plus_distr_l" +let coq_fast_Zmult_opp_comm = gen_constant "plugins.omega.fast_Zmult_opp_comm" +let coq_fast_Zopp_plus_distr = gen_constant "plugins.omega.fast_Zopp_plus_distr" +let coq_fast_Zopp_mult_distr_r = gen_constant "plugins.omega.fast_Zopp_mult_distr_r" +let coq_fast_Zopp_eq_mult_neg_1 = gen_constant "plugins.omega.fast_Zopp_eq_mult_neg_1" +let coq_fast_Zopp_involutive = gen_constant "plugins.omega.fast_Zopp_involutive" +let coq_Zegal_left = gen_constant "plugins.omega.Zegal_left" +let coq_Zne_left = gen_constant "plugins.omega.Zne_left" +let coq_Zlt_left = gen_constant "plugins.omega.Zlt_left" +let coq_Zge_left = gen_constant "plugins.omega.Zge_left" +let coq_Zgt_left = gen_constant "plugins.omega.Zgt_left" +let coq_Zle_left = gen_constant "plugins.omega.Zle_left" +let coq_new_var = gen_constant "plugins.omega.new_var" +let coq_intro_Z = gen_constant "plugins.omega.intro_Z" + +let coq_dec_eq = gen_constant "num.Z.eq_decidable" +let coq_dec_Zne = gen_constant "plugins.omega.dec_Zne" +let coq_dec_Zle = gen_constant "num.Z.le_decidable" +let coq_dec_Zlt = gen_constant "num.Z.lt_decidable" +let coq_dec_Zgt = gen_constant "plugins.omega.dec_Zgt" +let coq_dec_Zge = gen_constant "plugins.omega.dec_Zge" + +let coq_not_Zeq = gen_constant "plugins.omega.not_Zeq" +let coq_not_Zne = gen_constant "plugins.omega.not_Zne" +let coq_Znot_le_gt = gen_constant "plugins.omega.Znot_le_gt" +let coq_Znot_lt_ge = gen_constant "plugins.omega.Znot_lt_ge" +let coq_Znot_ge_lt = gen_constant "plugins.omega.Znot_ge_lt" +let coq_Znot_gt_le = gen_constant "plugins.omega.Znot_gt_le" +let coq_neq = gen_constant "plugins.omega.neq" +let coq_Zne = gen_constant "plugins.omega.Zne" +let coq_Zle = gen_constant "num.Z.le" +let coq_Zlt = gen_constant "num.Z.lt" +let coq_Zge = gen_constant "num.Z.ge" +let coq_Zgt = gen_constant "num.Z.gt" (* Peano/Datatypes *) -let coq_le = lazy (init_constant "le") -let coq_lt = lazy (init_constant "lt") -let coq_ge = lazy (init_constant "ge") -let coq_gt = lazy (init_constant "gt") -let coq_minus = lazy (init_constant "Nat.sub") -let coq_plus = lazy (init_constant "Nat.add") -let coq_mult = lazy (init_constant "Nat.mul") -let coq_pred = lazy (init_constant "Nat.pred") -let coq_nat = lazy (init_constant "nat") -let coq_S = lazy (init_constant "S") -let coq_O = lazy (init_constant "O") +let coq_nat = gen_constant "num.nat.type" +let coq_O = gen_constant "num.nat.O" +let coq_S = gen_constant "num.nat.S" +let coq_le = gen_constant "num.nat.le" +let coq_lt = gen_constant "num.nat.lt" +let coq_ge = gen_constant "num.nat.ge" +let coq_gt = gen_constant "num.nat.gt" +let coq_plus = gen_constant "num.nat.add" +let coq_minus = gen_constant "num.nat.sub" +let coq_mult = gen_constant "num.nat.mul" +let coq_pred = gen_constant "num.nat.pred" (* Compare_dec/Peano_dec/Minus *) -let coq_pred_of_minus = lazy (constant "pred_of_minus") -let coq_le_gt_dec = lazy (constant "le_gt_dec") -let coq_dec_eq_nat = lazy (constant "dec_eq_nat") -let coq_dec_le = lazy (constant "dec_le") -let coq_dec_lt = lazy (constant "dec_lt") -let coq_dec_ge = lazy (constant "dec_ge") -let coq_dec_gt = lazy (constant "dec_gt") -let coq_not_eq = lazy (constant "not_eq") -let coq_not_le = lazy (constant "not_le") -let coq_not_lt = lazy (constant "not_lt") -let coq_not_ge = lazy (constant "not_ge") -let coq_not_gt = lazy (constant "not_gt") +let coq_pred_of_minus = gen_constant "num.nat.pred_of_minus" +let coq_le_gt_dec = gen_constant "num.nat.le_gt_dec" +let coq_dec_eq_nat = gen_constant "num.nat.eq_dec" +let coq_dec_le = gen_constant "num.nat.dec_le" +let coq_dec_lt = gen_constant "num.nat.dec_lt" +let coq_dec_ge = gen_constant "num.nat.dec_ge" +let coq_dec_gt = gen_constant "num.nat.dec_gt" +let coq_not_eq = gen_constant "num.nat.not_eq" +let coq_not_le = gen_constant "num.nat.not_le" +let coq_not_lt = gen_constant "num.nat.not_lt" +let coq_not_ge = gen_constant "num.nat.not_ge" +let coq_not_gt = gen_constant "num.nat.not_gt" (* Logic/Decidable *) -let coq_eq_ind_r = lazy (constant "eq_ind_r") - -let coq_dec_or = lazy (constant "dec_or") -let coq_dec_and = lazy (constant "dec_and") -let coq_dec_imp = lazy (constant "dec_imp") -let coq_dec_iff = lazy (constant "dec_iff") -let coq_dec_not = lazy (constant "dec_not") -let coq_dec_False = lazy (constant "dec_False") -let coq_dec_not_not = lazy (constant "dec_not_not") -let coq_dec_True = lazy (constant "dec_True") - -let coq_not_or = lazy (constant "not_or") -let coq_not_and = lazy (constant "not_and") -let coq_not_imp = lazy (constant "not_imp") -let coq_not_iff = lazy (constant "not_iff") -let coq_not_not = lazy (constant "not_not") -let coq_imp_simp = lazy (constant "imp_simp") -let coq_iff = lazy (constant "iff") -let coq_not = lazy (init_constant "not") -let coq_and = lazy (init_constant "and") -let coq_or = lazy (init_constant "or") -let coq_eq = lazy (init_constant "eq") -let coq_ex = lazy (init_constant "ex") -let coq_False = lazy (init_constant "False") -let coq_True = lazy (init_constant "True") +let coq_eq_ind_r = gen_constant "core.eq.ind_r" + +let coq_dec_or = gen_constant "core.dec.or" +let coq_dec_and = gen_constant "core.dec.and" +let coq_dec_imp = gen_constant "core.dec.imp" +let coq_dec_iff = gen_constant "core.dec.iff" +let coq_dec_not = gen_constant "core.dec.not" +let coq_dec_False = gen_constant "core.dec.False" +let coq_dec_not_not = gen_constant "core.dec.not_not" +let coq_dec_True = gen_constant "core.dec.True" + +let coq_not_or = gen_constant "core.dec.not_or" +let coq_not_and = gen_constant "core.dec.not_and" +let coq_not_imp = gen_constant "core.dec.not_imp" +let coq_not_iff = gen_constant "core.dec.not_iff" +let coq_not_not = gen_constant "core.dec.dec_not_not" +let coq_imp_simp = gen_constant "core.dec.imp_simp" +let coq_iff = gen_constant "core.iff.type" +let coq_not = gen_constant "core.not.type" +let coq_and = gen_constant "core.and.type" +let coq_or = gen_constant "core.or.type" +let coq_eq = gen_constant "core.eq.type" +let coq_ex = gen_constant "core.ex.type" +let coq_False = gen_constant "core.False.type" +let coq_True = gen_constant "core.True.type" (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) diff --git a/plugins/omega/omega.ml b/plugins/omega/omega.ml index 2510c16934..7bca7c7099 100644 --- a/plugins/omega/omega.ml +++ b/plugins/omega/omega.ml @@ -178,7 +178,7 @@ let rec display_action print_var = function | DIVIDE_AND_APPROX (e1,e2,k,d) -> Printf.printf "Inequation E%d is divided by %s and the constant coefficient is \ - rounded by substracting %s.\n" e1.id (sbi k) (sbi d) + rounded by subtracting %s.\n" e1.id (sbi k) (sbi d) | NOT_EXACT_DIVIDE (e,k) -> Printf.printf "Constant in equation E%d is not divisible by the pgcd \ diff --git a/plugins/quote/plugin_base.dune b/plugins/quote/plugin_base.dune deleted file mode 100644 index 323906acb2..0000000000 --- a/plugins/quote/plugin_base.dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name quote_plugin) - (public_name coq.plugins.quote) - (synopsis "Coq's quote plugin") - (libraries coq.plugins.ltac)) diff --git a/plugins/rtauto/Bintree.v b/plugins/rtauto/Bintree.v index 600e8993b4..99c02995fb 100644 --- a/plugins/rtauto/Bintree.v +++ b/plugins/rtauto/Bintree.v @@ -319,6 +319,9 @@ Arguments F_empty [A]. Arguments F_push [A] a S _. Arguments In [A] x S F. +Register empty as plugins.rtauto.empty. +Register push as plugins.rtauto.push. + Section Map. Variables A B:Set. diff --git a/plugins/rtauto/Rtauto.v b/plugins/rtauto/Rtauto.v index 06cdf76b4e..f027a4a46e 100644 --- a/plugins/rtauto/Rtauto.v +++ b/plugins/rtauto/Rtauto.v @@ -387,3 +387,24 @@ exact (Reflect (empty \ A \ B \ C) Qed. Print toto. *) + +Register Reflect as plugins.rtauto.Reflect. + +Register Atom as plugins.rtauto.Atom. +Register Arrow as plugins.rtauto.Arrow. +Register Bot as plugins.rtauto.Bot. +Register Conjunct as plugins.rtauto.Conjunct. +Register Disjunct as plugins.rtauto.Disjunct. + +Register Ax as plugins.rtauto.Ax. +Register I_Arrow as plugins.rtauto.I_Arrow. +Register E_Arrow as plugins.rtauto.E_Arrow. +Register D_Arrow as plugins.rtauto.D_Arrow. +Register E_False as plugins.rtauto.E_False. +Register I_And as plugins.rtauto.I_And. +Register E_And as plugins.rtauto.E_And. +Register D_And as plugins.rtauto.D_And. +Register I_Or_l as plugins.rtauto.I_Or_l. +Register I_Or_r as plugins.rtauto.I_Or_r. +Register E_Or as plugins.rtauto.E_Or. +Register D_Or as plugins.rtauto.D_Or. diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 8a0f48dc4d..79418da27c 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -26,49 +26,39 @@ let step_count = ref 0 let node_count = ref 0 -let logic_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Init";"Logic"] s - -let li_False = lazy (destInd (logic_constant "False")) -let li_and = lazy (destInd (logic_constant "and")) -let li_or = lazy (destInd (logic_constant "or")) - -let pos_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["Numbers";"BinNums"] s - -let l_xI = lazy (pos_constant "xI") -let l_xO = lazy (pos_constant "xO") -let l_xH = lazy (pos_constant "xH") - -let store_constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Bintree"] s - -let l_empty = lazy (store_constant "empty") -let l_push = lazy (store_constant "push") - -let constant s = UnivGen.constr_of_global @@ - Coqlib.coq_reference "refl_tauto" ["rtauto";"Rtauto"] s - -let l_Reflect = lazy (constant "Reflect") - -let l_Atom = lazy (constant "Atom") -let l_Arrow = lazy (constant "Arrow") -let l_Bot = lazy (constant "Bot") -let l_Conjunct = lazy (constant "Conjunct") -let l_Disjunct = lazy (constant "Disjunct") - -let l_Ax = lazy (constant "Ax") -let l_I_Arrow = lazy (constant "I_Arrow") -let l_E_Arrow = lazy (constant "E_Arrow") -let l_D_Arrow = lazy (constant "D_Arrow") -let l_E_False = lazy (constant "E_False") -let l_I_And = lazy (constant "I_And") -let l_E_And = lazy (constant "E_And") -let l_D_And = lazy (constant "D_And") -let l_I_Or_l = lazy (constant "I_Or_l") -let l_I_Or_r = lazy (constant "I_Or_r") -let l_E_Or = lazy (constant "E_Or") -let l_D_Or = lazy (constant "D_Or") +let li_False = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.False.type")) +let li_and = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.and.type")) +let li_or = lazy (destInd (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.or.type")) + +let gen_constant n = lazy (UnivGen.constr_of_global (Coqlib.lib_ref n)) + +let l_xI = gen_constant "num.pos.xI" +let l_xO = gen_constant "num.pos.xO" +let l_xH = gen_constant "num.pos.xH" + +let l_empty = gen_constant "plugins.rtauto.empty" +let l_push = gen_constant "plugins.rtauto.push" + +let l_Reflect = gen_constant "plugins.rtauto.Reflect" + +let l_Atom = gen_constant "plugins.rtauto.Atom" +let l_Arrow = gen_constant "plugins.rtauto.Arrow" +let l_Bot = gen_constant "plugins.rtauto.Bot" +let l_Conjunct = gen_constant "plugins.rtauto.Conjunct" +let l_Disjunct = gen_constant "plugins.rtauto.Disjunct" + +let l_Ax = gen_constant "plugins.rtauto.Ax" +let l_I_Arrow = gen_constant "plugins.rtauto.I_Arrow" +let l_E_Arrow = gen_constant "plugins.rtauto.E_Arrow" +let l_D_Arrow = gen_constant "plugins.rtauto.D_Arrow" +let l_E_False = gen_constant "plugins.rtauto.E_False" +let l_I_And = gen_constant "plugins.rtauto.I_And" +let l_E_And = gen_constant "plugins.rtauto.E_And" +let l_D_And = gen_constant "plugins.rtauto.D_And" +let l_I_Or_l = gen_constant "plugins.rtauto.I_Or_l" +let l_I_Or_r = gen_constant "plugins.rtauto.I_Or_r" +let l_E_Or = gen_constant "plugins.rtauto.E_Or" +let l_D_Or = gen_constant "plugins.rtauto.D_Or" let special_whd gl c = diff --git a/plugins/setoid_ring/Ring_polynom.v b/plugins/setoid_ring/Ring_polynom.v index 33df36d847..ccd82eabcd 100644 --- a/plugins/setoid_ring/Ring_polynom.v +++ b/plugins/setoid_ring/Ring_polynom.v @@ -919,6 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. + Register PExpr as plugins.setoid_ring.pexpr. + Register PEc as plugins.setoid_ring.const. + Register PEX as plugins.setoid_ring.var. + Register PEadd as plugins.setoid_ring.add. + Register PEsub as plugins.setoid_ring.sub. + Register PEmul as plugins.setoid_ring.mul. + Register PEopp as plugins.setoid_ring.opp. + Register PEpow as plugins.setoid_ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.mlg index 4ea0b30bd7..3ddea7eb30 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.mlg @@ -8,6 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin open Pp open Util @@ -20,15 +22,19 @@ open Tacarg open Pcoq.Constr open Pltac +} + DECLARE PLUGIN "newring_plugin" TACTIC EXTEND protect_fv - [ "protect_fv" string(map) "in" ident(id) ] -> - [ protect_tac_in map id ] +| [ "protect_fv" string(map) "in" ident(id) ] -> + { protect_tac_in map id } | [ "protect_fv" string(map) ] -> - [ protect_tac map ] + { protect_tac map } END +{ + open Pptactic open Ppconstr @@ -46,35 +52,41 @@ let pr_ring_mod = function | Sign_spec t -> str "sign" ++ pr_arg pr_constr_expr t | Div_spec t -> str "div" ++ pr_arg pr_constr_expr t +} + VERNAC ARGUMENT EXTEND ring_mod - PRINTED BY pr_ring_mod - | [ "decidable" constr(eq_test) ] -> [ Ring_kind(Computational eq_test) ] - | [ "abstract" ] -> [ Ring_kind Abstract ] - | [ "morphism" constr(morph) ] -> [ Ring_kind(Morphism morph) ] - | [ "constants" "[" tactic(cst_tac) "]" ] -> [ Const_tac(CstTac cst_tac) ] - | [ "closed" "[" ne_global_list(l) "]" ] -> [ Const_tac(Closed l) ] - | [ "preprocess" "[" tactic(pre) "]" ] -> [ Pre_tac pre ] - | [ "postprocess" "[" tactic(post) "]" ] -> [ Post_tac post ] - | [ "setoid" constr(sth) constr(ext) ] -> [ Setoid(sth,ext) ] - | [ "sign" constr(sign_spec) ] -> [ Sign_spec sign_spec ] + PRINTED BY { pr_ring_mod } + | [ "decidable" constr(eq_test) ] -> { Ring_kind(Computational eq_test) } + | [ "abstract" ] -> { Ring_kind Abstract } + | [ "morphism" constr(morph) ] -> { Ring_kind(Morphism morph) } + | [ "constants" "[" tactic(cst_tac) "]" ] -> { Const_tac(CstTac cst_tac) } + | [ "closed" "[" ne_global_list(l) "]" ] -> { Const_tac(Closed l) } + | [ "preprocess" "[" tactic(pre) "]" ] -> { Pre_tac pre } + | [ "postprocess" "[" tactic(post) "]" ] -> { Post_tac post } + | [ "setoid" constr(sth) constr(ext) ] -> { Setoid(sth,ext) } + | [ "sign" constr(sign_spec) ] -> { Sign_spec sign_spec } | [ "power" constr(pow_spec) "[" ne_global_list(l) "]" ] -> - [ Pow_spec (Closed l, pow_spec) ] + { Pow_spec (Closed l, pow_spec) } | [ "power_tac" constr(pow_spec) "[" tactic(cst_tac) "]" ] -> - [ Pow_spec (CstTac cst_tac, pow_spec) ] - | [ "div" constr(div_spec) ] -> [ Div_spec div_spec ] + { Pow_spec (CstTac cst_tac, pow_spec) } + | [ "div" constr(div_spec) ] -> { Div_spec div_spec } END +{ + let pr_ring_mods l = surround (prlist_with_sep pr_comma pr_ring_mod l) +} + VERNAC ARGUMENT EXTEND ring_mods - PRINTED BY pr_ring_mods - | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> [ mods ] + PRINTED BY { pr_ring_mods } + | [ "(" ne_ring_mod_list_sep(mods, ",") ")" ] -> { mods } 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" ] => [Vernac_classifier.classify_as_query] -> [ + { let l = match l with None -> [] | Some l -> l in add_theory id t l } + | [ "Print" "Rings" ] => {Vernac_classifier.classify_as_query} -> { Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -82,35 +94,43 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF (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 } END TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t ] + { let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t } END +{ + let pr_field_mod = function | Ring_mod m -> pr_ring_mod m | Inject inj -> str "completeness" ++ pr_arg pr_constr_expr inj +} + VERNAC ARGUMENT EXTEND field_mod - PRINTED BY pr_field_mod - | [ ring_mod(m) ] -> [ Ring_mod m ] - | [ "completeness" constr(inj) ] -> [ Inject inj ] + PRINTED BY { pr_field_mod } + | [ ring_mod(m) ] -> { Ring_mod m } + | [ "completeness" constr(inj) ] -> { Inject inj } END +{ + let pr_field_mods l = surround (prlist_with_sep pr_comma pr_field_mod l) +} + VERNAC ARGUMENT EXTEND field_mods - PRINTED BY pr_field_mods - | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> [ mods ] + PRINTED BY { pr_field_mods } + | [ "(" ne_field_mod_list_sep(mods, ",") ")" ] -> { mods } 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" ] => [Vernac_classifier.classify_as_query] -> [ + { let l = match l with None -> [] | Some l -> l in add_field_theory id t l } +| [ "Print" "Fields" ] => {Vernac_classifier.classify_as_query} -> { Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> let sigma, env = Pfedit.get_current_context () in @@ -118,10 +138,10 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF (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 } END TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ let (t,l) = List.sep_last lt in field_lookup f lH l t ] + { let (t,l) = List.sep_last lt in field_lookup f lH l t } END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 0734654abf..85e759d152 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -205,25 +205,16 @@ let exec_tactic env evd n f args = let nf c = constr_of evd c in Array.map nf !tactic_res, Evd.universe_context_set evd -let stdlib_modules = - [["Coq";"Setoids";"Setoid"]; - ["Coq";"Lists";"List"]; - ["Coq";"Init";"Datatypes"]; - ["Coq";"Init";"Logic"]; - ] - -let coq_constant c = - lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" stdlib_modules c)) -let coq_reference c = - lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) - -let coq_mk_Setoid = coq_constant "Build_Setoid_Theory" -let coq_None = coq_reference "None" -let coq_Some = coq_reference "Some" -let coq_eq = coq_constant "eq" - -let coq_cons = coq_reference "cons" -let coq_nil = coq_reference "nil" +let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_global (Coqlib.lib_ref n))) +let gen_reference n = lazy (Coqlib.lib_ref n) + +let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_None = gen_reference "core.option.None" +let coq_Some = gen_reference "core.option.Some" +let coq_eq = gen_constant "core.eq.type" + +let coq_cons = gen_reference "core.list.cons" +let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) @@ -260,16 +251,18 @@ let plugin_modules = let my_constant c = lazy (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules "Ring" plugin_modules c)) + [@@ocaml.warning "-3"] let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) + [@@ocaml.warning "-3"] let znew_ring_path = DirPath.make (List.map Id.of_string ["InitialRing";plugin_dir;"Coq"]) let zltac s = lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s);; -let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s ;; +let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) @@ -907,7 +900,7 @@ let ftheory_to_obj : field_info -> obj = let field_equality evd r inv req = match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let c = UnivGen.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = UnivGen.constr_of_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> diff --git a/plugins/setoid_ring/plugin_base.dune b/plugins/setoid_ring/plugin_base.dune index 101246e28f..d83857edad 100644 --- a/plugins/setoid_ring/plugin_base.dune +++ b/plugins/setoid_ring/plugin_base.dune @@ -2,4 +2,4 @@ (name newring_plugin) (public_name coq.plugins.setoid_ring) (synopsis "Coq's setoid ring plugin") - (libraries coq.plugins.quote)) + (libraries coq.plugins.ltac)) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index f2f236f448..1492cfb4e4 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -201,8 +201,8 @@ let mkRInd mind = DAst.make @@ GRef (IndRef mind,None) let mkRLambda n s t = DAst.make @@ GLambda (n, Explicit, s, t) let rec mkRnat n = - if n <= 0 then DAst.make @@ GRef (Coqlib.glob_O, None) else - mkRApp (DAst.make @@ GRef (Coqlib.glob_S, None)) [mkRnat (n - 1)] + if n <= 0 then DAst.make @@ GRef (Coqlib.lib_ref "num.nat.O", None) else + mkRApp (DAst.make @@ GRef (Coqlib.lib_ref "num.nat.S", None)) [mkRnat (n - 1)] let glob_constr ist genv = function | _, Some ce -> @@ -763,7 +763,7 @@ let mkEtaApp c n imin = let mkRefl t c gl = let sigma = project gl in - let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.((build_coq_eq_data()).refl) in + let (sigma, refl) = EConstr.fresh_global (pf_env gl) sigma Coqlib.(lib_ref "core.eq.refl") in EConstr.mkApp (refl, [|t; c|]), { gl with sigma } let discharge_hyp (id', (id, mode)) gl = @@ -1220,7 +1220,7 @@ let genclrtac cl cs clr = (fun type_err gl -> tclTHEN (tclTHEN (Proofview.V82.of_tactic (Tactics.elim_type (EConstr.of_constr - (UnivGen.constr_of_global @@ Coqlib.build_coq_False ())))) (old_cleartac clr)) + (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.False.type"))))) (old_cleartac clr)) (fun gl -> raise type_err) gl)) (old_cleartac clr) @@ -1504,7 +1504,7 @@ let tclOPTION o d = let tacIS_INJECTION_CASE ?ty t = begin tclOPTION ty (tacTYPEOF t) >>= fun ty -> tacREDUCE_TO_QUANTIFIED_IND ty >>= fun ((mind,_),_) -> - tclUNIT (GlobRef.equal (GlobRef.IndRef mind) (Coqlib.build_coq_eq ())) + tclUNIT (Coqlib.check_ind_ref "core.eq.type" mind) end let tclWITHTOP tac = Goal.enter begin fun gl -> diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 602fcfcab5..7f9a9e125e 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -115,7 +115,7 @@ let ssrelim ?(ind=ref None) ?(is_case=false) deps what ?elim eqid elim_intro_tac let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in let eq = EConstr.of_constr eq in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) @@ -421,7 +421,7 @@ let injectl2rtac sigma c = match EConstr.kind sigma c with let is_injection_case c gl = let gl, cty = pfe_type_of gl c in let (mind,_), _ = pf_reduce_to_quantified_ind gl cty in - GlobRef.equal (IndRef mind) (Coqlib.build_coq_eq ()) + GlobRef.equal (IndRef mind) Coqlib.(lib_ref "core.eq.type") let perform_injection c gl = let gl, cty = pfe_type_of gl c in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 2af917b939..c04ced4ab4 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -130,7 +130,7 @@ let newssrcongrtac arg ist gl = let ssr_congr lr = EConstr.mkApp (arr, lr) in (* here thw two cases: simple equality or arrow *) let equality, _, eq_args, gl' = - let eq, gl = pf_fresh_global (Coqlib.build_coq_eq ()) gl in + let eq, gl = pf_fresh_global Coqlib.(lib_ref "core.eq.type") gl in pf_saturate gl (EConstr.of_constr eq) 3 in tclMATCH_GOAL (equality, gl') (fun gl' -> fs gl' (List.assoc 0 eq_args)) (fun ty -> congrtac (arg, Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) ty) ist) @@ -386,7 +386,7 @@ let rwcltac cl rdx dir sr gl = ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env (pf_env gl) (project gl) (snd sr))); let cvtac, rwtac, gl = if EConstr.Vars.closed0 (project gl) r' then - let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.build_coq_eq () in + let env, sigma, c, c_eq = pf_env gl, fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); match EConstr.kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with @@ -427,6 +427,7 @@ let rwcltac cl rdx dir sr gl = ;; +[@@@ocaml.warning "-3"] let lz_coq_prod = let prod = lazy (Coqlib.build_prod ()) in fun () -> Lazy.force prod @@ -438,7 +439,7 @@ let lz_setoid_relation = | _ -> let srel = try Some (UnivGen.constr_of_global @@ - Coqlib.coq_reference "Class_setoid" sdir "RewriteRelation") + Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in last_srel := (env, srel); srel @@ -484,7 +485,7 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.build_coq_True ())) then + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.True.type"))) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1dbacf0ff7..ce439d0497 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -149,6 +149,7 @@ let tac_case t = end (** [=> [: id]] ************************************************************) +[@@@ocaml.warning "-3"] let mk_abstract_id = let open Coqlib in let ssr_abstract_id = Summary.ref ~name:"SSR:abstractid" 0 in @@ -375,7 +376,7 @@ let elim_intro_tac ipats ?ist what eqid ssrelim is_rec clr = let rec gen_eq_tac () = Goal.enter begin fun g -> let sigma, env, concl = Goal.(sigma g, env g, concl g) in let sigma, eq = - EConstr.fresh_global env sigma (Coqlib.build_coq_eq ()) in + EConstr.fresh_global env sigma (Coqlib.lib_ref "core.eq.type") in let ctx, last = EConstr.decompose_prod_assum sigma concl in let args = match EConstr.kind_of_type sigma last with | Term.AtomicType (hd, args) -> diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.mlg index e4a0910673..8699b62c39 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.mlg @@ -10,12 +10,13 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +{ + let _vmcast = Constr.VMcast open Names open Pp open Pcoq open Ltac_plugin -open Genarg open Stdarg open Tacarg open Libnames @@ -61,7 +62,12 @@ let is_ssr_loaded () = (if CLexer.is_keyword "SsrSyntax_is_Imported" then ssr_loaded:=true; !ssr_loaded) +} + DECLARE PLUGIN "ssreflect_plugin" + +{ + (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; @@ -69,21 +75,31 @@ let frozen_lexer = CLexer.get_keyword_state () ;; let tacltop = (5,Notation_gram.E) let pr_ssrtacarg _ _ prt = prt tacltop -ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY pr_ssrtacarg -| [ "YouShouldNotTypeThis" ] -> [ CErrors.anomaly (Pp.str "Grammar placeholder match") ] + +} + +ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg } +| [ "YouShouldNotTypeThis" ] -> { CErrors.anomaly (Pp.str "Grammar placeholder match") } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; - ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> tac ]]; + ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; END +{ + (* Lexically closed tactic for tacticals. *) let pr_ssrtclarg _ _ prt tac = prt tacltop tac + +} + ARGUMENT EXTEND ssrtclarg TYPED AS ssrtacarg - PRINTED BY pr_ssrtclarg -| [ ssrtacarg(tac) ] -> [ tac ] + PRINTED BY { pr_ssrtclarg } +| [ ssrtacarg(tac) ] -> { tac } END +{ + open Genarg (** Adding a new uninterpreted generic argument type *) @@ -139,12 +155,15 @@ let intern_hyp ist (SsrHyp (loc, id) as hyp) = open Pcoq.Prim -ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY pr_ssrhyp - INTERPRETED BY interp_hyp - GLOBALIZED BY intern_hyp - | [ ident(id) ] -> [ SsrHyp (Loc.tag ~loc id) ] +} + +ARGUMENT EXTEND ssrhyp TYPED AS ssrhyprep PRINTED BY { pr_ssrhyp } + INTERPRETED BY { interp_hyp } + GLOBALIZED BY { intern_hyp } + | [ ident(id) ] -> { SsrHyp (Loc.tag ~loc id) } END +{ let pr_hoi = hoik pr_hyp let pr_ssrhoi _ _ _ = pr_hoi @@ -163,27 +182,33 @@ let interp_ssrhoi ist gl = function let s, id' = interp_wit wit_ident ist gl id in s, Id (SsrHyp (loc, id')) -ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY pr_ssrhoi - INTERPRETED BY interp_ssrhoi - GLOBALIZED BY intern_ssrhoi - | [ ident(id) ] -> [ Hyp (SsrHyp(Loc.tag ~loc id)) ] +} + +ARGUMENT EXTEND ssrhoi_hyp TYPED AS ssrhoirep PRINTED BY { pr_ssrhoi } + INTERPRETED BY { interp_ssrhoi } + GLOBALIZED BY { intern_ssrhoi } + | [ ident(id) ] -> { Hyp (SsrHyp(Loc.tag ~loc id)) } END -ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY pr_ssrhoi - INTERPRETED BY interp_ssrhoi - GLOBALIZED BY intern_ssrhoi - | [ ident(id) ] -> [ Id (SsrHyp(Loc.tag ~loc id)) ] +ARGUMENT EXTEND ssrhoi_id TYPED AS ssrhoirep PRINTED BY { pr_ssrhoi } + INTERPRETED BY { interp_ssrhoi } + GLOBALIZED BY { intern_ssrhoi } + | [ ident(id) ] -> { Id (SsrHyp(Loc.tag ~loc id)) } END +{ let pr_ssrhyps _ _ _ = pr_hyps -ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY pr_ssrhyps - INTERPRETED BY interp_hyps - | [ ssrhyp_list(hyps) ] -> [ check_hyps_uniq [] hyps; hyps ] +} + +ARGUMENT EXTEND ssrhyps TYPED AS ssrhyp list PRINTED BY { pr_ssrhyps } + INTERPRETED BY { interp_hyps } + | [ ssrhyp_list(hyps) ] -> { check_hyps_uniq [] hyps; hyps } END (** Rewriting direction *) +{ let pr_rwdir = function L2R -> mt() | R2L -> str "-" @@ -254,43 +279,46 @@ let test_ssrslashnum11 = let test_ssrslashnum01 = Pcoq.Gram.Entry.of_parser "test_ssrslashnum01" test_ssrslashnum01 +} -ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl -| [ "//=" ] -> [ SimplCut (~-1,~-1) ] -| [ "/=" ] -> [ Simpl ~-1 ] +ARGUMENT EXTEND ssrsimpl_ne TYPED AS ssrsimplrep PRINTED BY { pr_ssrsimpl } +| [ "//=" ] -> { SimplCut (~-1,~-1) } +| [ "/=" ] -> { Simpl ~-1 } END -Pcoq.(Prim.( -GEXTEND Gram +(* Pcoq.Prim. *) +GRAMMAR EXTEND Gram GLOBAL: ssrsimpl_ne; ssrsimpl_ne: [ - [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> SimplCut(n,m) - | test_ssrslashnum10; "/"; n = natural; "/" -> Cut n - | test_ssrslashnum10; "/"; n = natural; "=" -> Simpl n - | test_ssrslashnum10; "/"; n = natural; "/=" -> SimplCut (n,~-1) - | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> SimplCut (n,~-1) - | test_ssrslashnum01; "//"; m = natural; "=" -> SimplCut (~-1,m) - | test_ssrslashnum00; "//" -> Cut ~-1 + [ test_ssrslashnum11; "/"; n = natural; "/"; m = natural; "=" -> { SimplCut(n,m) } + | test_ssrslashnum10; "/"; n = natural; "/" -> { Cut n } + | test_ssrslashnum10; "/"; n = natural; "=" -> { Simpl n } + | test_ssrslashnum10; "/"; n = natural; "/=" -> { SimplCut (n,~-1) } + | test_ssrslashnum10; "/"; n = natural; "/"; "=" -> { SimplCut (n,~-1) } + | test_ssrslashnum01; "//"; m = natural; "=" -> { SimplCut (~-1,m) } + | test_ssrslashnum00; "//" -> { Cut ~-1 } ]]; END -)) -ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY pr_ssrsimpl -| [ ssrsimpl_ne(sim) ] -> [ sim ] -| [ ] -> [ Nop ] +ARGUMENT EXTEND ssrsimpl TYPED AS ssrsimplrep PRINTED BY { pr_ssrsimpl } +| [ ssrsimpl_ne(sim) ] -> { sim } +| [ ] -> { Nop } END +{ let pr_ssrclear _ _ _ = pr_clear mt -ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY pr_ssrclear -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ check_hyps_uniq [] clr; clr ] +} + +ARGUMENT EXTEND ssrclear_ne TYPED AS ssrhyps PRINTED BY { pr_ssrclear } +| [ "{" ne_ssrhyp_list(clr) "}" ] -> { check_hyps_uniq [] clr; clr } END -ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY pr_ssrclear -| [ ssrclear_ne(clr) ] -> [ clr ] -| [ ] -> [ [] ] +ARGUMENT EXTEND ssrclear TYPED AS ssrclear_ne PRINTED BY { pr_ssrclear } +| [ ssrclear_ne(clr) ] -> { clr } +| [ ] -> { [] } END (** Indexes *) @@ -301,6 +329,7 @@ END (* positive values, and allows the use of constr numerals, so that *) (* e.g., "let n := eval compute in (1 + 3) in (do n!clear)" works. *) +{ let pr_index = function | ArgVar {CAst.v=id} -> pr_id id @@ -342,9 +371,11 @@ let interp_index ist gl idx = open Pltac -ARGUMENT EXTEND ssrindex PRINTED BY pr_ssrindex - INTERPRETED BY interp_index -| [ int_or_var(i) ] -> [ mk_index ~loc i ] +} + +ARGUMENT EXTEND ssrindex PRINTED BY { pr_ssrindex } + INTERPRETED BY { interp_index } +| [ int_or_var(i) ] -> { mk_index ~loc i } END @@ -360,49 +391,61 @@ END (* default, but "{-}" prevents the implicit clear, and can be used to *) (* force dependent elimination -- see ndefectelimtac below. *) +{ let pr_ssrocc _ _ _ = pr_occ open Pcoq.Prim -ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY pr_ssrocc -| [ natural(n) natural_list(occ) ] -> [ - Some (false, List.map (check_index ~loc) (n::occ)) ] -| [ "-" natural_list(occ) ] -> [ Some (true, occ) ] -| [ "+" natural_list(occ) ] -> [ Some (false, occ) ] +} + +ARGUMENT EXTEND ssrocc TYPED AS (bool * int list) option PRINTED BY { pr_ssrocc } +| [ natural(n) natural_list(occ) ] -> { + Some (false, List.map (check_index ~loc) (n::occ)) } +| [ "-" natural_list(occ) ] -> { Some (true, occ) } +| [ "+" natural_list(occ) ] -> { Some (false, occ) } END (* modality *) +{ let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () let wit_ssrmmod = add_genarg "ssrmmod" pr_mmod let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssrmmod; - ssrmmod: [[ "!" -> Must | LEFTQMARK -> May | "?" -> May]]; + ssrmmod: [[ "!" -> { Must } | LEFTQMARK -> { May } | "?" -> { May } ]]; END (** Rewrite multiplier: !n ?n *) +{ + let pr_mult (n, m) = if n > 0 && m <> Once then int n ++ pr_mmod m else pr_mmod m let pr_ssrmult _ _ _ = pr_mult -ARGUMENT EXTEND ssrmult_ne TYPED AS int * ssrmmod PRINTED BY pr_ssrmult - | [ natural(n) ssrmmod(m) ] -> [ check_index ~loc n, m ] - | [ ssrmmod(m) ] -> [ notimes, m ] +} + +ARGUMENT EXTEND ssrmult_ne TYPED AS (int * ssrmmod) PRINTED BY { pr_ssrmult } + | [ natural(n) ssrmmod(m) ] -> { check_index ~loc n, m } + | [ ssrmmod(m) ] -> { notimes, m } END -ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY pr_ssrmult - | [ ssrmult_ne(m) ] -> [ m ] - | [ ] -> [ nomult ] +ARGUMENT EXTEND ssrmult TYPED AS ssrmult_ne PRINTED BY { pr_ssrmult } + | [ ssrmult_ne(m) ] -> { m } + | [ ] -> { nomult } END +{ + (** Discharge occ switch (combined occurrence / clear switch *) let pr_docc = function @@ -411,11 +454,15 @@ let pr_docc = function let pr_ssrdocc _ _ _ = pr_docc -ARGUMENT EXTEND ssrdocc TYPED AS ssrclear option * ssrocc PRINTED BY pr_ssrdocc -| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] -| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] +} + +ARGUMENT EXTEND ssrdocc TYPED AS (ssrclear option * ssrocc) PRINTED BY { pr_ssrdocc } +| [ "{" ssrocc(occ) "}" ] -> { mkocc occ } +| [ "{" ssrhyp_list(clr) "}" ] -> { mkclr clr } END +{ + (* Old kinds of terms *) let input_ssrtermkind strm = match Util.stream_nth 0 strm with @@ -458,90 +505,99 @@ let interp_ssrterm _ gl t = Tacmach.project gl, t open Pcoq.Constr +} + ARGUMENT EXTEND ssrterm - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_ssrterm SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "YouShouldNotTypeThis" constr(c) ] -> [ mk_lterm c ] + PRINTED BY { pr_ssrterm } + INTERPRETED BY { interp_ssrterm } + GLOBALIZED BY { glob_ssrterm } SUBSTITUTED BY { subst_ssrterm } + RAW_PRINTED BY { pr_ssrterm } + GLOB_PRINTED BY { pr_ssrterm } +| [ "YouShouldNotTypeThis" constr(c) ] -> { mk_lterm c } END - -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrterm; - ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> mk_term k c ]]; + ssrterm: [[ k = ssrtermkind; c = Pcoq.Constr.constr -> { mk_term k c } ]]; END (* New terms *) +{ + let pp_ast_closure_term _ _ _ = pr_ast_closure_term +} + ARGUMENT EXTEND ast_closure_term - PRINTED BY pp_ast_closure_term - INTERPRETED BY interp_ast_closure_term - GLOBALIZED BY glob_ast_closure_term - SUBSTITUTED BY subst_ast_closure_term - RAW_PRINTED BY pp_ast_closure_term - GLOB_PRINTED BY pp_ast_closure_term - | [ term_annotation(a) constr(c) ] -> [ mk_ast_closure_term a c ] + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) constr(c) ] -> { mk_ast_closure_term a c } END ARGUMENT EXTEND ast_closure_lterm - PRINTED BY pp_ast_closure_term - INTERPRETED BY interp_ast_closure_term - GLOBALIZED BY glob_ast_closure_term - SUBSTITUTED BY subst_ast_closure_term - RAW_PRINTED BY pp_ast_closure_term - GLOB_PRINTED BY pp_ast_closure_term - | [ term_annotation(a) lconstr(c) ] -> [ mk_ast_closure_term a c ] + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) lconstr(c) ] -> { mk_ast_closure_term a c } END (* Old Views *) +{ + let pr_view = pr_list mt (fun c -> str "/" ++ pr_term c) let pr_ssrbwdview _ _ _ = pr_view +} + ARGUMENT EXTEND ssrbwdview TYPED AS ssrterm list - PRINTED BY pr_ssrbwdview -| [ "YouShouldNotTypeThis" ] -> [ [] ] + PRINTED BY { pr_ssrbwdview } +| [ "YouShouldNotTypeThis" ] -> { [] } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrbwdview; ssrbwdview: [ - [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> [mk_term xNoFlag c] - | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> - (mk_term xNoFlag c) :: w ]]; + [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> { [mk_term xNoFlag c] } + | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrbwdview -> { + (mk_term xNoFlag c) :: w } ]]; END -) (* New Views *) +{ let pr_ssrfwdview _ _ _ = pr_view2 +} + ARGUMENT EXTEND ssrfwdview TYPED AS ast_closure_term list - PRINTED BY pr_ssrfwdview -| [ "YouShouldNotTypeThis" ] -> [ [] ] + PRINTED BY { pr_ssrfwdview } +| [ "YouShouldNotTypeThis" ] -> { [] } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrfwdview; ssrfwdview: [ [ test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr -> - [mk_ast_closure_term `None c] + { [mk_ast_closure_term `None c] } | test_not_ssrslashnum; "/"; c = Pcoq.Constr.constr; w = ssrfwdview -> - (mk_ast_closure_term `None c) :: w ]]; + { (mk_ast_closure_term `None c) :: w } ]]; END -) -(* }}} *) - (* ipats *) +{ let remove_loc x = x.CAst.v @@ -663,75 +719,79 @@ let pushIPatNoop = function | pats :: orpat -> (IPatNoop :: pats) :: orpat | [] -> [] -ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY pr_ssripats - INTERPRETED BY interp_ipats - GLOBALIZED BY intern_ipats - | [ "_" ] -> [ [IPatAnon Drop] ] - | [ "*" ] -> [ [IPatAnon All] ] +} + +ARGUMENT EXTEND ssripat TYPED AS ssripatrep list PRINTED BY { pr_ssripats } + INTERPRETED BY { interp_ipats } + GLOBALIZED BY { intern_ipats } + | [ "_" ] -> { [IPatAnon Drop] } + | [ "*" ] -> { [IPatAnon All] } (* - | [ "^" "*" ] -> [ [IPatFastMode] ] - | [ "^" "_" ] -> [ [IPatSeed `Wild] ] - | [ "^_" ] -> [ [IPatSeed `Wild] ] - | [ "^" "?" ] -> [ [IPatSeed `Anon] ] - | [ "^?" ] -> [ [IPatSeed `Anon] ] - | [ "^" ident(id) ] -> [ [IPatSeed (`Id(id,`Pre))] ] - | [ "^" "~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] - | [ "^~" ident(id) ] -> [ [IPatSeed (`Id(id,`Post))] ] + | [ "^" "*" ] -> { [IPatFastMode] } + | [ "^" "_" ] -> { [IPatSeed `Wild] } + | [ "^_" ] -> { [IPatSeed `Wild] } + | [ "^" "?" ] -> { [IPatSeed `Anon] } + | [ "^?" ] -> { [IPatSeed `Anon] } + | [ "^" ident(id) ] -> { [IPatSeed (`Id(id,`Pre))] } + | [ "^" "~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } + | [ "^~" ident(id) ] -> { [IPatSeed (`Id(id,`Post))] } *) - | [ ident(id) ] -> [ [IPatId id] ] - | [ "?" ] -> [ [IPatAnon One] ] + | [ ident(id) ] -> { [IPatId id] } + | [ "?" ] -> { [IPatAnon One] } (* TODO | [ "+" ] -> [ [IPatAnon Temporary] ] *) - | [ ssrsimpl_ne(sim) ] -> [ [IPatSimpl sim] ] - | [ ssrdocc(occ) "->" ] -> [ match occ with + | [ ssrsimpl_ne(sim) ] -> { [IPatSimpl sim] } + | [ ssrdocc(occ) "->" ] -> { match occ with | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, L2R)] - | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)]] - | [ ssrdocc(occ) "<-" ] -> [ match occ with + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, L2R)] } + | [ ssrdocc(occ) "<-" ] -> { match occ with | Some [], _ -> CErrors.user_err ~loc (str"occ_switch expected") | None, occ -> [IPatRewrite (occ, R2L)] - | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)]] - | [ ssrdocc(occ) ssrfwdview(v) ] -> [ match occ with + | Some clr, _ -> [IPatClear clr; IPatRewrite (allocc, R2L)] } + | [ ssrdocc(occ) ssrfwdview(v) ] -> { match occ with | Some [], _ -> [IPatView (true,v)] | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl;IPatView (false,v)] - | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") ] - | [ ssrdocc(occ) ] -> [ match occ with + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } + | [ ssrdocc(occ) ] -> { match occ with | Some cl, _ -> check_hyps_uniq [] cl; [IPatClear cl] - | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here")] - | [ "->" ] -> [ [IPatRewrite (allocc, L2R)] ] - | [ "<-" ] -> [ [IPatRewrite (allocc, R2L)] ] - | [ "-" ] -> [ [IPatNoop] ] - | [ "-/" "=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] - | [ "-/=" ] -> [ [IPatNoop;IPatSimpl(Simpl ~-1)] ] - | [ "-/" "/" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] - | [ "-//" ] -> [ [IPatNoop;IPatSimpl(Cut ~-1)] ] - | [ "-/" integer(n) "/" ] -> [ [IPatNoop;IPatSimpl(Cut n)] ] - | [ "-/" "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-//" "=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-//=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] ] - | [ "-/" integer(n) "/=" ] -> [ [IPatNoop;IPatSimpl(SimplCut (n,~-1))] ] + | _ -> CErrors.user_err ~loc (str"Only identifiers are allowed here") } + | [ "->" ] -> { [IPatRewrite (allocc, L2R)] } + | [ "<-" ] -> { [IPatRewrite (allocc, R2L)] } + | [ "-" ] -> { [IPatNoop] } + | [ "-/" "=" ] -> { [IPatNoop;IPatSimpl(Simpl ~-1)] } + | [ "-/=" ] -> { [IPatNoop;IPatSimpl(Simpl ~-1)] } + | [ "-/" "/" ] -> { [IPatNoop;IPatSimpl(Cut ~-1)] } + | [ "-//" ] -> { [IPatNoop;IPatSimpl(Cut ~-1)] } + | [ "-/" integer(n) "/" ] -> { [IPatNoop;IPatSimpl(Cut n)] } + | [ "-/" "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-//" "=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-//=" ] -> { [IPatNoop;IPatSimpl(SimplCut (~-1,~-1))] } + | [ "-/" integer(n) "/=" ] -> { [IPatNoop;IPatSimpl(SimplCut (n,~-1))] } | [ "-/" integer(n) "/" integer (m) "=" ] -> - [ [IPatNoop;IPatSimpl(SimplCut(n,m))] ] - | [ ssrfwdview(v) ] -> [ [IPatView (false,v)] ] - | [ "[" ":" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] - | [ "[:" ident_list(idl) "]" ] -> [ [IPatAbstractVars idl] ] + { [IPatNoop;IPatSimpl(SimplCut(n,m))] } + | [ ssrfwdview(v) ] -> { [IPatView (false,v)] } + | [ "[" ":" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } + | [ "[:" ident_list(idl) "]" ] -> { [IPatAbstractVars idl] } END -ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY pr_ssripats - | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] - | [ ] -> [ [] ] +ARGUMENT EXTEND ssripats TYPED AS ssripat PRINTED BY { pr_ssripats } + | [ ssripat(i) ssripats(tl) ] -> { i @ tl } + | [ ] -> { [] } END -ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY pr_ssriorpat -| [ ssripats(pats) "|" ssriorpat(orpat) ] -> [ pats :: orpat ] -| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] -| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> [ pats :: pushIPatNoop orpat ] -| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> [ pats :: pushIPatRewrite orpat ] -| [ ssripats(pats) "||" ssriorpat(orpat) ] -> [ pats :: [] :: orpat ] -| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> [ pats :: [] :: [] :: orpat ] -| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> [ [pats; []; []; []] @ orpat ] -| [ ssripats(pats) ] -> [ [pats] ] +ARGUMENT EXTEND ssriorpat TYPED AS ssripat list PRINTED BY { pr_ssriorpat } +| [ ssripats(pats) "|" ssriorpat(orpat) ] -> { pats :: orpat } +| [ ssripats(pats) "|-" ">" ssriorpat(orpat) ] -> { pats :: pushIPatRewrite orpat } +| [ ssripats(pats) "|-" ssriorpat(orpat) ] -> { pats :: pushIPatNoop orpat } +| [ ssripats(pats) "|->" ssriorpat(orpat) ] -> { pats :: pushIPatRewrite orpat } +| [ ssripats(pats) "||" ssriorpat(orpat) ] -> { pats :: [] :: orpat } +| [ ssripats(pats) "|||" ssriorpat(orpat) ] -> { pats :: [] :: [] :: orpat } +| [ ssripats(pats) "||||" ssriorpat(orpat) ] -> { [pats; []; []; []] @ orpat } +| [ ssripats(pats) ] -> { [pats] } END +{ + let reject_ssrhid strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "[" -> @@ -742,43 +802,44 @@ let reject_ssrhid strm = let test_nohidden = Pcoq.Gram.Entry.of_parser "test_ssrhid" reject_ssrhid -ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY pr_ssripat - | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> [ IPatCase(x) ] +} + +ARGUMENT EXTEND ssrcpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } + | [ "YouShouldNotTypeThis" ssriorpat(x) ] -> { IPatCase(x) } END -Pcoq.( -GEXTEND Gram +(* Pcoq *) +GRAMMAR EXTEND Gram GLOBAL: ssrcpat; ssrcpat: [ - [ test_nohidden; "["; iorpat = ssriorpat; "]" -> + [ test_nohidden; "["; iorpat = ssriorpat; "]" -> { (* check_no_inner_seed !@loc false iorpat; IPatCase (understand_case_type iorpat) *) - IPatCase iorpat + IPatCase iorpat } (* | test_nohidden; "("; iorpat = ssriorpat; ")" -> (* check_no_inner_seed !@loc false iorpat; IPatCase (understand_case_type iorpat) *) IPatDispatch iorpat *) - | test_nohidden; "[="; iorpat = ssriorpat; "]" -> + | test_nohidden; "[="; iorpat = ssriorpat; "]" -> { (* check_no_inner_seed !@loc false iorpat; *) - IPatInj iorpat ]]; + IPatInj iorpat } ]]; END -);; -Pcoq.( -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssripat; - ssripat: [[ pat = ssrcpat -> [pat] ]]; + ssripat: [[ pat = ssrcpat -> { [pat] } ]]; END -) -ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY pr_ssripats - | [ ssripat(i) ssripats(tl) ] -> [ i @ tl ] +ARGUMENT EXTEND ssripats_ne TYPED AS ssripat PRINTED BY { pr_ssripats } + | [ ssripat(i) ssripats(tl) ] -> { i @ tl } END (* subsets of patterns *) +{ + (* TODO: review what this function does, it looks suspicious *) let check_ssrhpats loc w_binders ipats = let err_loc s = CErrors.user_err ~loc ~hdr:"ssreflect" s in @@ -816,80 +877,97 @@ let pr_hpats (((clr, ipat), binders), simpl) = let pr_ssrhpats _ _ _ = pr_hpats let pr_ssrhpats_wtransp _ _ _ (_, x) = pr_hpats x -ARGUMENT EXTEND ssrhpats TYPED AS ((ssrclear * ssripat) * ssripat) * ssripat -PRINTED BY pr_ssrhpats - | [ ssripats(i) ] -> [ check_ssrhpats loc true i ] +} + +ARGUMENT EXTEND ssrhpats TYPED AS (((ssrclear * ssripat) * ssripat) * ssripat) +PRINTED BY { pr_ssrhpats } + | [ ssripats(i) ] -> { check_ssrhpats loc true i } END ARGUMENT EXTEND ssrhpats_wtransp - TYPED AS bool * (((ssrclear * ssripats) * ssripats) * ssripats) - PRINTED BY pr_ssrhpats_wtransp - | [ ssripats(i) ] -> [ false,check_ssrhpats loc true i ] - | [ ssripats(i) "@" ssripats(j) ] -> [ true,check_ssrhpats loc true (i @ j) ] + TYPED AS (bool * (((ssrclear * ssripats) * ssripats) * ssripats)) + PRINTED BY { pr_ssrhpats_wtransp } + | [ ssripats(i) ] -> { false,check_ssrhpats loc true i } + | [ ssripats(i) "@" ssripats(j) ] -> { true,check_ssrhpats loc true (i @ j) } END ARGUMENT EXTEND ssrhpats_nobs -TYPED AS ((ssrclear * ssripats) * ssripats) * ssripats PRINTED BY pr_ssrhpats - | [ ssripats(i) ] -> [ check_ssrhpats loc false i ] +TYPED AS (((ssrclear * ssripats) * ssripats) * ssripats) PRINTED BY { pr_ssrhpats } + | [ ssripats(i) ] -> { check_ssrhpats loc false i } END -ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY pr_ssripat - | [ "->" ] -> [ IPatRewrite (allocc, L2R) ] - | [ "<-" ] -> [ IPatRewrite (allocc, R2L) ] +ARGUMENT EXTEND ssrrpat TYPED AS ssripatrep PRINTED BY { pr_ssripat } + | [ "->" ] -> { IPatRewrite (allocc, L2R) } + | [ "<-" ] -> { IPatRewrite (allocc, R2L) } END +{ + let pr_intros sep intrs = if intrs = [] then mt() else sep () ++ str "=>" ++ pr_ipats intrs let pr_ssrintros _ _ _ = pr_intros mt +} + ARGUMENT EXTEND ssrintros_ne TYPED AS ssripat - PRINTED BY pr_ssrintros - | [ "=>" ssripats_ne(pats) ] -> [ pats ] -(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] + PRINTED BY { pr_ssrintros } + | [ "=>" ssripats_ne(pats) ] -> { pats } +(* TODO | [ "=>" ">" ssripats_ne(pats) ] -> { IPatFastMode :: pats } | [ "=>>" ssripats_ne(pats) ] -> [ IPatFastMode :: pats ] *) END -ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY pr_ssrintros - | [ ssrintros_ne(intrs) ] -> [ intrs ] - | [ ] -> [ [] ] +ARGUMENT EXTEND ssrintros TYPED AS ssrintros_ne PRINTED BY { pr_ssrintros } + | [ ssrintros_ne(intrs) ] -> { intrs } + | [ ] -> { [] } END +{ + let pr_ssrintrosarg _ _ prt (tac, ipats) = prt tacltop tac ++ pr_intros spc ipats -ARGUMENT EXTEND ssrintrosarg TYPED AS tactic * ssrintros - PRINTED BY pr_ssrintrosarg -| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> [ arg, ipats ] +} + +ARGUMENT EXTEND ssrintrosarg TYPED AS (tactic * ssrintros) + PRINTED BY { pr_ssrintrosarg } +| [ "YouShouldNotTypeThis" ssrtacarg(arg) ssrintros_ne(ipats) ] -> { arg, ipats } END TACTIC EXTEND ssrtclintros | [ "YouShouldNotTypeThis" ssrintrosarg(arg) ] -> - [ let tac, intros = arg in - ssrevaltac ist tac <*> tclIPATssr intros ] + { let tac, intros = arg in + ssrevaltac ist tac <*> tclIPATssr intros } END +{ + (** Defined identifier *) let pr_ssrfwdid id = pr_spc () ++ pr_id id let pr_ssrfwdidx _ _ _ = pr_ssrfwdid +} + (* We use a primitive parser for the head identifier of forward *) (* tactis to avoid syntactic conflicts with basic Coq tactics. *) -ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY pr_ssrfwdidx - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssrfwdid TYPED AS ident PRINTED BY { pr_ssrfwdidx } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let accept_ssrfwdid strm = match stream_nth 0 strm with | Tok.IDENT id -> accept_before_syms_or_any_id [":"; ":="; "("] strm | _ -> raise Stream.Failure - let test_ssrfwdid = Gram.Entry.of_parser "test_ssrfwdid" accept_ssrfwdid -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssrfwdid; - ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> id ]]; + ssrfwdid: [[ test_ssrfwdid; id = Prim.ident -> { id } ]]; END @@ -900,6 +978,7 @@ GEXTEND Gram (* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) (* and subgoal reordering tacticals (; first & ; last), respectively. *) +{ let pr_ortacs prt = let rec pr_rec = function @@ -914,14 +993,18 @@ let pr_ortacs prt = | [] -> mt() let pr_ssrortacs _ _ = pr_ortacs -ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY pr_ssrortacs -| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> [ Some tac :: tacs ] -| [ ssrtacarg(tac) "|" ] -> [ [Some tac; None] ] -| [ ssrtacarg(tac) ] -> [ [Some tac] ] -| [ "|" ssrortacs(tacs) ] -> [ None :: tacs ] -| [ "|" ] -> [ [None; None] ] +} + +ARGUMENT EXTEND ssrortacs TYPED AS tactic option list PRINTED BY { pr_ssrortacs } +| [ ssrtacarg(tac) "|" ssrortacs(tacs) ] -> { Some tac :: tacs } +| [ ssrtacarg(tac) "|" ] -> { [Some tac; None] } +| [ ssrtacarg(tac) ] -> { [Some tac] } +| [ "|" ssrortacs(tacs) ] -> { None :: tacs } +| [ "|" ] -> { [None; None] } END +{ + let pr_hintarg prt = function | true, tacs -> hv 0 (str "[ " ++ pr_ortacs prt tacs ++ str " ]") | false, [Some tac] -> prt tacltop tac @@ -929,26 +1012,30 @@ let pr_hintarg prt = function let pr_ssrhintarg _ _ = pr_hintarg +} -ARGUMENT EXTEND ssrhintarg TYPED AS bool * ssrortacs PRINTED BY pr_ssrhintarg -| [ "[" "]" ] -> [ nullhint ] -| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] -| [ ssrtacarg(arg) ] -> [ mk_hint arg ] +ARGUMENT EXTEND ssrhintarg TYPED AS (bool * ssrortacs) PRINTED BY { pr_ssrhintarg } +| [ "[" "]" ] -> { nullhint } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } +| [ ssrtacarg(arg) ] -> { mk_hint arg } END -ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY pr_ssrhintarg -| [ "[" ssrortacs(tacs) "]" ] -> [ mk_orhint tacs ] +ARGUMENT EXTEND ssrortacarg TYPED AS ssrhintarg PRINTED BY { pr_ssrhintarg } +| [ "[" ssrortacs(tacs) "]" ] -> { mk_orhint tacs } END +{ let pr_hint prt arg = if arg = nohint then mt() else str "by " ++ pr_hintarg prt arg let pr_ssrhint _ _ = pr_hint -ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY pr_ssrhint -| [ ] -> [ nohint ] +} + +ARGUMENT EXTEND ssrhint TYPED AS ssrhintarg PRINTED BY { pr_ssrhint } +| [ ] -> { nohint } END -(** The "in" pseudo-tactical *)(* {{{ **********************************************) +(** The "in" pseudo-tactical *) (* We can't make "in" into a general tactical because this would create a *) (* crippling conflict with the ltac let .. in construct. Hence, we add *) @@ -961,6 +1048,8 @@ END (* assumptions. This is especially difficult for discharged "let"s, which *) (* the default simpl and unfold tactics would erase blindly. *) +{ + open Ssrmatching_plugin.Ssrmatching open Ssrmatching_plugin.G_ssrmatching @@ -972,22 +1061,26 @@ let pr_wgen = function | (clr, None) -> spc () ++ pr_clear mt clr let pr_ssrwgen _ _ _ = pr_wgen +} + (* no globwith for char *) ARGUMENT EXTEND ssrwgen - TYPED AS ssrclear * ((ssrhoi_hyp * string) * cpattern option) option - PRINTED BY pr_ssrwgen -| [ ssrclear_ne(clr) ] -> [ clr, None ] -| [ ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, " "), None) ] -| [ "@" ssrhoi_hyp(hyp) ] -> [ [], Some((hyp, "@"), None) ] + TYPED AS (ssrclear * ((ssrhoi_hyp * string) * cpattern option) option) + PRINTED BY { pr_ssrwgen } +| [ ssrclear_ne(clr) ] -> { clr, None } +| [ ssrhoi_hyp(hyp) ] -> { [], Some((hyp, " "), None) } +| [ "@" ssrhoi_hyp(hyp) ] -> { [], Some((hyp, "@"), None) } | [ "(" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id," "),Some p) ] -| [ "(" ssrhoi_id(id) ")" ] -> [ [], Some ((id,"("), None) ] + { [], Some ((id," "),Some p) } +| [ "(" ssrhoi_id(id) ")" ] -> { [], Some ((id,"("), None) } | [ "(@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id,"@"),Some p) ] + { [], Some ((id,"@"),Some p) } | [ "(" "@" ssrhoi_id(id) ":=" lcpattern(p) ")" ] -> - [ [], Some ((id,"@"),Some p) ] + { [], Some ((id,"@"),Some p) } END +{ + let pr_clseq = function | InGoal | InHyps -> mt () | InSeqGoal -> str "|- *" @@ -1001,13 +1094,17 @@ let wit_ssrclseq = add_genarg "ssrclseq" pr_clseq let pr_clausehyps = pr_list pr_spc pr_wgen let pr_ssrclausehyps _ _ _ = pr_clausehyps +} + ARGUMENT EXTEND ssrclausehyps -TYPED AS ssrwgen list PRINTED BY pr_ssrclausehyps -| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> [ hyp :: hyps ] -| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> [ hyp :: hyps ] -| [ ssrwgen(hyp) ] -> [ [hyp] ] +TYPED AS ssrwgen list PRINTED BY { pr_ssrclausehyps } +| [ ssrwgen(hyp) "," ssrclausehyps(hyps) ] -> { hyp :: hyps } +| [ ssrwgen(hyp) ssrclausehyps(hyps) ] -> { hyp :: hyps } +| [ ssrwgen(hyp) ] -> { [hyp] } END +{ + (* type ssrclauses = ssrahyps * ssrclseq *) let pr_clauses (hyps, clseq) = @@ -1015,20 +1112,22 @@ let pr_clauses (hyps, clseq) = else str "in " ++ pr_clausehyps hyps ++ pr_clseq clseq let pr_ssrclauses _ _ _ = pr_clauses -ARGUMENT EXTEND ssrclauses TYPED AS ssrwgen list * ssrclseq - PRINTED BY pr_ssrclauses - | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> [ hyps, InHypsSeqGoal ] - | [ "in" ssrclausehyps(hyps) "|-" ] -> [ hyps, InHypsSeq ] - | [ "in" ssrclausehyps(hyps) "*" ] -> [ hyps, InHypsGoal ] - | [ "in" ssrclausehyps(hyps) ] -> [ hyps, InHyps ] - | [ "in" "|-" "*" ] -> [ [], InSeqGoal ] - | [ "in" "*" ] -> [ [], InAll ] - | [ "in" "*" "|-" ] -> [ [], InAllHyps ] - | [ ] -> [ [], InGoal ] -END +} +ARGUMENT EXTEND ssrclauses TYPED AS (ssrwgen list * ssrclseq) + PRINTED BY { pr_ssrclauses } + | [ "in" ssrclausehyps(hyps) "|-" "*" ] -> { hyps, InHypsSeqGoal } + | [ "in" ssrclausehyps(hyps) "|-" ] -> { hyps, InHypsSeq } + | [ "in" ssrclausehyps(hyps) "*" ] -> { hyps, InHypsGoal } + | [ "in" ssrclausehyps(hyps) ] -> { hyps, InHyps } + | [ "in" "|-" "*" ] -> { [], InSeqGoal } + | [ "in" "*" ] -> { [], InAll } + | [ "in" "*" "|-" ] -> { [], InAllHyps } + | [ ] -> { [], InGoal } +END +{ (** Definition value formatting *) @@ -1142,10 +1241,12 @@ let pr_unguarded prc prlc = prlc let pr_fwd = pr_fwd_guarded pr_unguarded pr_unguarded let pr_ssrfwd _ _ _ = pr_fwd - -ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ast_closure_lterm) PRINTED BY pr_ssrfwd - | [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdPose c ] - | [ ":" ast_closure_lterm (t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdPose ~loc t ~c ] + +} + +ARGUMENT EXTEND ssrfwd TYPED AS (ssrfwdfmt * ast_closure_lterm) PRINTED BY { pr_ssrfwd } + | [ ":=" ast_closure_lterm(c) ] -> { mkFwdVal FwdPose c } + | [ ":" ast_closure_lterm (t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdPose ~loc t ~c } END (** Independent parsing for binders *) @@ -1153,13 +1254,19 @@ END (* The pose, pose fix, and pose cofix tactics use these internally to *) (* parse argument fragments. *) +{ + let pr_ssrbvar prc _ _ v = prc v -ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY pr_ssrbvar -| [ ident(id) ] -> [ mkCVar ~loc id ] -| [ "_" ] -> [ mkCHole (Some loc) ] +} + +ARGUMENT EXTEND ssrbvar TYPED AS constr PRINTED BY { pr_ssrbvar } +| [ ident(id) ] -> { mkCVar ~loc id } +| [ "_" ] -> { mkCHole (Some loc) } END +{ + let bvar_lname = let open CAst in function | { v = CRef (qid, _) } when qualid_is_ident qid -> CAst.make ?loc:qid.CAst.loc @@ Name (qualid_basename qid) @@ -1167,40 +1274,43 @@ let bvar_lname = let open CAst in function let pr_ssrbinder prc _ _ (_, c) = prc c -ARGUMENT EXTEND ssrbinder TYPED AS ssrfwdfmt * constr PRINTED BY pr_ssrbinder +} + +ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinder } | [ ssrbvar(bv) ] -> - [ let { CAst.loc=xloc } as x = bvar_lname bv in + { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ")" ] -> - [ let { CAst.loc=xloc } as x = bvar_lname bv in + { let { CAst.loc=xloc } as x = bvar_lname bv in (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x],Default Explicit,mkCHole xloc)],mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ":" lconstr(t) ")" ] -> - [ let x = bvar_lname bv in + { let x = bvar_lname bv in (FwdPose, [BFdecl 1]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum([x], Default Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(bv) ne_ssrbvar_list(bvs) ":" lconstr(t) ")" ] -> - [ let xs = List.map bvar_lname (bv :: bvs) in + { let xs = List.map bvar_lname (bv :: bvs) in let n = List.length xs in (FwdPose, [BFdecl n]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum (xs, Default Explicit, t)], mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":" lconstr(t) ":=" lconstr(v) ")" ] -> - [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) ] + { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, Some t, mkCHole (Some loc)) } | [ "(" ssrbvar(id) ":=" lconstr(v) ")" ] -> - [ (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) ] + { (FwdPose,[BFdef]), CAst.make ~loc @@ CLetIn (bvar_lname id, v, None, mkCHole (Some loc)) } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrbinder; ssrbinder: [ - [ ["of" | "&"]; c = operconstr LEVEL "99" -> - let loc = !@loc in + [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { (FwdPose, [BFvar]), - CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) ] + CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Explicit,c)],mkCHole (Some loc)) } ] ]; END +{ + let rec binders_fmts = function | ((_, h), _) :: bs -> h @ binders_fmts bs | _ -> [] @@ -1233,24 +1343,32 @@ let pr_ssrstruct _ _ _ = function | Some id -> str "{struct " ++ pr_id id ++ str "}" | None -> mt () -ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY pr_ssrstruct -| [ "{" "struct" ident(id) "}" ] -> [ Some id ] -| [ ] -> [ None ] +} + +ARGUMENT EXTEND ssrstruct TYPED AS ident option PRINTED BY { pr_ssrstruct } +| [ "{" "struct" ident(id) "}" ] -> { Some id } +| [ ] -> { None } END (** The "pose" tactic *) (* The plain pose form. *) +{ + let bind_fwd bs ((fk, h), c) = (fk,binders_fmts bs @ h), { c with body = push_binders c.body bs } -ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY pr_ssrfwd - | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> [ bind_fwd bs fwd ] +} + +ARGUMENT EXTEND ssrposefwd TYPED AS ssrfwd PRINTED BY { pr_ssrfwd } + | [ ssrbinder_list(bs) ssrfwd(fwd) ] -> { bind_fwd bs fwd } END (* The pose fix form. *) +{ + let pr_ssrfixfwd _ _ _ (id, fwd) = str " fix " ++ pr_id id ++ pr_fwd fwd let bvar_locid = function @@ -1258,10 +1376,11 @@ let bvar_locid = function CAst.make ?loc:qid.CAst.loc (qualid_basename qid) | _ -> CErrors.user_err (Pp.str "Missing identifier after \"(co)fix\"") +} -ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd +ARGUMENT EXTEND ssrfixfwd TYPED AS (ident * ssrfwd) PRINTED BY { pr_ssrfixfwd } | [ "fix" ssrbvar(bv) ssrbinder_list(bs) ssrstruct(sid) ssrfwd(fwd) ] -> - [ let { CAst.v=id } as lid = bvar_locid bv in + { let { CAst.v=id } as lid = bvar_locid bv in let (fk, h), ac = fwd in let c = ac.body in let has_cast, t', c' = match format_constr_expr h c with @@ -1279,17 +1398,21 @@ ARGUMENT EXTEND ssrfixfwd TYPED AS ident * ssrfwd PRINTED BY pr_ssrfixfwd loop (names_of_local_assums lb) in let h' = BFrec (has_struct, has_cast) :: binders_fmts bs in let fix = CAst.make ~loc @@ CFix (lid, [lid, (Some i, CStructRec), lb, t', c']) in - id, ((fk, h'), { ac with body = fix }) ] + id, ((fk, h'), { ac with body = fix }) } END (* The pose cofix form. *) +{ + let pr_ssrcofixfwd _ _ _ (id, fwd) = str " cofix " ++ pr_id id ++ pr_fwd fwd -ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd +} + +ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY { pr_ssrcofixfwd } | [ "cofix" ssrbvar(bv) ssrbinder_list(bs) ssrfwd(fwd) ] -> - [ let { CAst.v=id } as lid = bvar_locid bv in + { let { CAst.v=id } as lid = bvar_locid bv in let (fk, h), ac = fwd in let c = ac.body in let has_cast, t', c' = match format_constr_expr h c with @@ -1298,36 +1421,45 @@ ARGUMENT EXTEND ssrcofixfwd TYPED AS ssrfixfwd PRINTED BY pr_ssrcofixfwd let h' = BFrec (false, has_cast) :: binders_fmts bs in let cofix = CAst.make ~loc @@ CCoFix (lid, [lid, fix_binders bs, t', c']) in id, ((fk, h'), { ac with body = cofix }) - ] + } END +{ + (* This does not print the type, it should be fixed... *) let pr_ssrsetfwd _ _ _ (((fk,_),(t,_)), docc) = pr_gen_fwd (fun _ _ -> pr_cpattern) (fun _ -> mt()) (fun _ -> mt()) fk ([Bcast ()],t) +} + ARGUMENT EXTEND ssrsetfwd -TYPED AS (ssrfwdfmt * (lcpattern * ast_closure_lterm option)) * ssrdocc -PRINTED BY pr_ssrsetfwd +TYPED AS ((ssrfwdfmt * (lcpattern * ast_closure_lterm option)) * ssrdocc) +PRINTED BY { pr_ssrsetfwd } | [ ":" ast_closure_lterm(t) ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> - [ mkssrFwdCast FwdPose loc t c, mkocc occ ] + { mkssrFwdCast FwdPose loc t c, mkocc occ } | [ ":" ast_closure_lterm(t) ":=" lcpattern(c) ] -> - [ mkssrFwdCast FwdPose loc t c, nodocc ] + { mkssrFwdCast FwdPose loc t c, nodocc } | [ ":=" "{" ssrocc(occ) "}" cpattern(c) ] -> - [ mkssrFwdVal FwdPose c, mkocc occ ] -| [ ":=" lcpattern(c) ] -> [ mkssrFwdVal FwdPose c, nodocc ] + { mkssrFwdVal FwdPose c, mkocc occ } +| [ ":=" lcpattern(c) ] -> { mkssrFwdVal FwdPose c, nodocc } END +{ let pr_ssrhavefwd _ _ prt (fwd, hint) = pr_fwd fwd ++ pr_hint prt hint -ARGUMENT EXTEND ssrhavefwd TYPED AS ssrfwd * ssrhint PRINTED BY pr_ssrhavefwd -| [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> [ mkFwdHint ":" t, hint ] -| [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> [ mkFwdCast FwdHave ~loc t ~c, nohint ] -| [ ":" ast_closure_lterm(t) ":=" ] -> [ mkFwdHintNoTC ":" t, nohint ] -| [ ":=" ast_closure_lterm(c) ] -> [ mkFwdVal FwdHave c, nohint ] +} + +ARGUMENT EXTEND ssrhavefwd TYPED AS (ssrfwd * ssrhint) PRINTED BY { pr_ssrhavefwd } +| [ ":" ast_closure_lterm(t) ssrhint(hint) ] -> { mkFwdHint ":" t, hint } +| [ ":" ast_closure_lterm(t) ":=" ast_closure_lterm(c) ] -> { mkFwdCast FwdHave ~loc t ~c, nohint } +| [ ":" ast_closure_lterm(t) ":=" ] -> { mkFwdHintNoTC ":" t, nohint } +| [ ":=" ast_closure_lterm(c) ] -> { mkFwdVal FwdHave c, nohint } END +{ + let intro_id_to_binder = List.map (function | IPatId id -> let { CAst.loc=xloc } as x = bvar_lname (mkCVar id) in @@ -1347,28 +1479,35 @@ let binder_to_intro_id = CAst.(List.map (function let pr_ssrhavefwdwbinders _ _ prt (tr,((hpats, (fwd, hint)))) = pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +} + ARGUMENT EXTEND ssrhavefwdwbinders - TYPED AS bool * (ssrhpats * (ssrfwd * ssrhint)) - PRINTED BY pr_ssrhavefwdwbinders + TYPED AS (bool * (ssrhpats * (ssrfwd * ssrhint))) + PRINTED BY { pr_ssrhavefwdwbinders } | [ ssrhpats_wtransp(trpats) ssrbinder_list(bs) ssrhavefwd(fwd) ] -> - [ let tr, pats = trpats in + { let tr, pats = trpats in let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in let allbinders = binders @ List.flatten (binder_to_intro_id bs) in let hint = bind_fwd allbs (fst fwd), snd fwd in - tr, ((((clr, pats), allbinders), simpl), hint) ] + tr, ((((clr, pats), allbinders), simpl), hint) } END +{ let pr_ssrdoarg prc _ prt (((n, m), tac), clauses) = pr_index n ++ pr_mmod m ++ pr_hintarg prt tac ++ pr_clauses clauses +} + ARGUMENT EXTEND ssrdoarg - TYPED AS ((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses - PRINTED BY pr_ssrdoarg -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] + TYPED AS (((ssrindex * ssrmmod) * ssrhintarg) * ssrclauses) + PRINTED BY { pr_ssrdoarg } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + (* type ssrseqarg = ssrindex * (ssrtacarg * ssrtac option) *) let pr_seqtacarg prt = function @@ -1381,13 +1520,17 @@ let pr_ssrseqarg _ _ prt = function | ArgArg 0, tac -> pr_seqtacarg prt tac | i, tac -> pr_index i ++ str " " ++ pr_seqtacarg prt tac +} + (* We must parse the index separately to resolve the conflict with *) (* an unindexed tactic. *) -ARGUMENT EXTEND ssrseqarg TYPED AS ssrindex * (ssrhintarg * tactic option) - PRINTED BY pr_ssrseqarg -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssrseqarg TYPED AS (ssrindex * (ssrhintarg * tactic option)) + PRINTED BY { pr_ssrseqarg } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let sq_brace_tacnames = ["first"; "solve"; "do"; "rewrite"; "have"; "suffices"; "wlog"] (* "by" is a keyword *) @@ -1409,35 +1552,45 @@ let check_seqtacarg dir arg = match snd arg, dir with | _, _ -> arg let ssrorelse = Entry.create "ssrorelse" -GEXTEND Gram + +} + +GRAMMAR EXTEND Gram GLOBAL: ssrorelse ssrseqarg; ssrseqidx: [ - [ test_ssrseqvar; id = Prim.ident -> ArgVar (CAst.make ~loc:!@loc id) - | n = Prim.natural -> ArgArg (check_index ~loc:!@loc n) + [ test_ssrseqvar; id = Prim.ident -> { ArgVar (CAst.make ~loc id) } + | n = Prim.natural -> { ArgArg (check_index ~loc n) } ] ]; - ssrswap: [[ IDENT "first" -> !@loc, true | IDENT "last" -> !@loc, false ]]; - ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> tac ]]; + ssrswap: [[ IDENT "first" -> { loc, true } | IDENT "last" -> { loc, false } ]]; + ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> { tac } ]]; ssrseqarg: [ - [ arg = ssrswap -> noindex, swaptacarg arg - | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> i, (tac, def) - | i = ssrseqidx; arg = ssrswap -> i, swaptacarg arg - | tac = tactic_expr LEVEL "3" -> noindex, (mk_hint tac, None) + [ arg = ssrswap -> { noindex, swaptacarg arg } + | i = ssrseqidx; tac = ssrortacarg; def = OPT ssrorelse -> { i, (tac, def) } + | i = ssrseqidx; arg = ssrswap -> { i, swaptacarg arg } + | tac = tactic_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } ] ]; END +{ + let tactic_expr = Pltac.tactic_expr +} + (** 1. Utilities *) (** Tactic-level diagnosis *) (* debug *) +{ + (* Let's play with the new proof engine API *) let old_tac = V82.tactic +} -(** Name generation *)(* {{{ *******************************************************) +(** Name generation *) (* Since Coq now does repeated internal checks of its external lexical *) (* rules, we now need to carve ssreflect reserved identifiers out of *) @@ -1448,6 +1601,8 @@ let old_tac = V82.tactic (* when the ssreflect Module is present this is normally an error, *) (* but we provide a compatibility flag to reduce this to a warning. *) +{ + let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true let _ = @@ -1475,21 +1630,23 @@ let ssr_id_of_string loc s = let ssr_null_entry = Gram.Entry.of_parser "ssr_null" (fun _ -> ()) -let (!@) = Pcoq.to_coqloc +} -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: Prim.ident; - Prim.ident: [[ s = IDENT; ssr_null_entry -> ssr_id_of_string !@loc s ]]; + Prim.ident: [[ s = IDENT; ssr_null_entry -> { ssr_id_of_string loc s } ]]; END +{ + let perm_tag = "_perm_Hyp_" let _ = add_internal_name (is_tagged perm_tag) - -(* }}} *) + +} (* We must not anonymize context names discharged by the "in" tactical. *) -(** Tactical extensions. *)(* {{{ **************************************************) +(** Tactical extensions. *) (* The TACTIC EXTEND facility can't be used for defining new user *) (* tacticals, because: *) @@ -1499,6 +1656,8 @@ let _ = add_internal_name (is_tagged perm_tag) (* don't start with a token, then redefine the grammar and *) (* printer using GEXTEND and set_pr_ssrtac, respectively. *) +{ + type ssrargfmt = ArgSsr of string | ArgSep of string let ssrtac_name name = { @@ -1525,15 +1684,15 @@ let tclintros_expr ?loc tac ipats = let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in ssrtac_expr ?loc "tclintros" args -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> tclintros_expr ~loc:!@loc tac intros + [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; END -(* }}} *) - (** Bracketing tactical *) @@ -1543,10 +1702,10 @@ END (* expressions so that the pretty-print always reflects the input. *) (* (Removing user-specified parentheses is dubious anyway). *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> Loc.tag ~loc:!@loc (Tacexp tac) ]]; - tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> TacArg arg ]]; + ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { Loc.tag ~loc (Tacexp tac) } ]]; + tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END (** The internal "done" and "ssrautoprop" tactics. *) @@ -1558,6 +1717,8 @@ END (* to allow for user extensions. "ssrautoprop" defaults to *) (* trivial. *) +{ + let ssrautoprop gl = try let tacname = @@ -1584,17 +1745,18 @@ let tclBY tac = Tacticals.tclTHEN tac (donetac ~-1) open Ssrfwd +} + TACTIC EXTEND ssrtclby -| [ "by" ssrhintarg(tac) ] -> [ V82.tactic (hinttac ist true tac) ] +| [ "by" ssrhintarg(tac) ] -> { V82.tactic (hinttac ist true tac) } END -(* }}} *) (* We can't parse "by" in ARGUMENT EXTEND because it will only be made *) (* into a keyword in ssreflect.v; so we anticipate this in GEXTEND. *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrhint simple_tactic; - ssrhint: [[ "by"; arg = ssrhintarg -> arg ]]; + ssrhint: [[ "by"; arg = ssrhintarg -> { arg } ]]; END (** The "do" tactical. ********************************************************) @@ -1603,32 +1765,37 @@ END type ssrdoarg = ((ssrindex * ssrmmod) * ssrhint) * ssrclauses *) TACTIC EXTEND ssrtcldo -| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> [ V82.tactic (ssrdotac ist arg) ] +| [ "YouShouldNotTypeThis" "do" ssrdoarg(arg) ] -> { V82.tactic (ssrdotac ist arg) } END -set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] + +{ + +let _ = set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] let ssrdotac_expr ?loc n m tac clauses = let arg = ((n, m), tac), clauses in ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; ssrdotac: [ - [ tac = tactic_expr LEVEL "3" -> mk_hint tac - | tacs = ssrortacarg -> tacs + [ tac = tactic_expr LEVEL "3" -> { mk_hint tac } + | tacs = ssrortacarg -> { tacs } ] ]; tactic_expr: LEVEL "3" [ RIGHTA [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc noindex m tac clauses + { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc noindex Once tac clauses + { ssrdotac_expr ~loc noindex Once tac clauses } | IDENT "do"; n = int_or_var; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> - ssrdotac_expr ~loc:!@loc (mk_index ~loc:!@loc n) m tac clauses + { ssrdotac_expr ~loc (mk_index ~loc n) m tac clauses } ] ]; END -(* }}} *) +{ (* We can't actually parse the direction separately because this *) (* would introduce conflicts with the basic ltac syntax. *) @@ -1636,15 +1803,20 @@ let pr_ssrseqdir _ _ _ = function | L2R -> str ";" ++ spc () ++ str "first " | R2L -> str ";" ++ spc () ++ str "last " -ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY pr_ssrseqdir -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrseqdir TYPED AS ssrdir PRINTED BY { pr_ssrseqdir } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END TACTIC EXTEND ssrtclseq | [ "YouShouldNotTypeThis" ssrtclarg(tac) ssrseqdir(dir) ssrseqarg(arg) ] -> - [ V82.tactic (tclSEQAT ist tac dir arg) ] + { V82.tactic (tclSEQAT ist tac dir arg) } END -set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] + +{ + +let _ = set_pr_ssrtac "tclseq" 5 [ArgSsr "tclarg"; ArgSsr "seqdir"; ArgSsr "seqarg"] let tclseq_expr ?loc tac dir arg = let arg1 = in_gen (rawwit wit_ssrtclarg) tac in @@ -1652,25 +1824,26 @@ let tclseq_expr ?loc tac dir arg = let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; ssr_first: [ - [ tac = ssr_first; ipats = ssrintros_ne -> tclintros_expr ~loc:!@loc tac ipats - | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> TacFirst tacl + [ tac = ssr_first; ipats = ssrintros_ne -> { tclintros_expr ~loc tac ipats } + | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> { TacFirst tacl } ] ]; ssr_first_else: [ - [ tac1 = ssr_first; tac2 = ssrorelse -> TacOrelse (tac1, tac2) - | tac = ssr_first -> tac ]]; + [ tac1 = ssr_first; tac2 = ssrorelse -> { TacOrelse (tac1, tac2) } + | tac = ssr_first -> { tac } ]]; tactic_expr: LEVEL "4" [ LEFTA [ tac1 = tactic_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> - TacThen (tac1, tac2) + { TacThen (tac1, tac2) } | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> - tclseq_expr ~loc:!@loc tac L2R arg + { tclseq_expr ~loc tac L2R arg } | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> - tclseq_expr ~loc:!@loc tac R2L arg + { tclseq_expr ~loc tac R2L arg } ] ]; END -(* }}} *) (** 5. Bookkeeping tactics (clear, move, case, elim) *) @@ -1680,18 +1853,24 @@ END (* type ssrgen = ssrdocc * ssrterm *) +{ + let pr_gen (docc, dt) = pr_docc docc ++ pr_cpattern dt let pr_ssrgen _ _ _ = pr_gen -ARGUMENT EXTEND ssrgen TYPED AS ssrdocc * cpattern PRINTED BY pr_ssrgen -| [ ssrdocc(docc) cpattern(dt) ] -> [ +} + +ARGUMENT EXTEND ssrgen TYPED AS (ssrdocc * cpattern) PRINTED BY { pr_ssrgen } +| [ ssrdocc(docc) cpattern(dt) ] -> { match docc with | Some [], _ -> CErrors.user_err ~loc (str"Clear flag {} not allowed here") - | _ -> docc, dt ] -| [ cpattern(dt) ] -> [ nodocc, dt ] + | _ -> docc, dt } +| [ cpattern(dt) ] -> { nodocc, dt } END +{ + let has_occ ((_, occ), _) = occ <> None (** Generalization (discharge) sequence *) @@ -1727,39 +1906,47 @@ let cons_dep (gensl, clr) = if List.length gensl = 1 then ([] :: gensl, clr) else CErrors.user_err (Pp.str "multiple dependents switches '/'") -ARGUMENT EXTEND ssrdgens_tl TYPED AS ssrgen list list * ssrclear - PRINTED BY pr_ssrdgens +} + +ARGUMENT EXTEND ssrdgens_tl TYPED AS (ssrgen list list * ssrclear) + PRINTED BY { pr_ssrdgens } | [ "{" ne_ssrhyp_list(clr) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (mkclr clr, dt) dgens ] + { cons_gen (mkclr clr, dt) dgens } | [ "{" ne_ssrhyp_list(clr) "}" ] -> - [ [[]], clr ] + { [[]], clr } | [ "{" ssrocc(occ) "}" cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (mkocc occ, dt) dgens ] + { cons_gen (mkocc occ, dt) dgens } | [ "/" ssrdgens_tl(dgens) ] -> - [ cons_dep dgens ] + { cons_dep dgens } | [ cpattern(dt) ssrdgens_tl(dgens) ] -> - [ cons_gen (nodocc, dt) dgens ] + { cons_gen (nodocc, dt) dgens } | [ ] -> - [ [[]], [] ] + { [[]], [] } END -ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY pr_ssrdgens -| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> [ cons_gen gen dgens ] +ARGUMENT EXTEND ssrdgens TYPED AS ssrdgens_tl PRINTED BY { pr_ssrdgens } +| [ ":" ssrgen(gen) ssrdgens_tl(dgens) ] -> { cons_gen gen dgens } END (** Equations *) (* argument *) +{ + let pr_eqid = function Some pat -> str " " ++ pr_ipat pat | None -> mt () let pr_ssreqid _ _ _ = pr_eqid +} + (* We must use primitive parsing here to avoid conflicts with the *) (* basic move, case, and elim tactics. *) -ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY pr_ssreqid -| [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +ARGUMENT EXTEND ssreqid TYPED AS ssripatrep option PRINTED BY { pr_ssreqid } +| [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let accept_ssreqid strm = match Util.stream_nth 0 strm with | Tok.IDENT _ -> accept_before_syms [":"] strm @@ -1770,24 +1957,26 @@ let accept_ssreqid strm = let test_ssreqid = Gram.Entry.of_parser "test_ssreqid" accept_ssreqid -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssreqid; ssreqpat: [ - [ id = Prim.ident -> IPatId id - | "_" -> IPatAnon Drop - | "?" -> IPatAnon One - | occ = ssrdocc; "->" -> (match occ with + [ id = Prim.ident -> { IPatId id } + | "_" -> { IPatAnon Drop } + | "?" -> { IPatAnon One } + | occ = ssrdocc; "->" -> { match occ with | None, occ -> IPatRewrite (occ, L2R) - | _ -> CErrors.user_err ~loc:!@loc (str"Only occurrences are allowed here")) - | occ = ssrdocc; "<-" -> (match occ with + | _ -> CErrors.user_err ~loc (str"Only occurrences are allowed here") } + | occ = ssrdocc; "<-" -> { match occ with | None, occ -> IPatRewrite (occ, R2L) - | _ -> CErrors.user_err ~loc:!@loc (str "Only occurrences are allowed here")) - | "->" -> IPatRewrite (allocc, L2R) - | "<-" -> IPatRewrite (allocc, R2L) + | _ -> CErrors.user_err ~loc (str "Only occurrences are allowed here") } + | "->" -> { IPatRewrite (allocc, L2R) } + | "<-" -> { IPatRewrite (allocc, R2L) } ]]; ssreqid: [ - [ test_ssreqid; pat = ssreqpat -> Some pat - | test_ssreqid -> None + [ test_ssreqid; pat = ssreqpat -> { Some pat } + | test_ssreqid -> { None } ]]; END @@ -1800,22 +1989,26 @@ END (* type ssrarg = ssrbwdview * (ssreqid * (ssrdgens * ssripats)) *) +{ + let pr_ssrarg _ _ _ (view, (eqid, (dgens, ipats))) = let pri = pr_intros (gens_sep dgens) in pr_view2 view ++ pr_eqid eqid ++ pr_dgens pr_gen dgens ++ pri ipats -ARGUMENT EXTEND ssrarg TYPED AS ssrfwdview * (ssreqid * (ssrdgens * ssrintros)) - PRINTED BY pr_ssrarg +} + +ARGUMENT EXTEND ssrarg TYPED AS (ssrfwdview * (ssreqid * (ssrdgens * ssrintros))) + PRINTED BY { pr_ssrarg } | [ ssrfwdview(view) ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> - [ view, (eqid, (dgens, ipats)) ] + { view, (eqid, (dgens, ipats)) } | [ ssrfwdview(view) ssrclear(clr) ssrintros(ipats) ] -> - [ view, (None, (([], clr), ipats)) ] + { view, (None, (([], clr), ipats)) } | [ ssreqid(eqid) ssrdgens(dgens) ssrintros(ipats) ] -> - [ [], (eqid, (dgens, ipats)) ] + { [], (eqid, (dgens, ipats)) } | [ ssrclear_ne(clr) ssrintros(ipats) ] -> - [ [], (None, (([], clr), ipats)) ] + { [], (None, (([], clr), ipats)) } | [ ssrintros_ne(ipats) ] -> - [ [], (None, (([], []), ipats)) ] + { [], (None, (([], []), ipats)) } END (** The "clear" tactic *) @@ -1823,11 +2016,13 @@ END (* We just add a numeric version that clears the n top assumptions. *) TACTIC EXTEND ssrclear - | [ "clear" natural(n) ] -> [ tclIPAT (List.init n (fun _ -> IPatAnon Drop)) ] + | [ "clear" natural(n) ] -> { tclIPAT (List.init n (fun _ -> IPatAnon Drop)) } END (** The "move" tactic *) +{ + (* TODO: review this, in particular the => _ and => [] cases *) let rec improper_intros = function | IPatSimpl _ :: ipats -> improper_intros ipats @@ -1845,149 +2040,179 @@ let check_movearg = function CErrors.user_err (Pp.str "no proper intro pattern for equation in move tactic") | arg -> arg -ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY pr_ssrarg -| [ ssrarg(arg) ] -> [ check_movearg arg ] +} + +ARGUMENT EXTEND ssrmovearg TYPED AS ssrarg PRINTED BY { pr_ssrarg } +| [ ssrarg(arg) ] -> { check_movearg arg } END +{ + let movearg_of_parsed_movearg (v,(eq,(dg,ip))) = (v,(eq,(ssrdgens_of_parsed_dgens dg,ip))) +} + TACTIC EXTEND ssrmove | [ "move" ssrmovearg(arg) ssrrpat(pat) ] -> - [ ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] ] + { ssrmovetac (movearg_of_parsed_movearg arg) <*> tclIPAT [pat] } | [ "move" ssrmovearg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses ] -| [ "move" ssrrpat(pat) ] -> [ tclIPAT [pat] ] -| [ "move" ] -> [ ssrsmovetac ] + { tclCLAUSES (ssrmovetac (movearg_of_parsed_movearg arg)) clauses } +| [ "move" ssrrpat(pat) ] -> { tclIPAT [pat] } +| [ "move" ] -> { ssrsmovetac } END +{ + let check_casearg = function | view, (_, (([_; gen :: _], _), _)) when view <> [] && has_occ gen -> CErrors.user_err (Pp.str "incompatible view and occurrence switch in dependent case tactic") | arg -> arg -ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY pr_ssrarg -| [ ssrarg(arg) ] -> [ check_casearg arg ] +} + +ARGUMENT EXTEND ssrcasearg TYPED AS ssrarg PRINTED BY { pr_ssrarg } +| [ ssrarg(arg) ] -> { check_casearg arg } END TACTIC EXTEND ssrcase | [ "case" ssrcasearg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrcasetac (movearg_of_parsed_movearg arg)) clauses ] -| [ "case" ] -> [ ssrscasetoptac ] + { tclCLAUSES (ssrcasetac (movearg_of_parsed_movearg arg)) clauses } +| [ "case" ] -> { ssrscasetoptac } END (** The "elim" tactic *) TACTIC EXTEND ssrelim | [ "elim" ssrarg(arg) ssrclauses(clauses) ] -> - [ tclCLAUSES (ssrelimtac (movearg_of_parsed_movearg arg)) clauses ] -| [ "elim" ] -> [ ssrselimtoptac ] + { tclCLAUSES (ssrelimtac (movearg_of_parsed_movearg arg)) clauses } +| [ "elim" ] -> { ssrselimtoptac } END (** 6. Backward chaining tactics: apply, exact, congr. *) (** The "apply" tactic *) +{ + let pr_agen (docc, dt) = pr_docc docc ++ pr_term dt let pr_ssragen _ _ _ = pr_agen let pr_ssragens _ _ _ = pr_dgens pr_agen -ARGUMENT EXTEND ssragen TYPED AS ssrdocc * ssrterm PRINTED BY pr_ssragen -| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> [ mkclr clr, dt ] -| [ ssrterm(dt) ] -> [ nodocc, dt ] +} + +ARGUMENT EXTEND ssragen TYPED AS (ssrdocc * ssrterm) PRINTED BY { pr_ssragen } +| [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ] -> { mkclr clr, dt } +| [ ssrterm(dt) ] -> { nodocc, dt } END -ARGUMENT EXTEND ssragens TYPED AS ssragen list list * ssrclear -PRINTED BY pr_ssragens +ARGUMENT EXTEND ssragens TYPED AS (ssragen list list * ssrclear) +PRINTED BY { pr_ssragens } | [ "{" ne_ssrhyp_list(clr) "}" ssrterm(dt) ssragens(agens) ] -> - [ cons_gen (mkclr clr, dt) agens ] -| [ "{" ne_ssrhyp_list(clr) "}" ] -> [ [[]], clr] + { cons_gen (mkclr clr, dt) agens } +| [ "{" ne_ssrhyp_list(clr) "}" ] -> { [[]], clr} | [ ssrterm(dt) ssragens(agens) ] -> - [ cons_gen (nodocc, dt) agens ] -| [ ] -> [ [[]], [] ] + { cons_gen (nodocc, dt) agens } +| [ ] -> { [[]], [] } END +{ + let mk_applyarg views agens intros = views, (agens, intros) let pr_ssraarg _ _ _ (view, (dgens, ipats)) = let pri = pr_intros (gens_sep dgens) in pr_view view ++ pr_dgens pr_agen dgens ++ pri ipats +} + ARGUMENT EXTEND ssrapplyarg -TYPED AS ssrbwdview * (ssragens * ssrintros) -PRINTED BY pr_ssraarg +TYPED AS (ssrbwdview * (ssragens * ssrintros)) +PRINTED BY { pr_ssraarg } | [ ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> - [ mk_applyarg [] (cons_gen gen dgens) intros ] + { mk_applyarg [] (cons_gen gen dgens) intros } | [ ssrclear_ne(clr) ssrintros(intros) ] -> - [ mk_applyarg [] ([], clr) intros ] + { mk_applyarg [] ([], clr) intros } | [ ssrintros_ne(intros) ] -> - [ mk_applyarg [] ([], []) intros ] + { mk_applyarg [] ([], []) intros } | [ ssrbwdview(view) ":" ssragen(gen) ssragens(dgens) ssrintros(intros) ] -> - [ mk_applyarg view (cons_gen gen dgens) intros ] + { mk_applyarg view (cons_gen gen dgens) intros } | [ ssrbwdview(view) ssrclear(clr) ssrintros(intros) ] -> - [ mk_applyarg view ([], clr) intros ] + { mk_applyarg view ([], clr) intros } END TACTIC EXTEND ssrapply -| [ "apply" ssrapplyarg(arg) ] -> [ +| [ "apply" ssrapplyarg(arg) ] -> { let views, (gens_clr, intros) = arg in - inner_ssrapplytac views gens_clr ist <*> tclIPATssr intros ] -| [ "apply" ] -> [ apply_top_tac ] + inner_ssrapplytac views gens_clr ist <*> tclIPATssr intros } +| [ "apply" ] -> { apply_top_tac } END (** The "exact" tactic *) +{ + let mk_exactarg views dgens = mk_applyarg views dgens [] -ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY pr_ssraarg +} + +ARGUMENT EXTEND ssrexactarg TYPED AS ssrapplyarg PRINTED BY { pr_ssraarg } | [ ":" ssragen(gen) ssragens(dgens) ] -> - [ mk_exactarg [] (cons_gen gen dgens) ] + { mk_exactarg [] (cons_gen gen dgens) } | [ ssrbwdview(view) ssrclear(clr) ] -> - [ mk_exactarg view ([], clr) ] + { mk_exactarg view ([], clr) } | [ ssrclear_ne(clr) ] -> - [ mk_exactarg [] ([], clr) ] + { mk_exactarg [] ([], clr) } END +{ + let vmexacttac pf = Goal.enter begin fun gl -> exact_no_check (EConstr.mkCast (pf, _vmcast, Tacmach.New.pf_concl gl)) end +} + TACTIC EXTEND ssrexact -| [ "exact" ssrexactarg(arg) ] -> [ +| [ "exact" ssrexactarg(arg) ] -> { let views, (gens_clr, _) = arg in - V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) ] -| [ "exact" ] -> [ - V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) ] -| [ "exact" "<:" lconstr(pf) ] -> [ vmexacttac pf ] + V82.tactic (tclBY (V82.of_tactic (inner_ssrapplytac views gens_clr ist))) } +| [ "exact" ] -> { + V82.tactic (Tacticals.tclORELSE (donetac ~-1) (tclBY (V82.of_tactic apply_top_tac))) } +| [ "exact" "<:" lconstr(pf) ] -> { vmexacttac pf } END (** The "congr" tactic *) (* type ssrcongrarg = open_constr * (int * constr) *) +{ + let pr_ssrcongrarg _ _ _ ((n, f), dgens) = (if n <= 0 then mt () else str " " ++ int n) ++ str " " ++ pr_term f ++ pr_dgens pr_gen dgens -ARGUMENT EXTEND ssrcongrarg TYPED AS (int * ssrterm) * ssrdgens - PRINTED BY pr_ssrcongrarg -| [ natural(n) constr(c) ssrdgens(dgens) ] -> [ (n, mk_term xNoFlag c), dgens ] -| [ natural(n) constr(c) ] -> [ (n, mk_term xNoFlag c),([[]],[]) ] -| [ constr(c) ssrdgens(dgens) ] -> [ (0, mk_term xNoFlag c), dgens ] -| [ constr(c) ] -> [ (0, mk_term xNoFlag c), ([[]],[]) ] +} + +ARGUMENT EXTEND ssrcongrarg TYPED AS ((int * ssrterm) * ssrdgens) + PRINTED BY { pr_ssrcongrarg } +| [ natural(n) constr(c) ssrdgens(dgens) ] -> { (n, mk_term xNoFlag c), dgens } +| [ natural(n) constr(c) ] -> { (n, mk_term xNoFlag c),([[]],[]) } +| [ constr(c) ssrdgens(dgens) ] -> { (0, mk_term xNoFlag c), dgens } +| [ constr(c) ] -> { (0, mk_term xNoFlag c), ([[]],[]) } END TACTIC EXTEND ssrcongr | [ "congr" ssrcongrarg(arg) ] -> -[ let arg, dgens = arg in +{ let arg, dgens = arg in V82.tactic begin match dgens with | [gens], clr -> Tacticals.tclTHEN (genstac (gens,clr)) (newssrcongrtac arg ist) | _ -> errorstrm (str"Dependent family abstractions not allowed in congr") - end] + end } END (** 7. Rewriting tactics (rewrite, unlock) *) @@ -1996,6 +2221,8 @@ END (** Rewrite clear/occ switches *) +{ + let pr_rwocc = function | None, None -> mt () | None, occ -> pr_occ occ @@ -2003,14 +2230,18 @@ let pr_rwocc = function let pr_ssrrwocc _ _ _ = pr_rwocc -ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY pr_ssrrwocc -| [ "{" ssrhyp_list(clr) "}" ] -> [ mkclr clr ] -| [ "{" ssrocc(occ) "}" ] -> [ mkocc occ ] -| [ ] -> [ noclr ] +} + +ARGUMENT EXTEND ssrrwocc TYPED AS ssrdocc PRINTED BY { pr_ssrrwocc } +| [ "{" ssrhyp_list(clr) "}" ] -> { mkclr clr } +| [ "{" ssrocc(occ) "}" ] -> { mkocc occ } +| [ ] -> { noclr } END (** Rewrite rules *) +{ + let pr_rwkind = function | RWred s -> pr_simpl s | RWdef -> str "/" @@ -2027,29 +2258,33 @@ let pr_ssrrule _ _ _ = pr_rule let noruleterm loc = mk_term xNoFlag (mkCProp loc) -ARGUMENT EXTEND ssrrule_ne TYPED AS ssrrwkind * ssrterm PRINTED BY pr_ssrrule - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrrule_ne TYPED AS (ssrrwkind * ssrterm) PRINTED BY { pr_ssrrule } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssrrule_ne; ssrrule_ne : [ [ test_not_ssrslashnum; x = - [ "/"; t = ssrterm -> RWdef, t - | t = ssrterm -> RWeq, t - | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) - ] -> x - | s = ssrsimpl_ne -> RWred s, noruleterm (Some !@loc) + [ "/"; t = ssrterm -> { RWdef, t } + | t = ssrterm -> { RWeq, t } + | s = ssrsimpl_ne -> { RWred s, noruleterm (Some loc) } + ] -> { x } + | s = ssrsimpl_ne -> { RWred s, noruleterm (Some loc) } ]]; END -ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY pr_ssrrule - | [ ssrrule_ne(r) ] -> [ r ] - | [ ] -> [ RWred Nop, noruleterm (Some loc) ] +ARGUMENT EXTEND ssrrule TYPED AS ssrrule_ne PRINTED BY { pr_ssrrule } + | [ ssrrule_ne(r) ] -> { r } + | [ ] -> { RWred Nop, noruleterm (Some loc) } END (** Rewrite arguments *) +{ + let pr_option f = function None -> mt() | Some x -> f x let pr_pattern_squarep= pr_option (fun r -> str "[" ++ pr_rpattern r ++ str "]") let pr_ssrpattern_squarep _ _ _ = pr_pattern_squarep @@ -2058,58 +2293,66 @@ let pr_rwarg ((d, m), ((docc, rx), r)) = let pr_ssrrwarg _ _ _ = pr_rwarg +} + ARGUMENT EXTEND ssrpattern_squarep -TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep - | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] - | [ ] -> [ None ] +TYPED AS rpattern option PRINTED BY { pr_ssrpattern_squarep } + | [ "[" rpattern(rdx) "]" ] -> { Some rdx } + | [ ] -> { None } END ARGUMENT EXTEND ssrpattern_ne_squarep -TYPED AS rpattern option PRINTED BY pr_ssrpattern_squarep - | [ "[" rpattern(rdx) "]" ] -> [ Some rdx ] +TYPED AS rpattern option PRINTED BY { pr_ssrpattern_squarep } + | [ "[" rpattern(rdx) "]" ] -> { Some rdx } END ARGUMENT EXTEND ssrrwarg - TYPED AS (ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule) - PRINTED BY pr_ssrrwarg + TYPED AS ((ssrdir * ssrmult) * ((ssrdocc * rpattern option) * ssrrule)) + PRINTED BY { pr_ssrrwarg } | [ "-" ssrmult(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg (R2L, m) (docc, rx) r ] + { mk_rwarg (R2L, m) (docc, rx) r } | [ "-/" ssrterm(t) ] -> (* just in case '-/' should become a token *) - [ mk_rwarg (R2L, nomult) norwocc (RWdef, t) ] + { mk_rwarg (R2L, nomult) norwocc (RWdef, t) } | [ ssrmult_ne(m) ssrrwocc(docc) ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg (L2R, m) (docc, rx) r ] + { mk_rwarg (L2R, m) (docc, rx) r } | [ "{" ne_ssrhyp_list(clr) "}" ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (mkclr clr, rx) r ] + { mk_rwarg norwmult (mkclr clr, rx) r } | [ "{" ne_ssrhyp_list(clr) "}" ssrrule(r) ] -> - [ mk_rwarg norwmult (mkclr clr, None) r ] + { mk_rwarg norwmult (mkclr clr, None) r } | [ "{" ssrocc(occ) "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (mkocc occ, rx) r ] + { mk_rwarg norwmult (mkocc occ, rx) r } | [ "{" "}" ssrpattern_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (nodocc, rx) r ] + { mk_rwarg norwmult (nodocc, rx) r } | [ ssrpattern_ne_squarep(rx) ssrrule_ne(r) ] -> - [ mk_rwarg norwmult (noclr, rx) r ] + { mk_rwarg norwmult (noclr, rx) r } | [ ssrrule_ne(r) ] -> - [ mk_rwarg norwmult norwocc r ] + { mk_rwarg norwmult norwocc r } END TACTIC EXTEND ssrinstofruleL2R -| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist L2R arg) ] +| [ "ssrinstancesofruleL2R" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist L2R arg) } END TACTIC EXTEND ssrinstofruleR2L -| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> [ V82.tactic (ssrinstancesofrule ist R2L arg) ] +| [ "ssrinstancesofruleR2L" ssrterm(arg) ] -> { V82.tactic (ssrinstancesofrule ist R2L arg) } END (** Rewrite argument sequence *) (* type ssrrwargs = ssrrwarg list *) +{ + let pr_ssrrwargs _ _ _ rwargs = pr_list spc pr_rwarg rwargs -ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY pr_ssrrwargs - | [ "YouShouldNotTypeThis" ] -> [ anomaly "Grammar placeholder match" ] +} + +ARGUMENT EXTEND ssrrwargs TYPED AS ssrrwarg list PRINTED BY { pr_ssrrwargs } + | [ "YouShouldNotTypeThis" ] -> { anomaly "Grammar placeholder match" } END +{ + let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true let _ = @@ -2120,57 +2363,70 @@ let _ = Goptions.optdepr = false; Goptions.optwrite = (fun b -> ssr_rw_syntax := b) } +let lbrace = Char.chr 123 +(** Workaround to a limitation of coqpp *) + let test_ssr_rw_syntax = let test strm = if not !ssr_rw_syntax then raise Stream.Failure else if is_ssr_loaded () then () else match Util.stream_nth 0 strm with - | Tok.KEYWORD key when List.mem key.[0] ['{'; '['; '/'] -> () + | Tok.KEYWORD key when List.mem key.[0] [lbrace; '['; '/'] -> () | _ -> raise Stream.Failure in Gram.Entry.of_parser "test_ssr_rw_syntax" test -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssrrwargs; - ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> a ]]; + ssrrwargs: [[ test_ssr_rw_syntax; a = LIST1 ssrrwarg -> { a } ]]; END (** The "rewrite" tactic *) TACTIC EXTEND ssrrewrite | [ "rewrite" ssrrwargs(args) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses ] + { tclCLAUSES (old_tac (ssrrewritetac ist args)) clauses } END (** The "unlock" tactic *) +{ + let pr_unlockarg (occ, t) = pr_occ occ ++ pr_term t let pr_ssrunlockarg _ _ _ = pr_unlockarg -ARGUMENT EXTEND ssrunlockarg TYPED AS ssrocc * ssrterm - PRINTED BY pr_ssrunlockarg - | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> [ occ, t ] - | [ ssrterm(t) ] -> [ None, t ] +} + +ARGUMENT EXTEND ssrunlockarg TYPED AS (ssrocc * ssrterm) + PRINTED BY { pr_ssrunlockarg } + | [ "{" ssrocc(occ) "}" ssrterm(t) ] -> { occ, t } + | [ ssrterm(t) ] -> { None, t } END +{ + let pr_ssrunlockargs _ _ _ args = pr_list spc pr_unlockarg args +} + ARGUMENT EXTEND ssrunlockargs TYPED AS ssrunlockarg list - PRINTED BY pr_ssrunlockargs - | [ ssrunlockarg_list(args) ] -> [ args ] + PRINTED BY { pr_ssrunlockargs } + | [ ssrunlockarg_list(args) ] -> { args } END TACTIC EXTEND ssrunlock | [ "unlock" ssrunlockargs(args) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (unlocktac ist args)) clauses ] + { tclCLAUSES (old_tac (unlocktac ist args)) clauses } END (** 8. Forward chaining tactics (pose, set, have, suffice, wlog) *) TACTIC EXTEND ssrpose -| [ "pose" ssrfixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] -| [ "pose" ssrcofixfwd(ffwd) ] -> [ V82.tactic (ssrposetac ffwd) ] -| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> [ V82.tactic (ssrposetac (id, fwd)) ] +| [ "pose" ssrfixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } +| [ "pose" ssrcofixfwd(ffwd) ] -> { V82.tactic (ssrposetac ffwd) } +| [ "pose" ssrfwdid(id) ssrposefwd(fwd) ] -> { V82.tactic (ssrposetac (id, fwd)) } END (** The "set" tactic *) @@ -2179,7 +2435,7 @@ END TACTIC EXTEND ssrset | [ "set" ssrfwdid(id) ssrsetfwd(fwd) ssrclauses(clauses) ] -> - [ tclCLAUSES (old_tac (ssrsettac id fwd)) clauses ] + { tclCLAUSES (old_tac (ssrsettac id fwd)) clauses } END (** The "have" tactic *) @@ -2190,124 +2446,138 @@ END (* Pltac. *) (* The standard TACTIC EXTEND does not work for abstract *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: tactic_expr; tactic_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> - ssrtac_expr ~loc:!@loc "abstract" - [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] ]]; + { ssrtac_expr ~loc "abstract" + [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; END TACTIC EXTEND ssrabstract -| [ "abstract" ssrdgens(gens) ] -> [ +| [ "abstract" ssrdgens(gens) ] -> { if List.length (fst gens) <> 1 then errorstrm (str"dependents switches '/' not allowed here"); - Ssripats.ssrabstract (ssrdgens_of_parsed_dgens gens) ] + Ssripats.ssrabstract (ssrdgens_of_parsed_dgens gens) } END TACTIC EXTEND ssrhave | [ "have" ssrhavefwdwbinders(fwd) ] -> - [ V82.tactic (havetac ist fwd false false) ] + { V82.tactic (havetac ist fwd false false) } END TACTIC EXTEND ssrhavesuff | [ "have" "suff" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true false) } END TACTIC EXTEND ssrhavesuffices | [ "have" "suffices" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true false) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true false) } END TACTIC EXTEND ssrsuffhave | [ "suff" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true true) } END TACTIC EXTEND ssrsufficeshave | [ "suffices" "have" ssrhpats_nobs(pats) ssrhavefwd(fwd) ] -> - [ V82.tactic (havetac ist (false,(pats,fwd)) true true) ] + { V82.tactic (havetac ist (false,(pats,fwd)) true true) } END (** The "suffice" tactic *) +{ + let pr_ssrsufffwdwbinders _ _ prt (hpats, (fwd, hint)) = pr_hpats hpats ++ pr_fwd fwd ++ pr_hint prt hint +} + ARGUMENT EXTEND ssrsufffwd - TYPED AS ssrhpats * (ssrfwd * ssrhint) PRINTED BY pr_ssrsufffwdwbinders + TYPED AS (ssrhpats * (ssrfwd * ssrhint)) PRINTED BY { pr_ssrsufffwdwbinders } | [ ssrhpats(pats) ssrbinder_list(bs) ":" ast_closure_lterm(t) ssrhint(hint) ] -> - [ let ((clr, pats), binders), simpl = pats in + { let ((clr, pats), binders), simpl = pats in let allbs = intro_id_to_binder binders @ bs in let allbinders = binders @ List.flatten (binder_to_intro_id bs) in let fwd = mkFwdHint ":" t in - (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) ] + (((clr, pats), allbinders), simpl), (bind_fwd allbs fwd, hint) } END TACTIC EXTEND ssrsuff -| [ "suff" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +| [ "suff" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } END TACTIC EXTEND ssrsuffices -| [ "suffices" ssrsufffwd(fwd) ] -> [ V82.tactic (sufftac ist fwd) ] +| [ "suffices" ssrsufffwd(fwd) ] -> { V82.tactic (sufftac ist fwd) } END (** The "wlog" (Without Loss Of Generality) tactic *) (* type ssrwlogfwd = ssrwgen list * ssrfwd *) +{ + let pr_ssrwlogfwd _ _ _ (gens, t) = str ":" ++ pr_list mt pr_wgen gens ++ spc() ++ pr_fwd t -ARGUMENT EXTEND ssrwlogfwd TYPED AS ssrwgen list * ssrfwd - PRINTED BY pr_ssrwlogfwd -| [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> [ gens, mkFwdHint "/" t] +} + +ARGUMENT EXTEND ssrwlogfwd TYPED AS (ssrwgen list * ssrfwd) + PRINTED BY { pr_ssrwlogfwd } +| [ ":" ssrwgen_list(gens) "/" ast_closure_lterm(t) ] -> { gens, mkFwdHint "/" t} END TACTIC EXTEND ssrwlog | [ "wlog" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } END TACTIC EXTEND ssrwlogs | [ "wlog" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwlogss | [ "wlog" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwithoutloss | [ "without" "loss" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint false `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint false `NoGen) } END TACTIC EXTEND ssrwithoutlosss | [ "without" "loss" "suff" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END TACTIC EXTEND ssrwithoutlossss | [ "without" "loss" "suffices" ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ]-> - [ V82.tactic (wlogtac ist pats fwd hint true `NoGen) ] + { V82.tactic (wlogtac ist pats fwd hint true `NoGen) } END +{ + (* Generally have *) let pr_idcomma _ _ _ = function | None -> mt() | Some None -> str"_, " | Some (Some id) -> pr_id id ++ str", " -ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY pr_idcomma - | [ ] -> [ None ] +} + +ARGUMENT EXTEND ssr_idcomma TYPED AS ident option option PRINTED BY { pr_idcomma } + | [ ] -> { None } END +{ + let accept_idcomma strm = match stream_nth 0 strm with | Tok.IDENT _ | Tok.KEYWORD "_" -> accept_before_syms [","] strm @@ -2315,35 +2585,44 @@ let accept_idcomma strm = let test_idcomma = Gram.Entry.of_parser "test_idcomma" accept_idcomma -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: ssr_idcomma; ssr_idcomma: [ [ test_idcomma; - ip = [ id = IDENT -> Some (Id.of_string id) | "_" -> None ]; "," -> - Some ip + ip = [ id = IDENT -> { Some (Id.of_string id) } | "_" -> { None } ]; "," -> + { Some ip } ] ]; END +{ + let augment_preclr clr1 (((clr0, x),y),z) = (((clr1 @ clr0, x),y),z) +} + TACTIC EXTEND ssrgenhave | [ "gen" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] + { let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } END TACTIC EXTEND ssrgenhave2 | [ "generally" "have" ssrclear(clr) ssr_idcomma(id) ssrhpats_nobs(pats) ssrwlogfwd(fwd) ssrhint(hint) ] -> - [ let pats = augment_preclr clr pats in - V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) ] + { let pats = augment_preclr clr pats in + V82.tactic (wlogtac ist pats fwd hint false (`Gen id)) } END +{ + (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) let () = CLexer.set_keyword_state frozen_lexer ;; +} (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssr/ssrvernac.ml4 b/plugins/ssr/ssrvernac.mlg index 989a6c5bf1..876751911b 100644 --- a/plugins/ssr/ssrvernac.ml4 +++ b/plugins/ssr/ssrvernac.mlg @@ -10,6 +10,8 @@ (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) +{ + open Names module CoqConstr = Constr open CoqConstr @@ -25,7 +27,6 @@ open Notation_ops open Notation_term open Glob_term open Stdarg -open Genarg open Decl_kinds open Pp open Ppconstr @@ -36,9 +37,12 @@ open Evar_kinds open Ssrprinters open Ssrcommon open Ssrparser + +} + DECLARE PLUGIN "ssreflect_plugin" -let (!@) = Pcoq.to_coqloc +{ (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) @@ -46,7 +50,7 @@ let frozen_lexer = CLexer.get_keyword_state () ;; (* global syntactic changes and vernacular commands *) -(** Alternative notations for "match" and anonymous arguments. *)(* {{{ ************) +(** Alternative notations for "match" and anonymous arguments. *)(* ************) (* Syntax: *) (* if <term> is <pattern> then ... else ... *) @@ -71,60 +75,62 @@ let frozen_lexer = CLexer.get_keyword_state () ;; (* as this can't be done from an ML extension file, the new *) (* syntax will only work when ssreflect.v is imported. *) -let no_ct = None, None and no_rt = None in +let no_ct = None, None and no_rt = None let aliasvar = function | [[{ CAst.v = CPatAlias (_, na); loc }]] -> Some na - | _ -> None in -let mk_cnotype mp = aliasvar mp, None in -let mk_ctype mp t = aliasvar mp, Some t in -let mk_rtype t = Some t in -let mk_dthen ?loc (mp, ct, rt) c = (CAst.make ?loc (mp, c)), ct, rt in + | _ -> None +let mk_cnotype mp = aliasvar mp, None +let mk_ctype mp t = aliasvar mp, Some t +let mk_rtype t = Some t +let mk_dthen ?loc (mp, ct, rt) c = (CAst.make ?loc (mp, c)), ct, rt let mk_let ?loc rt ct mp c1 = - CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [CAst.make ?loc (mp, c1)]) in -let mk_pat c (na, t) = (c, na, t) in -GEXTEND Gram + CAst.make ?loc @@ CCases (LetPatternStyle, rt, ct, [CAst.make ?loc (mp, c1)]) +let mk_pat c (na, t) = (c, na, t) + +} + +GRAMMAR EXTEND Gram GLOBAL: binder_constr; - ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> mk_rtype t ]]; - ssr_mpat: [[ p = pattern -> [[p]] ]]; + ssr_rtype: [[ "return"; t = operconstr LEVEL "100" -> { mk_rtype t } ]]; + ssr_mpat: [[ p = pattern -> { [[p]] } ]]; ssr_dpat: [ - [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> mp, mk_ctype mp t, rt - | mp = ssr_mpat; rt = ssr_rtype -> mp, mk_cnotype mp, rt - | mp = ssr_mpat -> mp, no_ct, no_rt + [ mp = ssr_mpat; "in"; t = pattern; rt = ssr_rtype -> { mp, mk_ctype mp t, rt } + | mp = ssr_mpat; rt = ssr_rtype -> { mp, mk_cnotype mp, rt } + | mp = ssr_mpat -> { mp, no_ct, no_rt } ] ]; - ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> mk_dthen ~loc:!@loc dp c ]]; - ssr_elsepat: [[ "else" -> [[CAst.make ~loc:!@loc @@ CPatAtom None]] ]]; - ssr_else: [[ mp = ssr_elsepat; c = lconstr -> CAst.make ~loc:!@loc (mp, c) ]]; + ssr_dthen: [[ dp = ssr_dpat; "then"; c = lconstr -> { mk_dthen ~loc dp c } ]]; + ssr_elsepat: [[ "else" -> { [[CAst.make ~loc @@ CPatAtom None]] } ]]; + ssr_else: [[ mp = ssr_elsepat; c = lconstr -> { CAst.make ~loc (mp, c) } ]]; binder_constr: [ [ "if"; c = operconstr LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> - let b1, ct, rt = db1 in CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + { let b1, ct, rt = db1 in CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } | "if"; c = operconstr LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> - let b1, ct, rt = db1 in + { let b1, ct, rt = db1 in let b1, b2 = let open CAst in let {loc=l1; v=(p1, r1)}, {loc=l2; v=(p2, r2)} = b1, b2 in (make ?loc:l1 (p1, r2), make ?loc:l2 (p2, r1)) in - CAst.make ~loc:!@loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) + CAst.make ~loc @@ CCases (MatchStyle, rt, [mk_pat c ct], [b1; b2]) } | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; "in"; c1 = lconstr -> - mk_let ~loc:!@loc no_rt [mk_pat c no_ct] mp c1 + { mk_let ~loc no_rt [mk_pat c no_ct] mp c1 } | "let"; ":"; mp = ssr_mpat; ":="; c = lconstr; rt = ssr_rtype; "in"; c1 = lconstr -> - mk_let ~loc:!@loc rt [mk_pat c (mk_cnotype mp)] mp c1 + { mk_let ~loc rt [mk_pat c (mk_cnotype mp)] mp c1 } | "let"; ":"; mp = ssr_mpat; "in"; t = pattern; ":="; c = lconstr; rt = ssr_rtype; "in"; c1 = lconstr -> - mk_let ~loc:!@loc rt [mk_pat c (mk_ctype mp t)] mp c1 + { mk_let ~loc rt [mk_pat c (mk_ctype mp t)] mp c1 } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: closed_binder; closed_binder: [ - [ ["of" | "&"]; c = operconstr LEVEL "99" -> - [CLocalAssum ([CAst.make ~loc:!@loc Anonymous], Default Explicit, c)] + [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> + { [CLocalAssum ([CAst.make ~loc Anonymous], Default Explicit, c)] } ] ]; END -(* }}} *) -(** Vernacular commands: Prenex Implicits and Search *)(* {{{ **********************) +(** Vernacular commands: Prenex Implicits and Search *)(***********************) (* This should really be implemented as an extension to the implicit *) (* arguments feature, but unfortuately that API is sealed. The current *) @@ -138,6 +144,8 @@ END (* Prenex Implicits for all the visible constants that had been *) (* declared as Prenex Implicits. *) +{ + let declare_one_prenex_implicit locality f = let fref = try Smartlocate.global_with_alias f @@ -159,23 +167,24 @@ let declare_one_prenex_implicit locality f = | impls -> Impargs.declare_manual_implicits locality fref ~enriching:false [impls] -VERNAC COMMAND FUNCTIONAL EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF +} + +VERNAC COMMAND EXTEND Ssrpreneximplicits CLASSIFIED AS SIDEFF | [ "Prenex" "Implicits" ne_global_list(fl) ] - -> [ fun ~atts ~st -> + -> { let open Vernacinterp in let locality = Locality.make_section_locality atts.locality in List.iter (declare_one_prenex_implicit locality) fl; - st - ] + } END (* Vernac grammar visibility patch *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: [ [ IDENT "Import"; IDENT "Prenex"; IDENT "Implicits" -> - Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) + { Vernacexpr.VernacUnsetOption (false, ["Printing"; "Implicit"; "Defensive"]) } ] ] ; END @@ -184,6 +193,8 @@ END (* Main prefilter *) +{ + type raw_glob_search_about_item = | RGlobSearchSubPattern of constr_expr | RGlobSearchString of Loc.t * string * string option @@ -303,24 +314,32 @@ let interp_search_notation ?loc tag okey = let _, npat = Patternops.pattern_of_glob_constr (sub () body) in Search.GlobSearchSubPattern npat +} + ARGUMENT EXTEND ssr_search_item TYPED AS ssr_searchitem - PRINTED BY pr_ssr_search_item - | [ string(s) ] -> [ RGlobSearchString (loc,s,None) ] - | [ string(s) "%" preident(key) ] -> [ RGlobSearchString (loc,s,Some key) ] - | [ constr_pattern(p) ] -> [ RGlobSearchSubPattern p ] + PRINTED BY { pr_ssr_search_item } + | [ string(s) ] -> { RGlobSearchString (loc,s,None) } + | [ string(s) "%" preident(key) ] -> { RGlobSearchString (loc,s,Some key) } + | [ constr_pattern(p) ] -> { RGlobSearchSubPattern p } END +{ + let pr_ssr_search_arg _ _ _ = let pr_item (b, p) = str (if b then "-" else "") ++ pr_search_item p in pr_list spc pr_item +} + ARGUMENT EXTEND ssr_search_arg TYPED AS (bool * ssr_searchitem) list - PRINTED BY pr_ssr_search_arg - | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> [ (false, p) :: a ] - | [ ssr_search_item(p) ssr_search_arg(a) ] -> [ (true, p) :: a ] - | [ ] -> [ [] ] + PRINTED BY { pr_ssr_search_arg } + | [ "-" ssr_search_item(p) ssr_search_arg(a) ] -> { (false, p) :: a } + | [ ssr_search_item(p) ssr_search_arg(a) ] -> { (true, p) :: a } + | [ ] -> { [] } END +{ + (* Main type conclusion pattern filter *) let rec splay_search_pattern na = function @@ -419,16 +438,20 @@ let wit_ssrmodloc = add_genarg "ssrmodloc" pr_modloc let pr_ssr_modlocs _ _ _ ml = if ml = [] then str "" else spc () ++ str "in " ++ pr_list spc pr_modloc ml -ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY pr_ssr_modlocs - | [ ] -> [ [] ] +} + +ARGUMENT EXTEND ssr_modlocs TYPED AS ssrmodloc list PRINTED BY { pr_ssr_modlocs } + | [ ] -> { [] } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: ssr_modlocs; - modloc: [[ "-"; m = global -> true, m | m = global -> false, m]]; - ssr_modlocs: [[ "in"; ml = LIST1 modloc -> ml ]]; + modloc: [[ "-"; m = global -> { true, m } | m = global -> { false, m } ]]; + ssr_modlocs: [[ "in"; ml = LIST1 modloc -> { ml } ]]; END +{ + let interp_modloc mr = let interp_mod (_, qid) = try Nametab.full_name_module qid with Not_found -> @@ -446,20 +469,20 @@ let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ spc () ++ str " " ++ pr_lconstr_env env Evd.empty t in Feedback.msg_info (hov 2 pr_res ++ fnl ()) +} + VERNAC COMMAND EXTEND SsrSearchPattern CLASSIFIED AS QUERY | [ "Search" ssr_search_arg(a) ssr_modlocs(mr) ] -> - [ let hpat = interp_search_arg a in + { let hpat = interp_search_arg a in let in_mod = interp_modloc mr in let post_filter gr env typ = in_mod gr env typ && hpat gr env typ in let display gr env typ = if post_filter gr env typ then ssrdisplaysearch gr env typ in - Search.generic_search None display ] + Search.generic_search None display } END -(* }}} *) - -(** View hint database and View application. *)(* {{{ ******************************) +(** View hint database and View application. *)(* ******************************) (* There are three databases of lemmas used to mediate the application *) (* of reflection lemmas: one for forward chaining, one for backward *) @@ -467,6 +490,8 @@ END (* View hints *) +{ + let pr_raw_ssrhintref prc _ _ = let open CAst in function | { v = CAppExpl ((None, r,x), args) } when isCHoles args -> prc (CAst.make @@ CRef (r,x)) ++ str "|" ++ int (List.length args) @@ -490,14 +515,19 @@ let mkhintref ?loc c n = match c.CAst.v with | CRef (r,x) -> CAst.make ?loc @@ CAppExpl ((None, r, x), mkCHoles ?loc n) | _ -> mkAppC (c, mkCHoles ?loc n) +} + ARGUMENT EXTEND ssrhintref - PRINTED BY pr_ssrhintref - RAW_TYPED AS constr RAW_PRINTED BY pr_raw_ssrhintref - GLOB_TYPED AS constr GLOB_PRINTED BY pr_glob_ssrhintref - | [ constr(c) ] -> [ c ] - | [ constr(c) "|" natural(n) ] -> [ mkhintref ~loc c n ] + TYPED AS constr + PRINTED BY { pr_ssrhintref } + RAW_PRINTED BY { pr_raw_ssrhintref } + GLOB_PRINTED BY { pr_glob_ssrhintref } + | [ constr(c) ] -> { c } + | [ constr(c) "|" natural(n) ] -> { mkhintref ~loc c n } END +{ + (* View purpose *) let pr_viewpos = function @@ -508,70 +538,82 @@ let pr_viewpos = function let pr_ssrviewpos _ _ _ = pr_viewpos -ARGUMENT EXTEND ssrviewpos PRINTED BY pr_ssrviewpos - | [ "for" "move" "/" ] -> [ Some Ssrview.AdaptorDb.Forward ] - | [ "for" "apply" "/" ] -> [ Some Ssrview.AdaptorDb.Backward ] - | [ "for" "apply" "/" "/" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] - | [ "for" "apply" "//" ] -> [ Some Ssrview.AdaptorDb.Equivalence ] - | [ ] -> [ None ] +} + +ARGUMENT EXTEND ssrviewpos PRINTED BY { pr_ssrviewpos } + | [ "for" "move" "/" ] -> { Some Ssrview.AdaptorDb.Forward } + | [ "for" "apply" "/" ] -> { Some Ssrview.AdaptorDb.Backward } + | [ "for" "apply" "/" "/" ] -> { Some Ssrview.AdaptorDb.Equivalence } + | [ "for" "apply" "//" ] -> { Some Ssrview.AdaptorDb.Equivalence } + | [ ] -> { None } END +{ + let pr_ssrviewposspc _ _ _ i = pr_viewpos i ++ spc () -ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY pr_ssrviewposspc - | [ ssrviewpos(i) ] -> [ i ] +} + +ARGUMENT EXTEND ssrviewposspc TYPED AS ssrviewpos PRINTED BY { pr_ssrviewposspc } + | [ ssrviewpos(i) ] -> { i } END +{ + let print_view_hints kind l = let pp_viewname = str "Hint View" ++ pr_viewpos (Some kind) ++ str " " in let pp_hints = pr_list spc pr_rawhintref l in Feedback.msg_info (pp_viewname ++ hov 0 pp_hints ++ Pp.cut ()) +} + VERNAC COMMAND EXTEND PrintView CLASSIFIED AS QUERY | [ "Print" "Hint" "View" ssrviewpos(i) ] -> - [ match i with + { match i with | Some k -> print_view_hints k (Ssrview.AdaptorDb.get k) | None -> List.iter (fun k -> print_view_hints k (Ssrview.AdaptorDb.get k)) [ Ssrview.AdaptorDb.Forward; Ssrview.AdaptorDb.Backward; Ssrview.AdaptorDb.Equivalence ] - ] + } END +{ + let glob_view_hints lvh = List.map (Constrintern.intern_constr (Global.env ()) (Evd.from_env (Global.env ()))) lvh +} + VERNAC COMMAND EXTEND HintView CLASSIFIED AS SIDEFF | [ "Hint" "View" ssrviewposspc(n) ne_ssrhintref_list(lvh) ] -> - [ let hints = glob_view_hints lvh in + { let hints = glob_view_hints lvh in match n with | None -> Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Forward hints; Ssrview.AdaptorDb.declare Ssrview.AdaptorDb.Backward hints | Some k -> - Ssrview.AdaptorDb.declare k hints ] + Ssrview.AdaptorDb.declare k hints } END -(* }}} *) - (** Canonical Structure alias *) -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: gallina_ext; gallina_ext: (* Canonical structure *) [[ IDENT "Canonical"; qid = Constr.global -> - Vernacexpr.VernacCanonical (CAst.make @@ AN qid) + { Vernacexpr.VernacCanonical (CAst.make @@ AN qid) } | IDENT "Canonical"; ntn = Prim.by_notation -> - Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) + { Vernacexpr.VernacCanonical (CAst.make @@ ByNotation ntn) } | IDENT "Canonical"; qid = Constr.global; d = G_vernac.def_body -> - let s = coerce_reference_to_id qid in + { let s = coerce_reference_to_id qid in Vernacexpr.VernacDefinition ((Decl_kinds.NoDischarge,Decl_kinds.CanonicalStructure), - ((CAst.make (Name s)),None), d) + ((CAst.make (Name s)),None), d) } ]]; END @@ -589,30 +631,34 @@ END (* Coq v8.3 defines "by" as a keyword, some hacks are not needed any *) (* longer and thus comment out. Such comments are marked with v8.3 *) +{ + open Pltac -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: hypident; hypident: [ - [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> id, Locus.InHypTypeOnly - | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> id, Locus.InHypValueOnly + [ "("; IDENT "type"; "of"; id = Prim.identref; ")" -> { id, Locus.InHypTypeOnly } + | "("; IDENT "value"; "of"; id = Prim.identref; ")" -> { id, Locus.InHypValueOnly } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: hloc; hloc: [ [ "in"; "("; "Type"; "of"; id = ident; ")" -> - Tacexpr.HypLocation (CAst.make id, Locus.InHypTypeOnly) + { Tacexpr.HypLocation (CAst.make id, Locus.InHypTypeOnly) } | "in"; "("; IDENT "Value"; "of"; id = ident; ")" -> - Tacexpr.HypLocation (CAst.make id, Locus.InHypValueOnly) + { Tacexpr.HypLocation (CAst.make id, Locus.InHypValueOnly) } ] ]; END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: constr_eval; constr_eval: [ - [ IDENT "type"; "of"; c = Constr.constr -> Genredexpr.ConstrTypeOf c ] + [ IDENT "type"; "of"; c = Constr.constr -> { Genredexpr.ConstrTypeOf c }] ]; END @@ -620,6 +666,10 @@ END (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) +{ + let () = CLexer.set_keyword_state frozen_lexer ;; +} + (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssrmatching/g_ssrmatching.ml4 b/plugins/ssrmatching/g_ssrmatching.mlg index 746c368aa9..3f0794fdd4 100644 --- a/plugins/ssrmatching/g_ssrmatching.ml4 +++ b/plugins/ssrmatching/g_ssrmatching.mlg @@ -8,8 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +{ + open Ltac_plugin -open Genarg open Pcoq open Pcoq.Constr open Ssrmatching @@ -19,83 +20,101 @@ open Ssrmatching.Internal * we thus save the lexer to restore it at the end of the file *) let frozen_lexer = CLexer.get_keyword_state () ;; +} + DECLARE PLUGIN "ssrmatching_plugin" +{ + let pr_rpattern _ _ _ = pr_rpattern +} + ARGUMENT EXTEND rpattern TYPED AS rpatternty - PRINTED BY pr_rpattern - INTERPRETED BY interp_rpattern - GLOBALIZED BY glob_rpattern - SUBSTITUTED BY subst_rpattern - | [ lconstr(c) ] -> [ mk_rpattern (T (mk_lterm c None)) ] - | [ "in" lconstr(c) ] -> [ mk_rpattern (In_T (mk_lterm c None)) ] + PRINTED BY { pr_rpattern } + INTERPRETED BY { interp_rpattern } + GLOBALIZED BY { glob_rpattern } + SUBSTITUTED BY { subst_rpattern } + | [ lconstr(c) ] -> { mk_rpattern (T (mk_lterm c None)) } + | [ "in" lconstr(c) ] -> { mk_rpattern (In_T (mk_lterm c None)) } | [ lconstr(x) "in" lconstr(c) ] -> - [ mk_rpattern (X_In_T (mk_lterm x None, mk_lterm c None)) ] + { mk_rpattern (X_In_T (mk_lterm x None, mk_lterm c None)) } | [ "in" lconstr(x) "in" lconstr(c) ] -> - [ mk_rpattern (In_X_In_T (mk_lterm x None, mk_lterm c None)) ] + { mk_rpattern (In_X_In_T (mk_lterm x None, mk_lterm c None)) } | [ lconstr(e) "in" lconstr(x) "in" lconstr(c) ] -> - [ mk_rpattern (E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) ] + { mk_rpattern (E_In_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) } | [ lconstr(e) "as" lconstr(x) "in" lconstr(c) ] -> - [ mk_rpattern (E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) ] + { mk_rpattern (E_As_X_In_T (mk_lterm e None, mk_lterm x None, mk_lterm c None)) } END +{ + let pr_ssrterm _ _ _ = pr_ssrterm +} + ARGUMENT EXTEND cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "Qed" constr(c) ] -> [ mk_lterm c None ] + PRINTED BY { pr_ssrterm } + INTERPRETED BY { interp_ssrterm } + GLOBALIZED BY { glob_cpattern } SUBSTITUTED BY { subst_ssrterm } + RAW_PRINTED BY { pr_ssrterm } + GLOB_PRINTED BY { pr_ssrterm } +| [ "Qed" constr(c) ] -> { mk_lterm c None } END +{ + let input_ssrtermkind strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' let ssrtermkind = Pcoq.Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind -GEXTEND Gram +} + +GRAMMAR EXTEND Gram GLOBAL: cpattern; - cpattern: [[ k = ssrtermkind; c = constr -> + cpattern: [[ k = ssrtermkind; c = constr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some !@loc && k = '(' + if loc_of_cpattern pattern <> Some loc && k = '(' then mk_term 'x' c None - else pattern ]]; + else pattern } ]]; END ARGUMENT EXTEND lcpattern TYPED AS cpattern - PRINTED BY pr_ssrterm - INTERPRETED BY interp_ssrterm - GLOBALIZED BY glob_cpattern SUBSTITUTED BY subst_ssrterm - RAW_PRINTED BY pr_ssrterm - GLOB_PRINTED BY pr_ssrterm -| [ "Qed" lconstr(c) ] -> [ mk_lterm c None ] + PRINTED BY { pr_ssrterm } + INTERPRETED BY { interp_ssrterm } + GLOBALIZED BY { glob_cpattern } SUBSTITUTED BY { subst_ssrterm } + RAW_PRINTED BY { pr_ssrterm } + GLOB_PRINTED BY { pr_ssrterm } +| [ "Qed" lconstr(c) ] -> { mk_lterm c None } END -GEXTEND Gram +GRAMMAR EXTEND Gram GLOBAL: lcpattern; - lcpattern: [[ k = ssrtermkind; c = lconstr -> + lcpattern: [[ k = ssrtermkind; c = lconstr -> { let pattern = mk_term k c None in - if loc_of_cpattern pattern <> Some !@loc && k = '(' + if loc_of_cpattern pattern <> Some loc && k = '(' then mk_term 'x' c None - else pattern ]]; + else pattern } ]]; END -ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY pr_rpattern -| [ rpattern(pat) ] -> [ pat ] +ARGUMENT EXTEND ssrpatternarg TYPED AS rpattern PRINTED BY { pr_rpattern } +| [ rpattern(pat) ] -> { pat } END TACTIC EXTEND ssrinstoftpat -| [ "ssrinstancesoftpat" cpattern(arg) ] -> [ Proofview.V82.tactic (ssrinstancesof arg) ] +| [ "ssrinstancesoftpat" cpattern(arg) ] -> { Proofview.V82.tactic (ssrinstancesof arg) } END +{ + (* We wipe out all the keywords generated by the grammar rules we defined. *) (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) let () = CLexer.set_keyword_state frozen_lexer ;; + +} diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index aadb4fe5f6..4a63dd4708 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -856,7 +856,7 @@ let rec uniquize = function let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ - str(String.plural !nocc " occurence") ++ match upats_origin with + str(String.plural !nocc " occurrence") ++ match upats_origin with | None -> str" of" ++ spc() ++ pr_constr_pat p' | Some (dir,rule) -> str" of the " ++ pr_dir_side dir ++ fnl() ++ ws 4 ++ pr_constr_pat p' ++ fnl () ++ diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 8ee6fbf036..94255bab6c 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -40,8 +40,7 @@ let ascii_kn = MutInd.make2 ascii_modpath ascii_label let path_of_Ascii = ((ascii_kn,0),1) let static_glob_Ascii = ConstructRef path_of_Ascii -let make_reference id = find_reference "Ascii interpretation" ascii_module id -let glob_Ascii = lazy (make_reference "Ascii") +let glob_Ascii = lazy (lib_ref "plugins.syntax.Ascii") open Lazy @@ -49,7 +48,7 @@ let interp_ascii ?loc p = let rec aux n p = if Int.equal n 0 then [] else let mp = p mod 2 in - (DAst.make ?loc @@ GRef ((if Int.equal mp 0 then glob_false else glob_true),None)) + (DAst.make ?loc @@ GRef (lib_ref (if Int.equal mp 0 then "core.bool.false" else "core.bool.true"),None)) :: (aux (n-1) (p/2)) in DAst.make ?loc @@ GApp (DAst.make ?loc @@ GRef(force glob_Ascii,None), aux 8 p) @@ -67,8 +66,8 @@ let interp_ascii_string ?loc s = let uninterp_ascii r = let rec uninterp_bool_list n = function | [] when Int.equal n 0 -> 0 - | r::l when is_gr r glob_true -> 1+2*(uninterp_bool_list (n-1) l) - | r::l when is_gr r glob_false -> 2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.true") -> 1+2*(uninterp_bool_list (n-1) l) + | r::l when is_gr r (lib_ref "core.bool.false") -> 2*(uninterp_bool_list (n-1) l) | _ -> raise Non_closed_ascii in try let aux c = match DAst.get c with diff --git a/plugins/syntax/g_numeral.ml4 b/plugins/syntax/g_numeral.mlg index 55f61a58f9..5dbc9eea7a 100644 --- a/plugins/syntax/g_numeral.ml4 +++ b/plugins/syntax/g_numeral.mlg @@ -10,6 +10,8 @@ DECLARE PLUGIN "numeral_notation_plugin" +{ + open Notation open Numeral open Pp @@ -24,15 +26,17 @@ let pr_numnot_option _ _ _ = function | Warning n -> str "(warning after " ++ str n ++ str ")" | Abstract n -> str "(abstract after " ++ str n ++ str ")" +} + ARGUMENT EXTEND numnotoption - PRINTED BY pr_numnot_option -| [ ] -> [ Nop ] -| [ "(" "warning" "after" bigint(waft) ")" ] -> [ Warning waft ] -| [ "(" "abstract" "after" bigint(n) ")" ] -> [ Abstract n ] + PRINTED BY { pr_numnot_option } +| [ ] -> { Nop } +| [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } +| [ "(" "abstract" "after" bigint(n) ")" ] -> { Abstract n } END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF | [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> - [ vernac_numeral_notation (Locality.make_module_locality atts.locality) ty f g (Id.to_string sc) o ] + { vernac_numeral_notation (Locality.make_module_locality atts.locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 703b40dd3e..59e65a0672 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -31,9 +31,8 @@ let string_kn = MutInd.make2 string_modpath @@ Label.make "string" let static_glob_EmptyString = ConstructRef ((string_kn,0),1) let static_glob_String = ConstructRef ((string_kn,0),2) -let make_reference id = find_reference "String interpretation" string_module id -let glob_String = lazy (make_reference "String") -let glob_EmptyString = lazy (make_reference "EmptyString") +let glob_String = lazy (lib_ref "plugins.syntax.String") +let glob_EmptyString = lazy (lib_ref "plugins.syntax.EmptyString") let is_gr c gr = match DAst.get c with | GRef (r, _) -> GlobRef.equal r gr diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 9fa8442f8a..54e847988b 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -994,8 +994,8 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) -let use_unit_judge evd = - let j, ctx = coq_unit_judge () in +let use_unit_judge env evd = + let j, ctx = coq_unit_judge !!env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in evd', j @@ -1024,7 +1024,7 @@ let adjust_impossible_cases sigma pb pred tomatch submat = | Evar (evk,_) when snd (evar_source evk sigma) == Evar_kinds.ImpossibleCase -> let sigma = if not (Evd.is_defined sigma evk) then - let sigma, default = use_unit_judge sigma in + let sigma, default = use_unit_judge pb.env sigma in let sigma = Evd.define evk default.uj_type sigma in sigma else sigma @@ -2512,7 +2512,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env sigma = function | Some t -> typing_function tycon env sigma t - | None -> use_unit_judge sigma in + | None -> use_unit_judge env sigma in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in @@ -2593,7 +2593,7 @@ let compile_program_cases ?loc style (typing_function, sigma) tycon env let typing_function tycon env sigma = function | Some t -> typing_function tycon env sigma t - | None -> use_unit_judge sigma in + | None -> use_unit_judge env sigma in let pb = { env = env; @@ -2668,7 +2668,7 @@ let compile_cases ?loc style (typing_fun, sigma) tycon env (predopt, tomatchl, e (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env sigma = function | Some t -> typing_fun tycon env sigma t - | None -> use_unit_judge sigma in + | None -> use_unit_judge env sigma in let pb = { env = env; diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 0dc5a9bad5..592057ab41 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -647,6 +647,7 @@ and detype_r d flags avoid env sigma t = else GEvar (Id.of_string_soft ("M" ^ string_of_int n), []) | Var id -> + (* Discriminate between section variable and non-section variable *) (try let _ = Global.lookup_named id in GRef (VarRef id, None) with Not_found -> GVar id) | Sort s -> GSort (detype_sort sigma (ESorts.kind sigma s)) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index bae13dbba1..f0ff1aa93b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -46,20 +46,24 @@ let _ = Goptions.declare_bool_option { (*******************************************) (* Functions to deal with impossible cases *) (*******************************************) -(* XXX: we would like to search for this with late binding - "data.id.type" etc... *) -let impossible_default_case () = - let c, ctx = UnivGen.fresh_global_instance (Global.env()) (Globnames.ConstRef Coqlib.id) in +let impossible_default_case env = + let type_of_id = + let open Names.GlobRef in + match Coqlib.lib_ref "core.IDProp.type" with + | ConstRef c -> c + | VarRef _ | IndRef _ | ConstructRef _ -> assert false + in + let c, ctx = UnivGen.fresh_global_instance env (Coqlib.(lib_ref "core.IDProp.idProp")) in let (_, u) = Constr.destConst c in - Some (c, Constr.mkConstU (Coqlib.type_of_id, u), ctx) + Some (c, Constr.mkConstU (type_of_id, u), ctx) let coq_unit_judge = let open Environ in let make_judge c t = make_judge (EConstr.of_constr c) (EConstr.of_constr t) in let na1 = Name (Id.of_string "A") in let na2 = Name (Id.of_string "H") in - fun () -> - match impossible_default_case () with + fun env -> + match impossible_default_case env with | Some (id, type_of_id, ctx) -> make_judge id type_of_id, ctx | None -> @@ -1348,7 +1352,7 @@ let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with | loc,Evar_kinds.ImpossibleCase -> - let j, ctx = coq_unit_judge () in + let j, ctx = coq_unit_judge env in let evd' = Evd.merge_context_set Evd.univ_flexible_alg ?loc evd' ctx in let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 20a4f34ec7..350dece28a 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -80,4 +80,4 @@ val evar_eqappr_x : ?rhs_is_already_stuck:bool -> transparent_state * bool -> (**/**) (** {6 Functions to deal with impossible cases } *) -val coq_unit_judge : unit -> EConstr.unsafe_judgment Univ.in_universe_context_set +val coq_unit_judge : env -> EConstr.unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 44bfe4b6cc..62d719034c 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -42,7 +42,6 @@ let get_polymorphic_positions sigma f = let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) pbty env evd t = let evdref = ref evd in - let modified = ref false in (* direction: true for fresh universes lower than the existing ones *) let refresh_sort status ~direction s = let s = ESorts.kind !evdref s in @@ -51,18 +50,18 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let evd = if direction then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' - in - modified := true; evdref := evd; mkSort s' + in evdref := evd; mkSort s' in let rec refresh ~onlyalg status ~direction t = match EConstr.kind !evdref t with | Sort s -> begin match ESorts.kind !evdref s with | Type u -> - (match Univ.universe_level u with + (* TODO: check if max(l,u) is not ok as well *) + (match Univ.universe_level u with | None -> refresh_sort status ~direction s | Some l -> - (match Evd.universe_rigidity evd l with + (match Evd.universe_rigidity !evdref l with | UnivRigid -> if not onlyalg then refresh_sort status ~direction s else t @@ -76,34 +75,43 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) refresh_sort status ~direction s | _ -> t end - | Prod (na,u,v) -> - mkProd (na, u, refresh ~onlyalg status ~direction v) + | Prod (na,u,v) -> + let v' = refresh ~onlyalg status ~direction v in + if v' == v then t else mkProd (na, u, v') | _ -> t + in (** Refresh the types of evars under template polymorphic references *) - and refresh_term_evars onevars top t = + let rec refresh_term_evars ~onevars ~top t = match EConstr.kind !evdref t with | App (f, args) when is_template_polymorphic env !evdref f -> let pos = get_polymorphic_positions !evdref f in - refresh_polymorphic_positions args pos + refresh_polymorphic_positions args pos; t | App (f, args) when top && isEvar !evdref f -> - refresh_term_evars true false f; - Array.iter (refresh_term_evars onevars false) args + let f' = refresh_term_evars ~onevars:true ~top:false f in + let args' = Array.map (refresh_term_evars ~onevars ~top:false) args in + if f' == f && args' == args then t + else mkApp (f', args') | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh ~onlyalg univ_flexible ~direction:true evi.evar_concl in - if !modified then - evdref := Evd.add !evdref ev {evi with evar_concl = ty'} - else () - | _ -> EConstr.iter !evdref (refresh_term_evars onevars false) t + let ty = evi.evar_concl in + let ty' = refresh ~onlyalg univ_flexible ~direction:true ty in + if ty == ty' then t + else (evdref := Evd.downcast ev ty' !evdref; t) + | Sort s -> + (match ESorts.kind !evdref s with + | Type u when not (Univ.Universe.is_levels u) -> + refresh_sort Evd.univ_flexible ~direction:false s + | _ -> t) + | _ -> EConstr.map !evdref (refresh_term_evars ~onevars ~top:false) t and refresh_polymorphic_positions args pos = let rec aux i = function | Some l :: ls -> if i < Array.length args then - ignore(refresh_term_evars true false args.(i)); + ignore(refresh_term_evars ~onevars:true ~top:false args.(i)); aux (succ i) ls | None :: ls -> if i < Array.length args then - ignore(refresh_term_evars false false args.(i)); + ignore(refresh_term_evars ~onevars:false ~top:false args.(i)); aux (succ i) ls | [] -> () in aux 0 pos @@ -115,9 +123,8 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) (* No cumulativity needed, but we still need to refresh the algebraics *) refresh ~onlyalg:true univ_flexible ~direction:false t | Some direction -> refresh ~onlyalg status ~direction t - else (refresh_term_evars false true t; t) - in - if !modified then !evdref, t' else !evdref, t + else refresh_term_evars ~onevars:false ~top:true t + in !evdref, t' let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in @@ -418,7 +425,7 @@ let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t w let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) -let free_vars_and_rels_up_alias_expansion sigma aliases c = +let free_vars_and_rels_up_alias_expansion env sigma aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in @@ -450,7 +457,7 @@ let free_vars_and_rels_up_alias_expansion sigma aliases c = | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 | _ -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> - acc2 := Id.Set.union (vars_of_global (Global.env()) (EConstr.to_constr sigma c)) !acc2 + acc2 := Id.Set.union (vars_of_global env (EConstr.to_constr sigma c)) !acc2 | _ -> iter_with_full_binders sigma (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) @@ -481,13 +488,13 @@ let alias_distinct l = in check (Int.Set.empty, Id.Set.empty) l -let get_actual_deps evd aliases l t = +let get_actual_deps env evd aliases l t = if occur_meta_or_existential evd t then (* Probably no restrictions on allowed vars in presence of evars *) l else (* Probably strong restrictions coming from t being evar-closed *) - let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion evd aliases t in + let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion env evd aliases t in List.filter (function | VarAlias id -> Id.Set.mem id fv_ids | RelAlias n -> Int.Set.mem n fv_rels @@ -513,7 +520,7 @@ let remove_instance_local_defs evd evk args = let find_unification_pattern_args env evd l t = let aliases = make_alias_map env evd in match expand_and_check_vars evd aliases l with - | Some l as x when alias_distinct (get_actual_deps evd aliases l t) -> x + | Some l as x when alias_distinct (get_actual_deps env evd aliases l t) -> x | _ -> None let is_unification_pattern_meta env evd nb m l t = @@ -1195,7 +1202,7 @@ exception EvarSolvedOnTheFly of evar_map * EConstr.constr the common domain of definition *) let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) - let fvs2 = free_vars_and_rels_up_alias_expansion evd aliases (mkEvar ev2) in + let fvs2 = free_vars_and_rels_up_alias_expansion env evd aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) argsv1 in diff --git a/pretyping/program.ml b/pretyping/program.ml index 8cfb7966cb..bbabbefdc3 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -11,8 +11,6 @@ open CErrors open Util -let init_reference dir s () = Coqlib.coq_reference "Program" dir s - let papp evdref r args = let open EConstr in let gr = delayed_force r in @@ -20,44 +18,48 @@ let papp evdref r args = evdref := evd; mkApp (hd, args) -let sig_typ = init_reference ["Init"; "Specif"] "sig" -let sig_intro = init_reference ["Init"; "Specif"] "exist" -let sig_proj1 = init_reference ["Init"; "Specif"] "proj1_sig" - -let sigT_typ = init_reference ["Init"; "Specif"] "sigT" -let sigT_intro = init_reference ["Init"; "Specif"] "existT" -let sigT_proj1 = init_reference ["Init"; "Specif"] "projT1" -let sigT_proj2 = init_reference ["Init"; "Specif"] "projT2" - -let prod_typ = init_reference ["Init"; "Datatypes"] "prod" -let prod_intro = init_reference ["Init"; "Datatypes"] "pair" -let prod_proj1 = init_reference ["Init"; "Datatypes"] "fst" -let prod_proj2 = init_reference ["Init"; "Datatypes"] "snd" +let sig_typ () = Coqlib.lib_ref "core.sig.type" +let sig_intro () = Coqlib.lib_ref "core.sig.intro" +let sig_proj1 () = Coqlib.lib_ref "core.sig.proj1" +(* let sig_proj2 () = Coqlib.lib_ref "core.sig.proj2" *) -let coq_eq_ind = init_reference ["Init"; "Logic"] "eq" -let coq_eq_refl = init_reference ["Init"; "Logic"] "eq_refl" -let coq_eq_refl_ref = init_reference ["Init"; "Logic"] "eq_refl" -let coq_eq_rect = init_reference ["Init"; "Logic"] "eq_rect" +let sigT_typ () = Coqlib.lib_ref "core.sigT.type" +let sigT_intro () = Coqlib.lib_ref "core.sigT.intro" +let sigT_proj1 () = Coqlib.lib_ref "core.sigT.proj1" +let sigT_proj2 () = Coqlib.lib_ref "core.sigT.proj2" -let coq_JMeq_ind = init_reference ["Logic";"JMeq"] "JMeq" -let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl" +let prod_typ () = Coqlib.lib_ref "core.prod.type" +let prod_intro () = Coqlib.lib_ref "core.prod.intro" +let prod_proj1 () = Coqlib.lib_ref "core.prod.proj1" +let prod_proj2 () = Coqlib.lib_ref "core.prod.proj2" -let coq_not = init_reference ["Init";"Logic"] "not" -let coq_and = init_reference ["Init";"Logic"] "and" +let coq_eq_ind () = Coqlib.lib_ref "core.eq.type" +let coq_eq_refl () = Coqlib.lib_ref "core.eq.refl" +let coq_eq_refl_ref () = Coqlib.lib_ref "core.eq.refl" +let coq_eq_rect () = Coqlib.lib_ref "core.eq.rect" let mk_coq_not sigma x = - let sigma, notc = Evarutil.new_global sigma (coq_not ()) in + let sigma, notc = Evarutil.new_global sigma Coqlib.(lib_ref "core.not.type") in sigma, EConstr.mkApp (notc, [| x |]) +let coq_JMeq_ind () = + try Coqlib.lib_ref "core.JMeq.type" + with Not_found -> + user_err (Pp.str "cannot find Coq.Logic.JMeq.JMeq; maybe library Coq.Logic.JMeq has to be required first.") +let coq_JMeq_refl () = Coqlib.lib_ref "core.JMeq.refl" + +(* let coq_not () = Universes.constr_of_global @@ Coqlib.lib_ref "core.not.type" *) +(* let coq_and () = Universes.constr_of_global @@ Coqlib.lib_ref "core.and.type" *) + let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd | [] -> invalid_arg "unsafe_fold_right" let mk_coq_and sigma l = - let sigma, and_typ = Evarutil.new_global sigma (coq_and ()) in + let sigma, and_typ = Evarutil.new_global sigma Coqlib.(lib_ref "core.and.type") in sigma, unsafe_fold_right (fun c conj -> - EConstr.mkApp (and_typ, [| c ; conj |])) + EConstr.(mkApp (and_typ, [| c ; conj |]))) l (* true = transparent by default, false = opaque if possible *) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 3719f9302a..f8dc5ba4d6 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -230,8 +230,7 @@ let warn_projection_no_head_constant = ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) -let compute_canonical_projections warn (con,ind) = - let env = Global.env () in +let compute_canonical_projections env warn (con,ind) = let ctx = Environ.constant_context env con in let u = Univ.make_abstract_instance ctx in let v = (mkConstU (con,u)) in @@ -282,7 +281,10 @@ let warn_redundant_canonical_projection = ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s) let add_canonical_structure warn o = - let lo = compute_canonical_projections warn o in + (* 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) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in let ocs = try Some (assoc_pat cs_pat l) @@ -290,9 +292,6 @@ let add_canonical_structure warn o = in match ocs with | None -> object_table := GlobRef.Map.add proj ((pat,s)::l) !object_table; | Some (c, cs) -> - (* XXX: Undesired global access to env *) - let env = Global.env () in - let sigma = Evd.from_env env in 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 diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 4665486fc0..e3b942b610 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1417,7 +1417,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = and mimick_undefined_evar evd flags hdc nargs sp = let ev = Evd.find_undefined evd sp in - let sp_env = Global.env_of_context (evar_filtered_hyps ev) in + let sp_env = reset_with_named_context (evar_filtered_hyps ev) env in let (evd', c) = applyHead sp_env evd nargs hdc in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags @@ -1633,7 +1633,7 @@ let make_eq_test env evd c = let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = let t = match ty with Some t -> t | None -> get_type_of env sigma c in - let x = id_of_name_using_hdchar (Global.env()) sigma t name in + let x = id_of_name_using_hdchar env sigma t name in let ids = Environ.ids_of_named_context_val (named_context_val env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context_val x (named_context_val env) then diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index e7f995c84e..6d53349fa1 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -394,7 +394,7 @@ let tag_var = tag Tag.variable kw n ++ pr_binder false pr_c (nal,k,t) | (CLocalAssum _ | CLocalPattern _ | CLocalDef _) :: _ as bdl -> kw n ++ pr_undelimited_binders sep pr_c bdl - | [] -> assert false + | [] -> anomaly (Pp.str "The ast is malformed, found lambda/prod without proper binders.") let pr_binders_gen pr_c sep is_open = if is_open then pr_delimited_binders pr_com_at sep pr_c diff --git a/printing/printmod.ml b/printing/printmod.ml index 1fc308ac99..20e0a989f3 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -23,8 +23,6 @@ open Goptions - The "rich" one, that also tries to print the types of the fields. The short version used to be the default behavior, but now we print types by default. The following option allows changing this. - Technically, the environments in this file are either None in - the "short" mode or (Some env) in the "rich" one. *) module Tag = @@ -39,6 +37,8 @@ let tag t s = Pp.tag t s let tag_definition s = tag Tag.definition s let tag_keyword s = tag Tag.keyword s +type short = OnlyNames | WithContents + let short = ref false let _ = @@ -282,7 +282,7 @@ let nametab_register_modparam mbid mtb = List.iter (nametab_register_body mp dir) struc; id -let print_body is_impl env mp (l,body) = +let print_body is_impl extent env mp (l,body) = let name = Label.print l in hov 2 (match body with | SFBmodule _ -> keyword "Module" ++ spc () ++ name @@ -293,9 +293,9 @@ let print_body is_impl env mp (l,body) = | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () | _ -> def "Parameter" ++ spc ()) ++ name ++ - (match env with - | None -> mt () - | Some env -> + (match extent with + | OnlyNames -> mt () + | WithContents -> let bl = UnivNames.universe_binders_with_opt_names (ConstRef (Constant.make2 mp l)) None in let sigma = Evd.from_ctx (UState.of_binders bl) in str " :" ++ spc () ++ @@ -308,10 +308,10 @@ let print_body is_impl env mp (l,body) = | _ -> mt ()) ++ str "." ++ Printer.pr_abstract_universe_ctx sigma ctx) | SFBmind mib -> - try - let env = Option.get env in + match extent with + | WithContents -> pr_mutual_inductive_body env (MutInd.make2 mp l) mib None - with e when CErrors.noncritical e -> + | OnlyNames -> let keyword = let open Declarations in match mib.mind_finite with @@ -321,15 +321,14 @@ let print_body is_impl env mp (l,body) = in keyword ++ spc () ++ name) -let print_struct is_impl env mp struc = - prlist_with_sep spc (print_body is_impl env mp) struc +let print_struct is_impl extent env mp struc = + prlist_with_sep spc (print_body is_impl extent env mp) struc -let print_structure is_type env mp locals struc = - let env' = Option.map - (Modops.add_structure mp struc Mod_subst.empty_delta_resolver) env in +let print_structure is_type extent env mp locals struc = + let env' = Modops.add_structure mp struc Mod_subst.empty_delta_resolver env in nametab_register_module_body mp struc; let kwd = if is_type then "Sig" else "Struct" in - hv 2 (keyword kwd ++ spc () ++ print_struct false env' mp struc ++ + hv 2 (keyword kwd ++ spc () ++ print_struct false extent env' mp struc ++ brk (1,-2) ++ keyword "End") let rec flatten_app mexpr l = match mexpr with @@ -337,7 +336,7 @@ let rec flatten_app mexpr l = match mexpr with | MEident mp -> mp::l | MEwith _ -> assert false -let rec print_typ_expr env mp locals mty = +let rec print_typ_expr extent env mp locals mty = match mty with | MEident kn -> print_kn locals kn | MEapply _ -> @@ -347,19 +346,23 @@ let rec print_typ_expr env mp locals mty = hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ prlist_with_sep spc (print_modpath locals) mapp ++ str")") | MEwith(me,WithDef(idl,(c, _)))-> - let env' = None in (* TODO: build a proper environment if env <> None *) let s = String.concat "." (List.map Id.to_string idl) in - (* XXX: What should env and sigma be here? *) - let env = Global.env () in - let sigma = Evd.from_env env in - hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() - ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ Printer.pr_lconstr_env env sigma c) + let body = match extent with + | WithContents -> + let sigma = Evd.from_env env in + spc() ++ str ":=" ++ spc() ++ Printer.pr_lconstr_env env sigma c + | OnlyNames -> + mt() in + hov 2 (print_typ_expr extent env mp locals me ++ spc() ++ str "with" ++ spc() + ++ def "Definition"++ spc() ++ str s ++ body) | MEwith(me,WithMod(idl,mp'))-> let s = String.concat "." (List.map Id.to_string idl) in - hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++ - keyword "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc() - ++ print_modpath locals mp') + let body = match extent with + | WithContents -> + spc() ++ str ":="++ spc() ++ print_modpath locals mp' + | OnlyNames -> mt () in + hov 2 (print_typ_expr extent env mp locals me ++ spc() ++ str "with" ++ spc() ++ + keyword "Module"++ spc() ++ str s ++ body) let print_mod_expr env mp locals = function | MEident mp -> print_modpath locals mp @@ -369,31 +372,31 @@ let print_mod_expr env mp locals = function (str"(" ++ prlist_with_sep spc (print_modpath locals) lapp ++ str")") | MEwith _ -> assert false (* No 'with' syntax for modules *) -let rec print_functor fty fatom is_type env mp locals = function - |NoFunctor me -> fatom is_type env mp locals me - |MoreFunctor (mbid,mtb1,me2) -> +let rec print_functor fty fatom is_type extent env mp locals = function + | NoFunctor me -> fatom is_type extent env mp locals me + | MoreFunctor (mbid,mtb1,me2) -> let id = nametab_register_modparam mbid mtb1 in let mp1 = MPbound mbid in - let pr_mtb1 = fty env mp1 locals mtb1 in - let env' = Option.map (Modops.add_module_type mp1 mtb1) env in + let pr_mtb1 = fty extent env mp1 locals mtb1 in + let env' = Modops.add_module_type mp1 mtb1 env in let locals' = (mbid, get_new_id locals (MBId.to_id mbid))::locals in let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ str "(" ++ Id.print id ++ str ":" ++ pr_mtb1 ++ str ")" ++ - spc() ++ print_functor fty fatom is_type env' mp locals' me2) + spc() ++ print_functor fty fatom is_type extent env' mp locals' me2) let rec print_expression x = print_functor print_modtype - (function true -> print_typ_expr | false -> print_mod_expr) x + (function true -> print_typ_expr | false -> fun _ -> print_mod_expr) x and print_signature x = print_functor print_modtype print_structure x -and print_modtype env mp locals mtb = match mtb.mod_type_alg with - | Some me -> print_expression true env mp locals me - | None -> print_signature true env mp locals mtb.mod_type +and print_modtype extent env mp locals mtb = match mtb.mod_type_alg with + | Some me -> print_expression true extent env mp locals me + | None -> print_signature true extent env mp locals mtb.mod_type let rec printable_body dir = let dir = pop_dirpath dir in @@ -409,28 +412,28 @@ let rec printable_body dir = (** Since we might play with nametab above, we should reset to prior state after the printing *) -let print_expression' is_type env mp me = +let print_expression' is_type extent env mp me = States.with_state_protection - (fun e -> print_expression is_type env mp [] e) me + (fun e -> print_expression is_type extent env mp [] e) me -let print_signature' is_type env mp me = +let print_signature' is_type extent env mp me = States.with_state_protection - (fun e -> print_signature is_type env mp [] e) me + (fun e -> print_signature is_type extent env mp [] e) me -let unsafe_print_module env mp with_body mb = +let unsafe_print_module extent env mp with_body mb = let name = print_modpath [] mp in let pr_equals = spc () ++ str ":= " in let body = match with_body, mb.mod_expr with | false, _ | true, Abstract -> mt() - | _, Algebraic me -> pr_equals ++ print_expression' false env mp me - | _, Struct sign -> pr_equals ++ print_signature' false env mp sign - | _, FullStruct -> pr_equals ++ print_signature' false env mp mb.mod_type + | _, Algebraic me -> pr_equals ++ print_expression' false extent env mp me + | _, Struct sign -> pr_equals ++ print_signature' false extent env mp sign + | _, FullStruct -> pr_equals ++ print_signature' false extent env mp mb.mod_type in let modtype = match mb.mod_expr, mb.mod_type_alg with | FullStruct, _ -> mt () - | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true env mp ty - | _, _ -> brk (1,1) ++ str": " ++ print_signature' true env mp mb.mod_type + | _, Some ty -> brk (1,1) ++ str": " ++ print_expression' true extent env mp ty + | _, _ -> brk (1,1) ++ str": " ++ print_signature' true extent env mp mb.mod_type in hv 0 (keyword "Module" ++ spc () ++ name ++ modtype ++ body) @@ -440,19 +443,21 @@ let print_module with_body mp = let me = Global.lookup_module mp in try if !short then raise ShortPrinting; - unsafe_print_module (Some (Global.env ())) mp with_body me ++ fnl () + unsafe_print_module WithContents + (Global.env ()) mp with_body me ++ fnl () with e when CErrors.noncritical e -> - unsafe_print_module None mp with_body me ++ fnl () + unsafe_print_module OnlyNames + (Global.env ()) mp with_body me ++ fnl () let print_modtype kn = let mtb = Global.lookup_modtype kn in let name = print_kn [] kn in hv 1 (keyword "Module Type" ++ spc () ++ name ++ str " =" ++ spc () ++ - (try - if !short then raise ShortPrinting; - print_signature' true (Some (Global.env ())) kn mtb.mod_type - with e when CErrors.noncritical e -> - print_signature' true None kn mtb.mod_type)) - - + try + if !short then raise ShortPrinting; + print_signature' true WithContents + (Global.env ()) kn mtb.mod_type + with e when CErrors.noncritical e -> + print_signature' true OnlyNames + (Global.env ()) kn mtb.mod_type) diff --git a/proofs/logic.ml b/proofs/logic.ml index 613581ade7..285240872e 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -230,8 +230,7 @@ let hyp_of_move_location = function | MoveBefore id -> id | _ -> assert false -let move_hyp sigma toleft (left,declfrom,right) hto = - let env = Global.env() in +let move_hyp env sigma toleft (left,declfrom,right) hto = let test_dep d d2 = if toleft then occur_var_in_decl env sigma (NamedDecl.get_id d2) d @@ -280,11 +279,11 @@ let move_hyp_in_named_context env sigma hfrom hto sign = let open EConstr in let (left,right,declfrom,toleft) = split_sign env sigma hfrom hto (named_context_of_val sign) in - move_hyp sigma toleft (left,declfrom,right) hto + move_hyp env sigma toleft (left,declfrom,right) hto -let insert_decl_in_named_context sigma decl hto sign = +let insert_decl_in_named_context env sigma decl hto sign = let open EConstr in - move_hyp sigma false ([],decl,named_context_of_val sign) hto + move_hyp env sigma false ([],decl,named_context_of_val sign) hto (**********************************************************************) diff --git a/proofs/logic.mli b/proofs/logic.mli index 9db54732bb..2cad278e10 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -75,6 +75,6 @@ val convert_hyp : bool -> Environ.named_context_val -> evar_map -> val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> Environ.named_context_val -> Environ.named_context_val -val insert_decl_in_named_context : Evd.evar_map -> +val insert_decl_in_named_context : Environ.env -> Evd.evar_map -> EConstr.named_declaration -> Id.t move_location -> Environ.named_context_val -> Environ.named_context_val diff --git a/stm/stm.ml b/stm/stm.ml index b7ba163309..19915b1600 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1364,7 +1364,7 @@ module rec ProofTask : sig t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignement -> unit; + t_assign : Proof_global.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1403,7 +1403,7 @@ end = struct (* {{{ *) t_stop : Stateid.t; t_drop : bool; t_states : competence; - t_assign : Proof_global.closed_proof_output Future.assignement -> unit; + t_assign : Proof_global.closed_proof_output Future.assignment -> unit; t_loc : Loc.t option; t_uuid : Future.UUID.t; t_name : string } @@ -1843,7 +1843,7 @@ and TacTask : sig type task = { t_state : Stateid.t; t_state_fb : Stateid.t; - t_assign : output Future.assignement -> unit; + t_assign : output Future.assignment -> unit; t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; @@ -1860,7 +1860,7 @@ end = struct (* {{{ *) type task = { t_state : Stateid.t; t_state_fb : Stateid.t; - t_assign : output Future.assignement -> unit; + t_assign : output Future.assignment -> unit; t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index e12063fd44..bd95a62532 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -12,7 +12,6 @@ open Constr open EConstr open Hipattern open Tactics -open Coqlib open Reductionops open Proofview.Notations @@ -33,8 +32,8 @@ let absurd c = let sigma, j = Coercion.inh_coerce_to_sort env sigma j in let t = j.Environ.utj_val in Proofview.Unsafe.tclEVARS sigma <*> - Tacticals.New.pf_constr_of_global (build_coq_not ()) >>= fun coqnot -> - Tacticals.New.pf_constr_of_global (build_coq_False ()) >>= fun coqfalse -> + Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.not.type")) >>= fun coqnot -> + Tacticals.New.pf_constr_of_global (Coqlib.(lib_ref "core.False.type")) >>= fun coqfalse -> Tacticals.New.tclTHENLIST [ elim_type coqfalse; Simple.apply (mk_absurd_proof coqnot t) diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 832014a610..f2bc679aac 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -27,7 +27,6 @@ open Constr_matching open Hipattern open Proofview.Notations open Tacmach.New -open Coqlib open Tactypes (* This file containts the implementation of the tactics ``Decide @@ -269,9 +268,10 @@ let decideEquality rectype ops = (* The tactic Compare *) let compare c1 c2 = - pf_constr_of_global (build_coq_sumbool ()) >>= fun opc -> - pf_constr_of_global (Coqlib.build_coq_eq ()) >>= fun eqc -> - pf_constr_of_global (build_coq_not ()) >>= fun notc -> + let open Coqlib in + pf_constr_of_global (lib_ref "core.sumbool.type") >>= fun opc -> + pf_constr_of_global (lib_ref "core.eq.type") >>= fun eqc -> + pf_constr_of_global (lib_ref "core.not.type") >>= fun notc -> Proofview.Goal.enter begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in let ops = (opc,eqc,notc) in diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index ea5ff4a6cb..16b94cd154 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -99,7 +99,7 @@ let my_it_mkLambda_or_LetIn_name s c = let get_coq_eq ctx = try - let eq = Globnames.destIndRef Coqlib.glob_eq in + let eq = Globnames.destIndRef (Coqlib.lib_ref "core.eq.type") in (* Do not force the lazy if they are not defined *) let eq, ctx = with_context_set ctx (UnivGen.fresh_inductive_instance (Global.env ()) eq) in diff --git a/tactics/equality.ml b/tactics/equality.ml index 510f119229..3e3ef78c5d 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -339,12 +339,17 @@ let jmeq_same_dom env sigma = function let find_elim hdcncl lft2rgt dep cls ot = Proofview.Goal.enter_one begin fun gl -> let sigma = project gl in - let is_global gr c = Termops.is_global sigma gr c in + let is_global_exists gr c = + Coqlib.has_ref gr && Termops.is_global sigma (Coqlib.lib_ref gr) c + in let inccl = Option.is_empty cls in let env = Proofview.Goal.env gl in - if (is_global Coqlib.glob_eq hdcncl || - (is_global Coqlib.glob_jmeq hdcncl && - jmeq_same_dom env sigma ot)) && not dep + (* if (is_global Coqlib.glob_eq hdcncl || *) + (* (is_global Coqlib.glob_jmeq hdcncl && *) + (* jmeq_same_dom env sigma ot)) && not dep *) + if (is_global_exists "core.eq.type" hdcncl || + (is_global_exists "core.JMeq.type" hdcncl + && jmeq_same_dom env sigma ot)) && not dep then let c = match EConstr.kind sigma hdcncl with @@ -588,7 +593,7 @@ let classes_dirpath = let init_setoid () = if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () - else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] + else check_required_library ["Coq";"Setoids";"Setoid"] let check_setoid cl = Option.fold_left @@ -637,8 +642,8 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> - let e = build_coq_eq () in - let sym = build_coq_eq_sym () in + let e = lib_ref "core.eq.type" in + let sym = lib_ref "core.eq.sym" in Tacticals.New.pf_constr_of_global sym >>= fun sym -> Tacticals.New.pf_constr_of_global e >>= fun e -> let eq = applist (e, [t1;c1;c2]) in @@ -930,9 +935,9 @@ let build_selector env sigma dirn c ind special default = let ans = Inductiveops.make_case_or_project env sigma indf ci p c (Array.of_list brl) in ans -let build_coq_False () = pf_constr_of_global (build_coq_False ()) -let build_coq_True () = pf_constr_of_global (build_coq_True ()) -let build_coq_I () = pf_constr_of_global (build_coq_I ()) +let build_coq_False () = pf_constr_of_global (lib_ref "core.False.type") +let build_coq_True () = pf_constr_of_global (lib_ref "core.True.type") +let build_coq_I () = pf_constr_of_global (lib_ref "core.True.I") let rec build_discriminator env sigma true_0 false_0 dirn c = function | [] -> @@ -1320,15 +1325,15 @@ let inject_if_homogenous_dependent_pair ty = let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in (* fetch the informations of the pair *) - let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in - let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in + let sigTconstr = Coqlib.(lib_ref "core.sigT.type") in + let existTconstr = Coqlib.lib_ref "core.sigT.intro" in (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app sigma t) in - if not (Termops.is_global sigma (sigTconstr()) eqTypeDest) then raise Exit; + if not (Termops.is_global sigma sigTconstr eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect sigma t1 and hd2,ar2 = decompose_app_vect sigma t2 in - if not (Termops.is_global sigma (existTconstr()) hd1) then raise Exit; - if not (Termops.is_global sigma (existTconstr()) hd2) then raise Exit; + if not (Termops.is_global sigma existTconstr hd1) then raise Exit; + if not (Termops.is_global sigma existTconstr hd2) then raise Exit; let (ind, _), _ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) @@ -1336,17 +1341,16 @@ let inject_if_homogenous_dependent_pair ty = (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; - Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; + check_required_library ["Coq";"Logic";"Eqdep_dec"]; let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in - let inj2 = Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] - "inj_pair2_eq_dec" in + let inj2 = lib_ref "core.eqdep_dec.inj_pair2" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> - Tacticals.New.pf_constr_of_global Coqlib.glob_eq >>= fun ceq -> + Tacticals.New.pf_constr_of_global Coqlib.(lib_ref "core.eq.type") >>= fun ceq -> tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar sigma hyp]; Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 -> @@ -1671,8 +1675,8 @@ let _ = optwrite = (:=) regular_subst_tactic } let restrict_to_eq_and_identity eq = (* compatibility *) - if not (is_global glob_eq eq) && - not (is_global glob_identity eq) + if not (is_global (lib_ref "core.eq.type") eq) && + not (is_global (lib_ref "core.identity.type") eq) then raise Constr_matching.PatternMatchingFailure exception FoundHyp of (Id.t * constr * bool) diff --git a/tactics/hints.ml b/tactics/hints.ml index af6d1c472f..245bdce5ad 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1292,13 +1292,13 @@ let project_hint ~poly pri l2r r = let sigma, c = Evd.fresh_global env sigma gr in let t = Retyping.get_type_of env sigma c in let t = - Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in + Tacred.reduce_to_quantified_ref env sigma (lib_ref "core.iff.type") t in let sign,ccl = decompose_prod_assum sigma t in let (a,b) = match snd (decompose_app sigma ccl) with | [a;b] -> (a,b) | _ -> assert false in let p = - if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + if l2r then lib_ref "core.iff.proj1" else lib_ref "core.iff.proj2" in let sigma, p = Evd.fresh_global env sigma p in let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in let c = it_mkLambda_or_LetIn diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index a1bb0a7401..708412720a 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -289,24 +289,22 @@ let coq_refl_jm_pattern = mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "A"; mkGVar "x";]))) -open Globnames - let match_with_equation env sigma t = if not (isApp sigma t) then raise NoEquationFound; let (hdapp,args) = destApp sigma t in match EConstr.kind sigma hdapp with | Ind (ind,u) -> - if GlobRef.equal (IndRef ind) glob_eq then - Some (build_coq_eq_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if GlobRef.equal (IndRef ind) glob_identity then - Some (build_coq_identity_data()),hdapp, - PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if GlobRef.equal (IndRef ind) glob_jmeq then - Some (build_coq_jmeq_data()),hdapp, - HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) - else - let (mib,mip) = Global.lookup_inductive ind in + if Coqlib.check_ind_ref "core.eq.type" ind then + Some (build_coq_eq_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.identity.type" ind then + Some (build_coq_identity_data()),hdapp, + PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) + else if Coqlib.check_ind_ref "core.JMeq.type" ind then + Some (build_coq_jmeq_data()),hdapp, + HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) + else + let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then @@ -438,12 +436,12 @@ let match_eq sigma eqn (ref, hetero) = | _ -> raise PatternMatchingFailure let no_check () = true -let check_jmeq_loaded () = Library.library_is_loaded @@ Coqlib.jmeq_library_path +let check_jmeq_loaded () = has_ref "core.JMeq.type" let equalities = - [(coq_eq_ref, false), no_check, build_coq_eq_data; - (coq_jmeq_ref, true), check_jmeq_loaded, build_coq_jmeq_data; - (coq_identity_ref, false), no_check, build_coq_identity_data] + [(lazy(lib_ref "core.eq.type"), false), no_check, build_coq_eq_data; + (lazy(lib_ref "core.JMeq.type"), true), check_jmeq_loaded, build_coq_jmeq_data; + (lazy(lib_ref "core.identity.type"), false), no_check, build_coq_identity_data] let find_eq_data sigma eqn = (* fails with PatternMatchingFailure *) let d,k = first_match (match_eq sigma eqn) equalities in @@ -478,9 +476,9 @@ let find_this_eq_data_decompose gl eqn = let match_sigma env sigma ex = match EConstr.kind sigma ex with - | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (Lazy.force coq_exist_ref) f -> + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sig.intro") f -> build_sigma (), (snd (destConstruct sigma f), a, p, car, cdr) - | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (Lazy.force coq_existT_ref) f -> + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (lib_ref "core.sigT.intro") f -> build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) | _ -> raise PatternMatchingFailure @@ -489,7 +487,7 @@ let find_sigma_data_decompose env ex = (* fails with PatternMatchingFailure *) (* Pattern "(sig ?1 ?2)" *) let coq_sig_pattern = - lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) + lazy (mkPattern (mkGAppRef (lazy (lib_ref "core.sig.type")) [mkGPatVar "X1"; mkGPatVar "X2"])) let match_sigma env sigma t = match Id.Map.bindings (matches env sigma (Lazy.force coq_sig_pattern) t) with @@ -507,44 +505,44 @@ let is_matching_sigma env sigma t = is_matching env sigma (Lazy.force coq_sig_pa let coq_eqdec ~sum ~rev = lazy ( - let eqn = mkGAppRef coq_eq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"]) in - let args = [eqn; mkGAppRef coq_not_ref [eqn]] in + let eqn = mkGAppRef (lazy (lib_ref "core.eq.type")) (List.map mkGPatVar ["X1"; "X2"; "X3"]) in + let args = [eqn; mkGAppRef (lazy (lib_ref "core.not.type")) [eqn]] in let args = if rev then List.rev args else args in mkPattern (mkGAppRef sum args) ) +let sumbool_type = lazy (lib_ref "core.sumbool.type") +let or_type = lazy (lib_ref "core.or.type") + (** [{ ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 }] *) -let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false +let coq_eqdec_inf_pattern = coq_eqdec ~sum:sumbool_type ~rev:false (** [{ ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 }] *) -let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true +let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:sumbool_type ~rev:true (** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *) -let coq_eqdec_pattern = coq_eqdec ~sum:coq_or_ref ~rev:false +let coq_eqdec_pattern = coq_eqdec ~sum:or_type ~rev:false (** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *) -let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true - -let op_or = coq_or_ref -let op_sum = coq_sumbool_ref +let coq_eqdec_rev_pattern = coq_eqdec ~sum:or_type ~rev:true let match_eqdec env sigma t = let eqonleft,op,subst = - try true,op_sum,matches env sigma (Lazy.force coq_eqdec_inf_pattern) t + try true,sumbool_type,matches env sigma (Lazy.force coq_eqdec_inf_pattern) t with PatternMatchingFailure -> - try false,op_sum,matches env sigma (Lazy.force coq_eqdec_inf_rev_pattern) t + try false,sumbool_type,matches env sigma (Lazy.force coq_eqdec_inf_rev_pattern) t with PatternMatchingFailure -> - try true,op_or,matches env sigma (Lazy.force coq_eqdec_pattern) t + try true,or_type,matches env sigma (Lazy.force coq_eqdec_pattern) t with PatternMatchingFailure -> - false,op_or,matches env sigma (Lazy.force coq_eqdec_rev_pattern) t in + false,or_type,matches env sigma (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Lazy.force op, c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern.") (* Patterns "~ ?" and "? -> False" *) -let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) -let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) +let coq_not_pattern = lazy (mkPattern (mkGAppRef (lazy (lib_ref "core.not.type")) [mkGHole])) +let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef (lazy (lib_ref "core.False.type"))))) let is_matching_not env sigma t = is_matching env sigma (Lazy.force coq_not_pattern) t let is_matching_imp_False env sigma t = is_matching env sigma (Lazy.force coq_imp_False_pattern) t diff --git a/tactics/inv.ml b/tactics/inv.ml index 5ac4284b43..6a39a10fc4 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -350,7 +350,7 @@ let remember_first_eq id x = if !x == Logic.MoveLast then x := Logic.MoveAfter i let dest_nf_eq env sigma t = match EConstr.kind sigma t with | App (r, [| t; x; y |]) -> let open Reductionops in - let lazy eq = Coqlib.coq_eq_ref in + let eq = Coqlib.lib_ref "core.eq.type" in if EConstr.is_global sigma eq r then (t, whd_all env sigma x, whd_all env sigma y) else user_err Pp.(str "Not an equality.") diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f3f81ff616..18ddc9318d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -451,7 +451,7 @@ let internal_cut_gen ?(check=true) dir replace id t = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in - let sign' = insert_decl_in_named_context sigma (LocalAssum (id,t)) nexthyp sign' in + let sign' = insert_decl_in_named_context env sigma (LocalAssum (id,t)) nexthyp sign' in sign',t,concl,sigma else (if check && mem_named_context_val id sign then @@ -3552,12 +3552,13 @@ let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") -let coq_eq sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq ()) -let coq_eq_refl sigma = Evarutil.new_global sigma (Coqlib.build_coq_eq_refl ()) +let coq_eq sigma = Evarutil.new_global sigma Coqlib.(lib_ref "core.eq.type") +let coq_eq_refl sigma = Evarutil.new_global sigma Coqlib.(lib_ref "core.eq.refl") -let coq_heq_ref = lazy (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq") +let coq_heq_ref = lazy (Coqlib.lib_ref "core.JMeq.type") let coq_heq sigma = Evarutil.new_global sigma (Lazy.force coq_heq_ref) -let coq_heq_refl sigma = Evarutil.new_global sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl") +let coq_heq_refl sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.JMeq.refl") +(* let coq_heq_refl = lazy (glob (lib_ref "core.JMeq.refl")) *) let mkEq sigma t x y = let sigma, eq = coq_eq sigma in @@ -3789,7 +3790,7 @@ let abstract_args gl generalize_vars dep id defined f args = let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in Proofview.Goal.enter begin fun gl -> - Coqlib.check_required_library Coqlib.jmeq_module_name; + Coqlib.(check_required_library jmeq_module_name); let sigma = Tacmach.New.project gl in let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in @@ -3849,7 +3850,7 @@ let specialize_eqs id = match EConstr.kind !evars ty with | Prod (na, t, b) -> (match EConstr.kind !evars t with - | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars (Lazy.force coq_eq_ref) eq -> + | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars Coqlib.(lib_ref "core.eq.type") eq -> let c = if noccur_between !evars 1 (List.length ctx) x then y else x in let pt = mkApp (eq, [| eqty; c; c |]) in let ind = destInd !evars eq in @@ -5017,21 +5018,17 @@ let cache_term_by_tactic_then ~opaque ?(goal_type=None) id gk tac tacK = Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in let cst = Impargs.with_implicit_protection cst () in - let lem = - match const.Entries.const_entry_universes with - | Entries.Polymorphic_const_entry uctx -> - let uctx = Univ.ContextSet.of_context uctx in - (** Hack: the kernel may generate definitions whose universe variables are - not the same as requested in the entry because of constraints delayed - in the body, even in polymorphic mode. We mimick what it does for now - in hope it is fixed at some point. *) - let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in - let uctx = Univ.ContextSet.to_context (Univ.ContextSet.union uctx body_uctx) in - let u = Univ.UContext.instance uctx in - mkConstU (cst, EInstance.make u) - | Entries.Monomorphic_const_entry _ -> - mkConst cst + let inst = match const.Entries.const_entry_universes with + | Entries.Monomorphic_const_entry _ -> EInstance.empty + | Entries.Polymorphic_const_entry ctx -> + (** We mimick what the kernel does, that is ensuring that no additional + constraints appear in the body of polymorphic constants. Ideally this + should be enforced statically. *) + let (_, body_uctx), _ = Future.force const.Entries.const_entry_body in + let () = assert (Univ.ContextSet.is_empty body_uctx) in + EInstance.make (Univ.UContext.instance ctx) in + let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in let eff = private_con_of_con (Global.safe_env ()) cst in diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b99d80e95f..b85258505b 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/Makefile b/test-suite/Makefile index e35393b5e8..928a77cb8e 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -43,8 +43,8 @@ coqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite coqdoc := $(BIN)coqdoc coqtopbyte := $(BIN)coqtop.byte -coqtopload := $(coqtop) -top Top -async-proofs-cache force -load-vernac-source -coqtopcompile := $(coqtop) -compile +coqtopload := $(coqtop) -async-proofs-cache force -load-vernac-source +coqtopcompile := $(coqtop) -async-proofs-cache force -compile coqdep := $(BIN)coqdep -coqlib $(LIB) VERBOSE?= @@ -122,7 +122,7 @@ run: $(SUBSYSTEMS) bugs: $(BUGS) clean: - rm -f trace .lia.cache output/MExtraction.out + rm -f trace .nia.cache .lia.cache output/MExtraction.out $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' -o -name '*.glob' \ @@ -213,7 +213,7 @@ $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...still active"; \ @@ -235,7 +235,7 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -250,11 +250,22 @@ $(addsuffix .log,$(wildcard bugs/closed/*.v)): %.v.log: %.v # Unit tests ####################################################################### -OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) -SYSMOD:=-package num,str,unix,dynlink,threads +# An alternative is ifeq ($(OS),Windows_NT) using make's own variable. +ifeq ($(ARCH),win32) + export FINDLIB_SEP=";" +else + export FINDLIB_SEP=":" +endif + +# COQLIBINSTALL is quoted in config/make thus we must unquote it, +# otherwise the directory name will include the quotes, see +# see for example https://stackoverflow.com/questions/10424645/how-to-convert-a-quoted-string-to-a-normal-one-in-makefile -COQSRCDIRS:=$(addprefix -I $(LIB)/,$(CORESRCDIRS)) -COQCMXS:=$(addprefix $(LIB)/,$(LINKCMX)) +ifeq ($(LOCAL),true) + export OCAMLPATH := $(shell echo $(COQLIBINSTALL)$(FINDLIB_SEP)$$OCAMLPATH) +endif + +OCAMLOPT := $(OCAMLFIND) opt $(CAMLFLAGS) # ML files from unit-test framework, not containing tests UNIT_SRCFILES:=$(shell find ./unit-tests/src -name *.ml) @@ -278,10 +289,8 @@ unit-tests: $(UNIT_LOGFILES) # Build executable, run it to generate log file unit-tests/%.ml.log: unit-tests/%.ml $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLOPT) -linkall -linkpkg -cclib -lcoqrun \ - $(SYSMOD) -package camlp5.gramlib,oUnit \ - -I unit-tests/src $(COQSRCDIRS) $(COQCMXS) \ - $(UNIT_CMXS) $< -o $<.test; + $(HIDE)$(OCAMLOPT) -linkall -linkpkg -package coq.toplevel,oUnit \ + -I unit-tests/src $(UNIT_CMXS) $< -o $<.test; $(HIDE)./$<.test ####################################################################### @@ -309,7 +318,7 @@ $(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v)): %.v $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ echo $(call log_intro,$<); \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ + $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -341,7 +350,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ @@ -482,7 +491,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(call get_command_based_on_flags,"$<") "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqtopcompile) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_success); \ echo " $<...still wished"; \ diff --git a/test-suite/bugs/closed/bug_4132.v b/test-suite/bugs/closed/bug_4132.v index 806ffb771f..67ecc3087f 100644 --- a/test-suite/bugs/closed/bug_4132.v +++ b/test-suite/bugs/closed/bug_4132.v @@ -26,6 +26,6 @@ Qed. Lemma foo3 x y (b := 0) (H1 : x <= y) (H2 : y <= b) : x <= b. omega. (* Pierre L: according to a comment of bug report #4132, - this might have triggered "Failure(occurence 2)" in the past, + this might have triggered "Failure(occurrence 2)" in the past, but I never managed to reproduce that. *) Qed. diff --git a/test-suite/bugs/closed/bug_5197.v b/test-suite/bugs/closed/bug_5197.v new file mode 100644 index 0000000000..b67e93d677 --- /dev/null +++ b/test-suite/bugs/closed/bug_5197.v @@ -0,0 +1,44 @@ +Set Universe Polymorphism. +Set Primitive Projections. +Unset Printing Primitive Projection Compatibility. +Axiom Ω : Type. + +Record Pack (A : Ω -> Type) (Aᴿ : Ω -> (forall ω : Ω, A ω) -> Type) := mkPack { + elt : forall ω, A ω; + prp : forall ω, Aᴿ ω elt; +}. + +Record TYPE := mkTYPE { + wit : Ω -> Type; + rel : Ω -> (forall ω : Ω, wit ω) -> Type; +}. + +Definition El (A : TYPE) : Type := Pack A.(wit) A.(rel). + +Definition Typeᶠ : TYPE := {| + wit := fun _ => Type; + rel := fun _ A => (forall ω : Ω, A ω) -> Type; + |}. +Set Printing Universes. +Fail Definition Typeᵇ : El Typeᶠ := + mkPack _ _ (fun w => Type) (fun w A => (forall ω, A ω) -> Type). + +Definition Typeᵇ : El Typeᶠ := + mkPack _ (fun _ (A : Ω -> Type) => (forall ω : Ω, A ω) -> _) (fun w => Type) (fun w A => (forall ω, A ω) -> Type). + +(** Bidirectional typechecking helps here *) +Require Import Program.Tactics. +Program Definition progTypeᵇ : El Typeᶠ := + mkPack _ _ (fun w => Type) (fun w A => (forall ω, A ω) -> Type). + +(** +The command has indeed failed with message: +Error: Conversion test raised an anomaly +**) + +Definition Typeᵇ' : El Typeᶠ. +Proof. +unshelve refine (mkPack _ _ _ _). ++ refine (fun _ => Type). ++ simpl. refine (fun _ A => (forall ω, A ω) -> Type). +Defined. diff --git a/test-suite/bugs/closed/8553.v b/test-suite/bugs/closed/bug_8553.v index 4a1afabe89..4a1afabe89 100644 --- a/test-suite/bugs/closed/8553.v +++ b/test-suite/bugs/closed/bug_8553.v diff --git a/test-suite/bugs/closed/8672.v b/test-suite/bugs/closed/bug_8672.v index 66cd6dfa8c..66cd6dfa8c 100644 --- a/test-suite/bugs/closed/8672.v +++ b/test-suite/bugs/closed/bug_8672.v diff --git a/test-suite/dune b/test-suite/dune new file mode 100644 index 0000000000..c5fa0bb14a --- /dev/null +++ b/test-suite/dune @@ -0,0 +1,73 @@ +(rule + (targets summary.log) + (deps + ; File that should be promoted. + misc/universes/all_stdlib.v + ; Dependencies of the legacy makefile + ../Makefile.common + ../config/Makefile + ; Stuff for the compat script test + ../dev/header.ml + ../dev/tools/update-compat.py + ../doc/stdlib/index-list.html.template + (package coq) + ; For fake_ide + (package coqide-server) + (source_tree .)) + ; Finer-grained dependencies look like this + ; ../tools/CoqMakefile.in + ; ../theories/Init/Prelude.vo + ; ../theories/Arith/Arith.vo + ; ../theories/Arith/Compare.vo + ; ../theories/PArith/PArith.vo + ; ../theories/QArith/QArith.vo + ; ../theories/QArith/Qcanon.vo + ; ../theories/ZArith/ZArith.vo + ; ../theories/ZArith/Zwf.vo + ; ../theories/Sets/Ensembles.vo + ; ../theories/Numbers/Natural/Peano/NPeano.vo + ; ../theories/Numbers/Cyclic/Int31/Cyclic31.vo + ; ../theories/FSets/FMaps.vo + ; ../theories/FSets/FSets.vo + ; ../theories/MSets/MSets.vo + ; ../theories/Compat/Coq87.vo + ; ../theories/Compat/Coq88.vo + ; ../theories/Relations/Relations.vo + ; ../theories/Unicode/Utf8.vo + ; ../theories/Program/Program.vo + ; ../theories/Classes/EquivDec.vo + ; ../theories/Classes/DecidableClass.vo + ; ../theories/Classes/SetoidClass.vo + ; ../theories/Classes/RelationClasses.vo + ; ../theories/Logic/Classical.vo + ; ../theories/Logic/Hurkens.vo + ; ../theories/Logic/ClassicalFacts.vo + ; ../theories/Reals/Reals.vo + ; ../theories/Lists/Streams.vo + ; ../plugins/micromega/Lia.vo + ; ../plugins/micromega/Lqa.vo + ; ../plugins/micromega/Psatz.vo + ; ../plugins/micromega/MExtraction.vo + ; ../plugins/nsatz/Nsatz.vo + ; ../plugins/omega/Omega.vo + ; ../plugins/ssr/ssrbool.vo + ; ../plugins/derive/Derive.vo + ; ../plugins/funind/Recdef.vo + ; ../plugins/extraction/Extraction.vo + ; ../plugins/extraction/ExtrOcamlNatInt.vo + ; coqtop + ; coqtop.opt + ; coqidetop.opt + ; coqqueryworker.opt + ; coqtacticworker.opt + ; coqproofworker.opt + ; coqc + ; coqchk + ; coqdoc + ; %{bin:coq_makefile} + ; %{bin:fake_ide} + (action + (progn + ; XXX: we will allow to set the NJOBS variable in a future Dune + ; version, either by using an env var or by letting Dune set `-j` + (run make -j 2 BIN= PRINT_LOGS=1)))) diff --git a/test-suite/micromega/example.v b/test-suite/micromega/example.v index 25e4a09fa0..d70bb809c6 100644 --- a/test-suite/micromega/example.v +++ b/test-suite/micromega/example.v @@ -12,25 +12,48 @@ Open Scope Z_scope. Require Import ZMicromega. Require Import VarMap. -(* false in Q : x=1/2 and n=1 *) - Lemma not_so_easy : forall x n : Z, 2*x + 1 <= 2 *n -> x <= n-1. Proof. intros. - lia. + psatz Z 2. Qed. + (* From Laurent Théry *) -Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. +Goal forall (x y : Z), x = 0 -> x * y = 0. +Proof. + intros. + psatz Z 2. +Qed. + +Goal forall (x y : Z), x = 0 -> x * y = 0. +Proof. + intros. + psatz Z 2. +Qed. + +Goal forall (x y : Z), 2*x = 0 -> x * y = 0. Proof. intros. psatz Z 2. Qed. +Goal forall (x y: Z), - x*x >= 0 -> x * y = 0. +Proof. + intros. + psatz Z 4. +Qed. + +Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. +Proof. + intros. + psatz Z 2. +Qed. + Lemma Zdiscr: forall a b c x, a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. Proof. @@ -42,11 +65,9 @@ Lemma plus_minus : forall x y, 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. Proof. intros. - lia. + psatz Z 1. Qed. - - Lemma mplus_minus : forall x y, x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. Proof. @@ -95,7 +116,7 @@ Proof. generalize (H8 _ _ _ (conj H5 H4)). generalize (H10 _ _ _ (conj H5 H4)). generalize rho_ge. - psatz Z 2. + zify; intuition subst ; psatz Z 2. Qed. (* Rule of signs *) @@ -118,18 +139,12 @@ Proof. intros; psatz Z 2. Qed. -Lemma sign_zer_pos: forall x y, +Lemma sign_zero_pos: forall x y, x = 0 -> y > 0 -> x*y = 0. Proof. intros; psatz Z 2. Qed. -Lemma sign_zero_zero: forall x y, - x = 0 -> y = 0 -> x*y = 0. -Proof. - intros; psatz Z 2. -Qed. - Lemma sign_zero_neg: forall x y, x = 0 -> y < 0 -> x*y = 0. Proof. @@ -157,12 +172,6 @@ Qed. (* Other (simple) examples *) -Lemma binomial : forall x y, (x+y)^2 = x^2 + 2*x*y + y^2. -Proof. - intros. - lia. -Qed. - Lemma product : forall x y, x >= 0 -> y >= 0 -> x * y >= 0. Proof. intros. @@ -170,13 +179,6 @@ Proof. Qed. -Lemma product_strict : forall x y, x > 0 -> y > 0 -> x * y > 0. -Proof. - intros. - psatz Z 2. -Qed. - - Lemma pow_2_pos : forall x, x ^ 2 + 1 = 0 -> False. Proof. intros ; psatz Z 2. @@ -229,8 +231,6 @@ Proof. intros; psatz Z 3. Qed. - - Lemma hol_light7 : forall x y z, 0<= x /\ 0 <= y /\ 0 <= z /\ x + y + z <= 3 -> x * y + x * z + y * z >= 3 * x * y * z. @@ -251,6 +251,7 @@ Proof. intros; psatz Z 2. Qed. + Lemma hol_light10 : forall x y, x >= 1 /\ y >= 1 -> x * y >= x + y - 1. Proof. @@ -275,6 +276,7 @@ Proof. unfold e ; intros ; psatz Z 2. Qed. + Lemma hol_light14 : forall x y z, 2 <= x /\ x <= 4 /\ 2 <= y /\ y <= 4 /\ 2 <= z /\ z <= 4 -> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z). @@ -300,6 +302,7 @@ Proof. intros ; psatz Z 3. Qed. + Lemma hol_light18 : forall x y, 0 <= x /\ 0 <= y -> x * y * (x + y) ^ 2 <= (x ^ 2 + y ^ 2) ^ 2. Proof. @@ -310,18 +313,12 @@ Qed. (* Some examples over integers and natural numbers. *) (* ------------------------------------------------------------------------- *) -Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. -Proof. - intros ; lia. -Qed. - Lemma hol_light22 : forall n, n >= 0 -> n <= n * n. Proof. intros. psatz Z 2. Qed. - Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) -> (x1 + y1 = x2 + y2). @@ -336,11 +333,89 @@ Proof. psatz Z 1. Qed. - - Lemma motzkin : forall x y, (x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. Proof. intros. generalize (motzkin' x y). psatz Z 8. Qed. + +(** Other tests *) + +Goal forall x y z n, + y >= z /\ y = n \/ ~ y >= z /\ z = n -> + x >= y /\ + (x >= z /\ (x >= n /\ x = x \/ ~ x >= n /\ x = n) \/ + ~ x >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)) \/ + ~ x >= y /\ + (y >= z /\ (x >= n /\ y = x \/ ~ x >= n /\ y = n) \/ + ~ y >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)). +Proof. + intros. + psatz Z 2. +Qed. + +(** Incompeteness: require manual case split *) +Goal forall (z0 z z1 z2 z3 z5 :Z) +(H8 : 0 <= z2) +(H5 : z5 > 0) +(H0 : z0 > 0) +(H9 : z2 < z0) +(H1 : z0 * z5 > 0) +(H10 : 0 <= z1 * z0 + z0 * z5 - 1 - z0 * z5 * z) +(H11 : z1 * z0 + z0 * z5 - 1 - z0 * z5 * z < z0 * z5) +(H6 : 0 <= z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3) +(H7 : z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3 < z0 * z5) +(C : z > z3), False. +Proof. + intros. + assert (z1 - z5 * z3 - 1 < 0) by psatz Z 3. + psatz Z 3. +Qed. + +Goal forall + (d sz x n : Z) + (GE : sz * x - sz * d >=1 ) + (R : sz + d * sz - sz * x >= 1), + False. +Proof. + intros. + assert (x - d >= 1) by psatz Z 3. + psatz Z 3. +Qed. + + +Goal forall x6 x8 x9 x10 x11 x12 x13 x14, + x6 >= 0 -> + -x6 + x8 + x9 + -x10 >= 1 -> + x8 >= 0 -> + x11 >= 0 -> + -x11 + x12 + x13 + -x14 >= 1 -> + x6 + -4*x8 + -2*x9 + 3*x10 + x11 + -4*x12 + -2*x13 + 3*x14 >= -5 -> + x10 >= 0 -> + x14 >= 0 -> + x12 >= 0 -> + x8 + -x10 + x12 + -x14 >= 1 -> + False. +Proof. + intros. + psatz Z 1. +Qed. + +Goal forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12, +x2 + -1*x4 >= 0 -> +-2*x2 + x4 >= -1 -> +x1 + x3 + x4 + -1*x7 + -1*x11 >= 1 -> +-1*x2 + x8 + x10 >= 0 -> +-2*x3 + -2*x4 + x5 + 2*x6 + x9 >= -1 -> +-2*x1 + 3*x3 + x4 + -1*x7 + -1*x11 >= 0 -> +-2*x1 + x3 + x4 + -1*x8 + -1*x10 + 2*x12 >= 0 -> +-2*x2 + x3 + x4 + -1*x7 + -1*x11 + 2*x12 >= 0 -> +-2*x2 + x3 + 3*x4 + -1*x8 + -1*x10 >= 0 -> +2*x2 + -1*x3 + -1*x4 + x5 + 2*x6 + -2*x8 + x9 + -2*x10 >= 0 -> +x1 + -2*x3 + x7 + x11 + -2*x12 >= 0 -> + False. +Proof. + intros. + psatz Z 1. +Qed. diff --git a/test-suite/micromega/example_nia.v b/test-suite/micromega/example_nia.v new file mode 100644 index 0000000000..8de631aa6a --- /dev/null +++ b/test-suite/micromega/example_nia.v @@ -0,0 +1,503 @@ +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* *) +(************************************************************************) + +Require Import ZArith. +Require Import Psatz. +Open Scope Z_scope. +Require Import ZMicromega. +Require Import VarMap. + +(* false in Q : x=1/2 and n=1 *) + +Lemma int_not_rat : forall x, 2 * x = 1 -> False. +Proof. + intros. + lia. +Qed. + + +Lemma not_so_easy : forall x n : Z, + 2*x + 1 <= 2 *n -> x <= n-1. +Proof. + intros. + lia. +Qed. + +Goal forall a1 da na b1 db nb, + a1 * da = na -> + b1 * db = nb -> + a1 * b1 * da * db = na * nb. +Proof. + intros. + nia. +Qed. + +(* From Laurent Théry *) + +Goal forall (x y : Z), x = 0 -> x * y = 0. +Proof. + intros. + nia. +Qed. + +Goal forall (x y : Z), x = 0 -> x * y = 0. +Proof. + intros. + nia. +Qed. + +Goal forall (x y : Z), 2*x = 0 -> x * y = 0. +Proof. + intros. + nia. +Qed. + + +Goal forall (x y: Z), - x*x >= 0 -> x * y = 0. +Proof. + intros. + nia. +Qed. + +Lemma some_pol : forall x, 4 * x ^ 2 + 3 * x + 2 >= 0. +Proof. + intros. + nia. +Qed. + + +Lemma Zdiscr: forall a b c x, + a * x ^ 2 + b * x + c = 0 -> b ^ 2 - 4 * a * c >= 0. +Proof. + intros. + Fail nia. (* Incompletness *) +Abort. + + +Lemma plus_minus : forall x y, + 0 = x + y -> 0 = x -y -> 0 = x /\ 0 = y. +Proof. + intros. + lia. +Qed. + + +Lemma mplus_minus : forall x y, + x + y >= 0 -> x -y >= 0 -> x^2 - y^2 >= 0. +Proof. + intros; nia. +Qed. + +Lemma pol3: forall x y, 0 <= x + y -> + x^3 + 3*x^2*y + 3*x* y^2 + y^3 >= 0. +Proof. + intros. + Fail nia. +Abort. + + +(* Motivating example from: Expressiveness + Automation + Soundness: + Towards COmbining SMT Solvers and Interactive Proof Assistants *) +Parameter rho : Z. +Parameter rho_ge : rho >= 0. +Parameter correct : Z -> Z -> Prop. + + +Definition rbound1 (C:Z -> Z -> Z) : Prop := + forall p s t, correct p t /\ s <= t -> C p t - C p s <= (1-rho)*(t-s). + +Definition rbound2 (C:Z -> Z -> Z) : Prop := + forall p s t, correct p t /\ s <= t -> (1-rho)*(t-s) <= C p t - C p s. + + +Lemma bounded_drift : forall s t p q C D, s <= t /\ correct p t /\ correct q t /\ + rbound1 C /\ rbound2 C /\ rbound1 D /\ rbound2 D -> + Z.abs (C p t - D q t) <= Z.abs (C p s - D q s) + 2 * rho * (t- s). +Proof. + intros. + generalize (Z.abs_eq (C p t - D q t)). + generalize (Z.abs_neq (C p t - D q t)). + generalize (Z.abs_eq (C p s -D q s)). + generalize (Z.abs_neq (C p s - D q s)). + unfold rbound2 in H. + unfold rbound1 in H. + intuition. + generalize (H6 _ _ _ (conj H H4)). + generalize (H7 _ _ _ (conj H H4)). + generalize (H8 _ _ _ (conj H H4)). + generalize (H10 _ _ _ (conj H H4)). + generalize (H6 _ _ _ (conj H5 H4)). + generalize (H7 _ _ _ (conj H5 H4)). + generalize (H8 _ _ _ (conj H5 H4)). + generalize (H10 _ _ _ (conj H5 H4)). + generalize rho_ge. + nia. +Qed. + +(* Rule of signs *) + +Lemma sign_pos_pos: forall x y, + x > 0 -> y > 0 -> x*y > 0. +Proof. + intros; nia. +Qed. + +Lemma sign_pos_zero: forall x y, + x > 0 -> y = 0 -> x*y = 0. +Proof. + intros; nia. +Qed. + +Lemma sign_pos_neg: forall x y, + x > 0 -> y < 0 -> x*y < 0. +Proof. + intros; nia. +Qed. + +Lemma sign_zero_pos: forall x y, + x = 0 -> y > 0 -> x*y = 0. +Proof. + intros; nia. +Qed. + +Lemma sign_zero_zero: forall x y, + x = 0 -> y = 0 -> x*y = 0. +Proof. + intros; nia. +Qed. + +Lemma sign_zero_neg: forall x y, + x = 0 -> y < 0 -> x*y = 0. +Proof. + intros; nia. +Qed. + +Lemma sign_neg_pos: forall x y, + x < 0 -> y > 0 -> x*y < 0. +Proof. + intros; nia. +Qed. + +Lemma sign_neg_zero: forall x y, + x < 0 -> y = 0 -> x*y = 0. +Proof. + intros; nia. +Qed. + +Lemma sign_neg_neg: forall x y, + x < 0 -> y < 0 -> x*y > 0. +Proof. + intros; nia. +Qed. + + +(* Other (simple) examples *) + +Lemma binomial : forall x y, (x+y)^2 = x^2 + 2*x*y + y^2. +Proof. + intros. + lia. +Qed. + +Lemma product : forall x y, x >= 0 -> y >= 0 -> x * y >= 0. +Proof. + intros. + nia. +Qed. + + +Lemma product_strict : forall x y, x > 0 -> y > 0 -> x * y > 0. +Proof. + intros. + nia. +Qed. + + +Lemma pow_2_pos : forall x, x ^ 2 + 1 = 0 -> False. +Proof. + intros. nia. +Qed. + +(* Found in Parrilo's talk *) +(* BUG?: certificate with **very** big coefficients *) +Lemma parrilo_ex : forall x y, x - y^2 + 3 >= 0 -> y + x^2 + 2 = 0 -> False. +Proof. + intros. + nia. +Qed. + +(* from hol_light/Examples/sos.ml *) + +Lemma hol_light1 : forall a1 a2 b1 b2, + a1 >= 0 -> a2 >= 0 -> + (a1 * a1 + a2 * a2 = b1 * b1 + b2 * b2 + 2) -> + (a1 * b1 + a2 * b2 = 0) -> a1 * a2 - b1 * b2 >= 0. +Proof. + intros. + Fail nia. +Abort. + +Lemma hol_light2 : forall x a, + 3 * x + 7 * a < 4 -> 3 < 2 * x -> a < 0. +Proof. + intros; nia. +Qed. + +Lemma hol_light3 : forall b a c x, + b ^ 2 < 4 * a * c -> (a * x ^2 + b * x + c = 0) -> False. +Proof. + intros. + Fail nia. +Abort. + + +Lemma hol_light4 : forall a c b x, + a * x ^ 2 + b * x + c = 0 -> b ^ 2 >= 4 * a * c. +Proof. + intros. + Fail nia. +Abort. + +Lemma hol_light5 : forall x y, + 0 <= x /\ x <= 1 /\ 0 <= y /\ y <= 1 + -> x ^ 2 + y ^ 2 < 1 \/ + (x - 1) ^ 2 + y ^ 2 < 1 \/ + x ^ 2 + (y - 1) ^ 2 < 1 \/ + (x - 1) ^ 2 + (y - 1) ^ 2 < 1. +Proof. +intros; nia. +Qed. + +Lemma hol_light7 : forall x y z, + 0<= x /\ 0 <= y /\ 0 <= z /\ x + y + z <= 3 + -> x * y + x * z + y * z >= 3 * x * y * z. +Proof. + intros. + Fail nia. +Abort. + +Lemma hol_light8 : forall x y z, + x ^ 2 + y ^ 2 + z ^ 2 = 1 -> (x + y + z) ^ 2 <= 3. +Proof. + intros. + Fail nia. +Abort. + +Lemma hol_light9 : forall w x y z, + w ^ 2 + x ^ 2 + y ^ 2 + z ^ 2 = 1 + -> (w + x + y + z) ^ 2 <= 4. +Proof. + intros. + Fail nia. +Abort. + + +Lemma hol_light10 : forall x y, + x >= 1 /\ y >= 1 -> x * y >= x + y - 1. +Proof. + intros. + nia. +Qed. + + +Lemma hol_light11 : forall x y, + x > 1 /\ y > 1 -> x * y > x + y - 1. +Proof. + intros ; nia. +Qed. + +Lemma hol_light12: forall x y z, + 2 <= x /\ x <= 125841 / 50000 /\ + 2 <= y /\ y <= 125841 / 50000 /\ + 2 <= z /\ z <= 125841 / 50000 + -> 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z) >= 0. +Proof. + intros x y z ; set (e:= (125841 / 50000)). + compute in e. + unfold e ; intros ; nia. +Qed. + + +Lemma hol_light14 : forall x y z, + 2 <= x /\ x <= 4 /\ 2 <= y /\ y <= 4 /\ 2 <= z /\ z <= 4 + -> 12 <= 2 * (x * z + x * y + y * z) - (x * x + y * y + z * z). +Proof. + intros ; nia. +Qed. + + +(* ------------------------------------------------------------------------- *) +(* Inequality from sci.math (see "Leon-Sotelo, por favor"). *) +(* ------------------------------------------------------------------------- *) + +Lemma hol_light16 : forall x y, + 0 <= x /\ 0 <= y /\ (x * y = 1) + -> x + y <= x ^ 2 + y ^ 2. +Proof. + intros ; nia. +Qed. + +Lemma hol_light17 : forall x y, + 0 <= x /\ 0 <= y /\ (x * y = 1) + -> x * y * (x + y) <= x ^ 2 + y ^ 2. +Proof. + intros. + Fail nia. +Abort. + + +Lemma hol_light18 : forall x y, + 0 <= x /\ 0 <= y -> x * y * (x + y) ^ 2 <= (x ^ 2 + y ^ 2) ^ 2. +Proof. + intros. + Fail nia. +Abort. + +(* ------------------------------------------------------------------------- *) +(* Some examples over integers and natural numbers. *) +(* ------------------------------------------------------------------------- *) + +Lemma hol_light19 : forall m n, 2 * m + n = (n + m) + m. +Proof. + intros ; lia. +Qed. + +Lemma hol_light22 : forall n, n >= 0 -> n <= n * n. +Proof. + intros. + nia. +Qed. + +Lemma hol_light24 : forall x1 y1 x2 y2, x1 >= 0 -> x2 >= 0 -> y1 >= 0 -> y2 >= 0 -> + ((x1 + y1) ^2 + x1 + 1 = (x2 + y2) ^ 2 + x2 + 1) + -> (x1 + y1 = x2 + y2). +Proof. + intros. + nia. +Qed. + +Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. +Proof. + intros. + Fail nia. +Abort. + + +Lemma motzkin : forall x y, (x^2*y^4 + x^4*y^2 + 1 - 3*x^2*y^2) >= 0. +Proof. + intros. + Fail generalize (motzkin' x y). + Fail nia. +Abort. + +(** Other tests *) + +Goal forall x y z n, + y >= z /\ y = n \/ ~ y >= z /\ z = n -> + x >= y /\ + (x >= z /\ (x >= n /\ x = x \/ ~ x >= n /\ x = n) \/ + ~ x >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)) \/ + ~ x >= y /\ + (y >= z /\ (x >= n /\ y = x \/ ~ x >= n /\ y = n) \/ + ~ y >= z /\ (x >= n /\ z = x \/ ~ x >= n /\ z = n)). +Proof. + intros. + lia. +Qed. + +(** Incompeteness: require manual case split *) +Goal forall (z0 z z1 z2 z3 z5 :Z) +(H8 : 0 <= z2) +(H5 : z5 > 0) +(H0 : z0 > 0) +(H9 : z2 < z0) +(H1 : z0 * z5 > 0) +(H10 : 0 <= z1 * z0 + z0 * z5 - 1 - z0 * z5 * z) +(H11 : z1 * z0 + z0 * z5 - 1 - z0 * z5 * z < z0 * z5) +(H6 : 0 <= z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3) +(H7 : z0 * z1 + z2 - z0 + 1 + z0 * z5 - 1 - z0 * z5 * z3 < z0 * z5) +(C : z > z3), False. +Proof. + intros. + assert (z1 - z5 * z3 - 1 < 0) by nia. + nia. +Qed. + + +Goal forall + (d sz x n : Z) + (GE : sz * x - sz * d >=1 ) + (R : sz + d * sz - sz * x >= 1), + False. +Proof. + intros. + assert (x - d >= 1) by nia. + nia. +Qed. + + +Goal forall x6 x8 x9 x10 x11 x12 x13 x14, + x6 >= 0 -> + -x6 + x8 + x9 + -x10 >= 1 -> + x8 >= 0 -> + x11 >= 0 -> + -x11 + x12 + x13 + -x14 >= 1 -> + x6 + -4*x8 + -2*x9 + 3*x10 + x11 + -4*x12 + -2*x13 + 3*x14 >= -5 -> + x10 >= 0 -> + x14 >= 0 -> + x12 >= 0 -> + x8 + -x10 + x12 + -x14 >= 1 -> + False. +Proof. + intros. + lia. +Qed. + +Goal forall x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12, +x2 + -1*x4 >= 0 -> +-2*x2 + x4 >= -1 -> +x1 + x3 + x4 + -1*x7 + -1*x11 >= 1 -> +-1*x2 + x8 + x10 >= 0 -> +-2*x3 + -2*x4 + x5 + 2*x6 + x9 >= -1 -> +-2*x1 + 3*x3 + x4 + -1*x7 + -1*x11 >= 0 -> +-2*x1 + x3 + x4 + -1*x8 + -1*x10 + 2*x12 >= 0 -> +-2*x2 + x3 + x4 + -1*x7 + -1*x11 + 2*x12 >= 0 -> +-2*x2 + x3 + 3*x4 + -1*x8 + -1*x10 >= 0 -> +2*x2 + -1*x3 + -1*x4 + x5 + 2*x6 + -2*x8 + x9 + -2*x10 >= 0 -> +x1 + -2*x3 + x7 + x11 + -2*x12 >= 0 -> + False. +Proof. + intros. + lia. +Qed. + +(** Needs some cutting plane *) +Goal + forall (m : Z) + (M : Z) + (x : Z) + (i : Z) + (e1 : Z) + (e2 : Z) + (e5 : Z) + (e6 : Z) + (H2 : e5 >= M) + (H11 : i < m) + (H5 : 0 <= i) + (H15 : m < 4294967296) + (H7 : 0 <= x) + (H26 : e5 < 4294967296) + (H21 : x + i = 4294967296 * e6 + e5) + (H9 : x + m = 4294967296 * e2 + e1) + (H12 : x < e1) + (H13 : e1 < M), + False. +Proof. + intros. + lia. +Qed. diff --git a/test-suite/micromega/non_lin_ci.v b/test-suite/micromega/non_lin_ci.v new file mode 100644 index 0000000000..ec39209230 --- /dev/null +++ b/test-suite/micromega/non_lin_ci.v @@ -0,0 +1,278 @@ +Require Import ZArith. +Require Import Lia Psatz. +Open Scope Z_scope. + + + + +(* From fiat-crypto Generalized.v *) + + +Goal forall (x1 : Z) (x2 : Z) (x3 : Z) (x4 : Z) (x5 : Z) (x6 : Z) (x7 : Z) (x8 : Z) (x9 : Z) (x10 : Z) (x11 : Z) (x12 : Z) (x13 : Z) (x14 : Z) (x15 : Z) (x16 : Z) (x17 : Z) (x18 : Z) +(H0 : -1 + -x1^2 + x3*x5 + x1^2*x2 + -x2*x3*x4 >= 0) +(H1 : -1 + x4 >= 0) +(H2 : -1 + x6 >= 0) +(H3 : -1 + -x4 + x1 >= 0) +(H4 : x3 + -x7 = 0) +(H5 : x8 >= 0) +(H6 : -1 + x4 >= 0) +(H7 : x9 >= 0) +(H8 : -x8 + x10 >= 0) +(H9 : -1 + x1^2 + -x9 >= 0) +(H10 : x4 + -x11 >= 0) +(H11 : -x3 + x1*x12 + -x12*x13 >= 0) +(H12 : -1 + -x9 + x1*x4 >= 0) +(H13 : -1 + x4 + -x13 >= 0) +(H14 : x13 >= 0) +(H15 : -1 + x5 >= 0) +(H16 : -1 + x1 + -x2 >= 0) +(H17 : x1^2 + -x13 + -x3*x4 = 0) +(H18 : -1 + x12 + -x14 >= 0) +(H19 : x14 >= 0) +(H20 : x1 + -x14 + -x5*x12 = 0) +(H21 : -1 + x4 + -x15 >= 0) +(H22 : x15 >= 0) +(H23 : x9 + -x15 + -x2*x4 = 0) +(H24 : -x9 + x16 + x4*x17 = 0) +(H25 : x17 + -x18 = 0) +, False +. +Proof. + intros. + Time nia. +Qed. + +Goal + forall (__x1 __x2 __x3 __x4 __x5 __x6 __x7 __x8 __x9 __x10 __x11 __x12 __x13 + __x14 __x15 __x16 : Z) + (H6 : __x8 < __x10 ^ 2 * __x15 ^ 2 + 2 * __x10 * __x15 * __x14 + __x14 ^ 2) + (H7 : 0 <= __x8) + (H12 : 0 <= __x14) + (H0 : __x8 = __x15 * __x11 + __x9) + (H14 : __x10 ^ 2 * __x15 + __x10 * __x14 < __x16) + (H17 : __x16 <= 0) + (H15 : 0 <= __x9) + (H18 : __x9 < __x15) + (H16 : 0 <= __x12) + (H19 : __x12 < (__x10 * __x15 + __x14) * __x10) + , False. +Proof. + intros. + Time nia. +Qed. + + +(* From fiat-crypto Toplevel1.v *) + + +Goal forall + (x1 x2 x3 x4 x5 x7 : Z) + (H0 : x1 + x2 - x3 = 0) (* substitute x1, nothing happens *) + (H1 : 2 * x2 - x4 - 1 >= 0) + (H2 : - x2 + x4 >= 0) + (H3 : 2 * x2 - x5 - 1 >= 0) + (H5 : x2 - 4 >= 0) + (H7 : - x2 * x7 + x4 * x5 >= 0) + (H6 : x2 * x7 + x2 - x4 * x5 - 1 >= 0) + (H9 : x7 - x2 ^ 2 >= 0), (* x2^2 is *visibly* positive *) + False. +Proof. + intros. + nia. +Qed. + +Goal forall + (x1 x2 x3 x4 x5 x7 : Z) + (H0 : x2 + x1 - x3 = 0) (* substitute x2= x3 -x1 ... *) + (H1 : 2 * x2 - x4 - 1 >= 0) + (H2 : - x2 + x4 >= 0) + (H3 : 2 * x2 - x5 - 1 >= 0) + (H5 : x2 - 4 >= 0) + (H7 : - x2 * x7 + x4 * x5 >= 0) + (H6 : x2 * x7 + x2 - x4 * x5 - 1 >= 0) + (H9 : x7 - x2 ^ 2 >= 0), (* (x3 - x1)^2 is not visibly positive *) + False. +Proof. + intros. + nia. +Qed. + +(* From bedrock2 FlatToRisc.v *) + +(* Variant of the following - omega fails (bad linearisation?)*) +Goal forall + (PXLEN XLEN r : Z) + (q q0 r0 a : Z) + (H3 : 4 * a = 4 * PXLEN * q0 + (4 * q + r)) + (H6 : 0 <= 4 * q + r) + (H7 : 4 * q + r < 4 * PXLEN) + (H8 : r <= 3) + (H4 : r >= 1), + False. +Proof. + intros. + Time lia. +Qed. + +Goal forall + (PXLEN XLEN r : Z) + (q q0 r0 a : Z) + (H3 : 4 * a = 4 * PXLEN * q0 + (4 * q + r)) + (H6 : 0 <= 4 * q + r) + (H7 : 4 * q + r < 4 * PXLEN) + (H8 : r <= 3) + (H4 : r >= 1), + False. +Proof. + intros. + Time nia. +Qed. + + +(** Very slow *) +Goal forall + (XLEN r : Z) + (H : 4 < 2 ^ XLEN) + (H0 : 8 <= XLEN) + (q q0 r0 a : Z) + (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) + (H5 : r0 = 4 * q + r) + (H6 : 0 <= r0) + (H7 : r0 < 4 * 2 ^ (XLEN - 2)) + (H2 : 0 <= r) + (H8 : r < 4) + (H4 : r > 0) + (H9 : 0 < 2 ^ (XLEN - 2)), + False. +Proof. + intros. + Time nia. +Qed. + +Goal forall + (XLEN r : Z) + (R : r > 0 \/ r < 0) + (H : 4 < 2 ^ XLEN) + (H0 : 8 <= XLEN) + (H1 : ~ (0 <= XLEN - 2) \/ 0 < 2 ^ (XLEN - 2)) + (q q0 r0 a : Z) + (H2 : 0 <= r0 < 4 * 2 ^ (XLEN - 2)) + (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) + (H4 : 0 <= r < 4) + (H5 : r0 = 4 * q + r), + False. +Proof. + intros. + Time nia. +Qed. + +Goal forall + (XLEN r : Z) + (R : r > 0 \/ r < 0) + (H : 4 < 2 ^ XLEN) + (H0 : 8 <= XLEN) + (H1 : ~ (0 <= XLEN - 2) \/ 0 < 2 ^ (XLEN - 2)) + (q q0 r0 a : Z) + (H2 : 0 <= r0 < 4 * 2 ^ (XLEN - 2)) + (H3 : 4 * a = 4 * 2 ^ (XLEN - 2) * q0 + r0) + (H4 : 0 <= r < 4) + (H5 : r0 = 4 * q + r), + False. +Proof. + intros. + intuition idtac. + Time all:nia. +Qed. + + + +Goal forall + (XLEN a q q0 z : Z) + (HR : 4 * a - 4 * z * q0 - 4 * q > 0) + (H0 : 8 <= XLEN) + (H1 : 0 < z) + (H : 0 <= 4 * a - 4 * z * q0 - 4 * q) + (H3 : 4 * a - 4 * z * q0 - 4 * q < 4) + (H4 : 4 * a - 4 * z * q0 < 4 * z), + False. +Proof. + intros. + Time nia. +Qed. + + + +(* From fiat-crypto Modulo.v *) + +Goal forall (b : Z) + (H : 0 <> b) + (c r q1 q2 r2 : Z) + (H2 : r2 < c) + (q0 : Z) + (H7 : r < b) + (H5 : 0 <= r) + (H6 : r < b) + (H12 : 0 < c) + (H13 : 0 <> c) + (H0 : 0 <> c * b) + (H1 : 0 <= r2) + (H14 : 0 <= q0) + (H9 : c * q1 + q0 = c * q2 + r2) + (H4 : 0 <= b * q0 + - r) + (H10 : b * q0 + - r < c * b), + q1 = q2. +Proof. + intros. + Fail nia. +Abort. + + +(* From Sozeau's plugin Equations *) + + +Goal forall x p2 p1 m, + x <> 0%Z -> + (Z.abs (x * p2 ) > Z.abs (Z.abs p1 + Z.abs m))%Z -> + (Z.abs (x * (p1 + x * p2 )) > Z.abs m)%Z. +Proof. + intros. + Time nia. +Qed. + + +Goal forall z z0 z1 m + (Heqz0 : z0 = ((1 + z) * z1)%Z) + (H0 : (0 <= m)%Z) + (H3 : z = m) + (H1 : (0 <= z0)%Z) + (H4 : z1 = z0) + (H2 : (z1 > 0)%Z), + (z1 > z)%Z. +Proof. + intros. + Time nia. +Qed. + + + + +(* Known issues. + + - Found proof may violate Proof using ... + There may be a compliant proof but lia has no way to know. + Proofs could be optimised to minimise the number of hypotheses, + but this seems to costly. +Section S. + Variable z z0 z1 z2 : Z. + Variable H2 : 0 <= z2. + Variable H3 : z2 < z1. + Variable H4 : 0 <= z0. + Variable H5 : z0 < z1. + Variable H6 : z = - z2. + + Goal -z1 -z2 >= 0 -> False. + Proof using H2 H3 H6. + intros. + lia. + Qed. +*) diff --git a/test-suite/micromega/rexample.v b/test-suite/micromega/rexample.v index bd52270100..52dc9ed2e0 100644 --- a/test-suite/micromega/rexample.v +++ b/test-suite/micromega/rexample.v @@ -72,6 +72,14 @@ Proof. psatz R 3. Qed. +Goal forall x, -x^2 >= 0 -> x - 1 >= 0 -> False. +Proof. + intros. + nra. +Qed. + + + Lemma motzkin' : forall x y, (x^2+y^2+1)*(x^2*y^4 + x^4*y^2 + 1 - (3 ) *x^2*y^2) >= 0. Proof. intros ; psatz R 2. @@ -86,3 +94,24 @@ Lemma opp_eq_0_iff a : -a = 0 <-> a = 0. Proof. lra. Qed. + +(* From L. Théry *) + +Goal forall (x y : R), x = 0 -> x * y = 0. +Proof. + intros. + nra. +Qed. + +Goal forall (x y : R), 2*x = 0 -> x * y = 0. +Proof. + intros. + nra. +Qed. + + +Goal forall (x y: R), - x*x >= 0 -> x * y = 0. +Proof. + intros. + nra. +Qed. diff --git a/test-suite/micromega/square.v b/test-suite/micromega/square.v index d163dfbcd2..7266b662fa 100644 --- a/test-suite/micromega/square.v +++ b/test-suite/micromega/square.v @@ -11,21 +11,21 @@ Open Scope Z_scope. Lemma Zabs_square : forall x, (Z.abs x)^2 = x^2. Proof. - intros ; case (Zabs_dec x) ; intros ; psatz Z 2. + intros ; case (Zabs_dec x) ; intros ; nia. Qed. Hint Resolve Z.abs_nonneg Zabs_square. Lemma integer_statement : ~exists n, exists p, n^2 = 2*p^2 /\ n <> 0. Proof. -intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p). + intros [n [p [Heq Hnz]]]; pose (n' := Z.abs n); pose (p':=Z.abs p). assert (facts : 0 <= Z.abs n /\ 0 <= Z.abs p /\ Z.abs n^2=n^2 /\ Z.abs p^2 = p^2) by auto. assert (H : (0 < n' /\ 0 <= p' /\ n' ^2 = 2* p' ^2)) by - (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; psatz Z 2). + (destruct facts as [Hf1 [Hf2 [Hf3 Hf4]]]; unfold n', p' ; nia). generalize p' H; elim n' using (well_founded_ind (Zwf_well_founded 0)); clear. intros n IHn p [Hn [Hp Heq]]. -assert (Hzwf : Zwf 0 (2*p-n) n) by (unfold Zwf; psatz Z 2). -assert (Hdecr : 0 < 2*p-n /\ 0 <= n-p /\ (2*p-n)^2=2*(n-p)^2) by psatz Z 2. +assert (Hzwf : Zwf 0 (2*p-n) n) by (unfold Zwf; nia). +assert (Hdecr : 0 < 2*p-n /\ 0 <= n-p /\ (2*p-n)^2=2*(n-p)^2) by nia. apply (IHn (2*p-n) Hzwf (n-p) Hdecr). Qed. diff --git a/test-suite/misc/universes/build_all_stdlib.sh b/test-suite/misc/universes/build_all_stdlib.sh new file mode 100755 index 0000000000..2d2e6f863b --- /dev/null +++ b/test-suite/misc/universes/build_all_stdlib.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash + +echo "Require $(find ../../../theories ../../../plugins -type f -name "*.v" | \ + sed 's/^.*\/theories\///' | sed 's/^.*\/plugins\///' | sed 's/\.v$//' | sed 's/\//./g') ." diff --git a/test-suite/misc/universes/dune b/test-suite/misc/universes/dune new file mode 100644 index 0000000000..58bba300d2 --- /dev/null +++ b/test-suite/misc/universes/dune @@ -0,0 +1,8 @@ +(rule + (targets all_stdlib.v) + (deps + (source_tree ../../../theories) + (source_tree ../../../plugins)) + (action + (with-outputs-to all_stdlib.v + (run ./build_all_stdlib.sh)))) diff --git a/test-suite/output/MExtraction.v b/test-suite/output/MExtraction.v index 352e422cf7..36992e4dda 100644 --- a/test-suite/output/MExtraction.v +++ b/test-suite/output/MExtraction.v @@ -7,6 +7,6 @@ Require Import QMicromega. Require Import RMicromega. Recursive Extraction - List.map RingMicromega.simpl_cone (*map_cone indexes*) - denorm Qpower vm_add - n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. + 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/PrintModule.out b/test-suite/output/PrintModule.out index 751d5fcc48..1a9bc068c5 100644 --- a/test-suite/output/PrintModule.out +++ b/test-suite/output/PrintModule.out @@ -1,5 +1,9 @@ Module N : S with Definition T := nat := M +Module N : S with Definition T := M + Module N : S with Module T := K := M +Module N : S with Module T := M + Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v index 5f30f7cda6..54ef305be4 100644 --- a/test-suite/output/PrintModule.v +++ b/test-suite/output/PrintModule.v @@ -1,3 +1,5 @@ +(* Bug #2169 *) + Module FOO. Module M. @@ -12,6 +14,10 @@ Module N : S with Definition T := nat := M. Print Module N. +Set Short Module Printing. +Print Module N. +Unset Short Module Printing. + End FOO. Module BAR. @@ -31,8 +37,14 @@ Module N : S with Module T := K := M. Print Module N. +Set Short Module Printing. +Print Module N. +Unset Short Module Printing. + End BAR. +(* Bug #4661 *) + Module QUX. Module Type Test. diff --git a/test-suite/success/btauto.v b/test-suite/success/btauto.v new file mode 100644 index 0000000000..d2512b5cbb --- /dev/null +++ b/test-suite/success/btauto.v @@ -0,0 +1,9 @@ +Require Import Btauto. + +Open Scope bool_scope. + +Lemma test_orb a b : (if a || b then negb (negb b && negb a) else negb a && negb b) = true. +Proof. btauto. Qed. + +Lemma test_xorb a : xorb a a = false. +Proof. btauto. Qed. diff --git a/test-suite/success/univers.v b/test-suite/success/univers.v index 2863404590..28426b5700 100644 --- a/test-suite/success/univers.v +++ b/test-suite/success/univers.v @@ -60,7 +60,7 @@ Qed. Record U : Type := { A:=Type; a:A }. -(** Check assignement of sorts to inductives and records. *) +(** Check assignment of sorts to inductives and records. *) Variable sh : list nat. diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 6f220f2023..0c68b75124 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -83,6 +83,8 @@ Proof. apply le_dec. Defined. +Register le_gt_dec as num.nat.le_gt_dec. + (** Proofs of decidability *) Theorem dec_le n m : decidable (n <= m). @@ -130,6 +132,16 @@ Proof. apply Nat.nlt_ge. Qed. +Register dec_le as num.nat.dec_le. +Register dec_lt as num.nat.dec_lt. +Register dec_ge as num.nat.dec_ge. +Register dec_gt as num.nat.dec_gt. +Register not_eq as num.nat.not_eq. +Register not_le as num.nat.not_le. +Register not_lt as num.nat.not_lt. +Register not_ge as num.nat.not_ge. +Register not_gt as num.nat.not_gt. + (** A ternary comparison function in the spirit of [Z.compare]. See now [Nat.compare] and its properties. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index 3bf6cd952f..d6adb7e205 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -46,6 +46,8 @@ Proof. symmetry. apply Nat.sub_1_r. Qed. +Register pred_of_minus as num.nat.pred_of_minus. + (** * Diagonal *) Notation minus_diag := Nat.sub_diag (only parsing). (* n - n = 0 *) diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 9a24c804a1..ddbc128aa1 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -30,6 +30,8 @@ Proof. elim (Nat.eq_dec n m); [left|right]; trivial. Defined. +Register dec_eq_nat as num.nat.eq_dec. + Definition UIP_nat:= Eqdep_dec.UIP_dec Nat.eq_dec. Import EqNotations. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 8a0265438a..75f14bb4da 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -41,6 +41,10 @@ Declare Scope bool_scope. Delimit Scope bool_scope with bool. Bind Scope bool_scope with bool. +Register bool as core.bool.type. +Register true as core.bool.true. +Register false as core.bool.false. + (** Basic boolean operators *) Definition andb (b1 b2:bool) : bool := if b1 then b2 else false. @@ -62,6 +66,11 @@ Definition negb (b:bool) := if b then false else true. Infix "||" := orb : bool_scope. Infix "&&" := andb : bool_scope. +Register andb as core.bool.andb. +Register orb as core.bool.orb. +Register xorb as core.bool.xorb. +Register negb as core.bool.negb. + (** Basic properties of [andb] *) Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. @@ -70,6 +79,8 @@ Proof. Qed. Hint Resolve andb_prop: bool. +Register andb_prop as core.bool.andb_prop. + Lemma andb_true_intro : forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. Proof. @@ -77,12 +88,16 @@ Proof. Qed. Hint Resolve andb_true_intro: bool. +Register andb_true_intro as core.bool.andb_true_intro. + (** Interpretation of booleans as propositions *) Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. Hint Constructors eq_true : eq_true. +Register eq_true as core.eq_true.type. + (** Another way of interpreting booleans as propositions *) Definition is_true b := b = true. @@ -141,6 +156,9 @@ Delimit Scope nat_scope with nat. Bind Scope nat_scope with nat. Arguments S _%nat. +Register nat as num.nat.type. +Register O as num.nat.O. +Register S as num.nat.S. (********************************************************************) (** * Container datatypes *) @@ -156,6 +174,10 @@ Inductive option (A:Type) : Type := Arguments Some {A} a. Arguments None {A}. +Register option as core.option.type. +Register Some as core.option.Some. +Register None as core.option.None. + Definition option_map (A B:Type) (f:A->B) (o : option A) : option B := match o with | Some a => @Some B (f a) @@ -187,11 +209,19 @@ Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. Arguments pair {A B} _ _. +Register prod as core.prod.type. +Register pair as core.prod.intro. +Register prod_rect as core.prod.rect. + Section projections. Context {A : Type} {B : Type}. Definition fst (p:A * B) := match p with (x, y) => x end. Definition snd (p:A * B) := match p with (x, y) => y end. + + Register fst as core.prod.proj1. + Register snd as core.prod.proj2. + End projections. Hint Resolve pair inl inr: core. @@ -239,6 +269,10 @@ Bind Scope list_scope with list. Infix "::" := cons (at level 60, right associativity) : list_scope. +Register list as core.list.type. +Register nil as core.list.nil. +Register cons as core.list.cons. + Local Open Scope list_scope. Definition length (A : Type) : list A -> nat := @@ -269,6 +303,11 @@ Inductive comparison : Set := | Lt : comparison | Gt : comparison. +Register comparison as core.comparison.type. +Register Eq as core.comparison.Eq. +Register Lt as core.comparison.Lt. +Register Gt as core.comparison.Gt. + Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. Proof. destruct c, c'; intro H; reflexivity || destruct H; discriminate. @@ -353,6 +392,10 @@ Arguments identity_ind [A] a P f y i. Arguments identity_rec [A] a P f y i. Arguments identity_rect [A] a P f y i. +Register identity as core.identity.type. +Register identity_refl as core.identity.refl. +Register identity_ind as core.identity.ind. + (** Identity type *) Definition ID := forall A:Type, A -> A. @@ -361,6 +404,8 @@ Definition id : ID := fun A x => x. Definition IDProp := forall A:Prop, A -> A. Definition idProp : IDProp := fun A x => x. +Register IDProp as core.IDProp.type. +Register idProp as core.IDProp.idProp. (* begin hide *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 4ec0049a9c..1db0a8e1b5 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -21,14 +21,21 @@ Notation "A -> B" := (forall (_ : A), B) : type_scope. Inductive True : Prop := I : True. +Register True as core.True.type. +Register I as core.True.I. + (** [False] is the always false proposition *) Inductive False : Prop :=. +Register False as core.False.type. + (** [not A], written [~A], is the negation of [A] *) Definition not (A:Prop) := A -> False. Notation "~ x" := (not x) : type_scope. +Register not as core.not.type. + (** Create the "core" hint database, and set its transparent state for variables and constants explicitely. *) @@ -50,6 +57,9 @@ Inductive and (A B:Prop) : Prop := where "A /\ B" := (and A B) : type_scope. +Register and as core.and.type. +Register conj as core.and.conj. + Section Conjunction. Variables A B : Prop. @@ -77,12 +87,18 @@ where "A \/ B" := (or A B) : type_scope. Arguments or_introl [A B] _, [A] B _. Arguments or_intror [A B] _, A [B] _. +Register or as core.or.type. + (** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *) Definition iff (A B:Prop) := (A -> B) /\ (B -> A). Notation "A <-> B" := (iff A B) : type_scope. +Register iff as core.iff.type. +Register proj1 as core.iff.proj1. +Register proj2 as core.iff.proj2. + Section Equivalence. Theorem iff_refl : forall A:Prop, A <-> A. @@ -257,6 +273,8 @@ Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3) Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. +Register ex as core.ex.type. + Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop := ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q. @@ -333,6 +351,11 @@ Hint Resolve I conj or_introl or_intror : core. Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. +Register eq as core.eq.type. +Register eq_refl as core.eq.refl. +Register eq_ind as core.eq.ind. +Register eq_rect as core.eq.rect. + Section Logic_lemmas. Theorem absurd : forall A C:Prop, A -> ~ A -> C. @@ -351,16 +374,22 @@ Section Logic_lemmas. destruct 1; trivial. Defined. + Register eq_sym as core.eq.sym. + Theorem eq_trans : x = y -> y = z -> x = z. Proof. destruct 2; trivial. Defined. + Register eq_trans as core.eq.trans. + Theorem f_equal : x = y -> f x = f y. Proof. destruct 1; trivial. Defined. + Register f_equal as core.eq.congr. + Theorem not_eq_sym : x <> y -> y <> x. Proof. red; intros h1 h2; apply h1; destruct h2; trivial. @@ -373,6 +402,8 @@ Section Logic_lemmas. intros A x P H y H0. elim eq_sym with (1 := H0); assumption. Defined. + Register eq_ind_r as core.eq.ind_r. + Definition eq_rec_r : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y. intros A x P H y H0; elim eq_sym with (1 := H0); assumption. @@ -458,6 +489,8 @@ Proof. destruct 1; destruct 1; reflexivity. Qed. +Register f_equal2 as core.eq.congr2. + Theorem f_equal3 : forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 6f10a93997..587de12a15 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -51,6 +51,11 @@ Section identity_is_a_congruence. End identity_is_a_congruence. +Register identity_sym as core.identity.sym. +Register identity_trans as core.identity.trans. +Register identity_congr as core.identity.congr. + + Definition identity_ind_r : forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y. intros A x P H y H0; case identity_sym with (1 := H0); trivial. diff --git a/theories/Init/Nat.v b/theories/Init/Nat.v index eb4ba0e5e6..7e7a1ced58 100644 --- a/theories/Init/Nat.v +++ b/theories/Init/Nat.v @@ -42,6 +42,8 @@ Definition pred n := | S u => u end. +Register pred as num.nat.pred. + Fixpoint add n m := match n with | 0 => m @@ -50,6 +52,8 @@ Fixpoint add n m := where "n + m" := (add n m) : nat_scope. +Register add as num.nat.add. + Definition double n := n + n. Fixpoint mul n m := @@ -60,6 +64,8 @@ Fixpoint mul n m := where "n * m" := (mul n m) : nat_scope. +Register mul as num.nat.mul. + (** Truncated subtraction: [n-m] is [0] if [n<=m] *) Fixpoint sub n m := @@ -70,6 +76,8 @@ Fixpoint sub n m := where "n - m" := (sub n m) : nat_scope. +Register sub as num.nat.sub. + (** ** Comparisons *) Fixpoint eqb n m : bool := diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 65e5e76a22..4489f4cb15 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -182,6 +182,11 @@ Notation "x <= y < z" := (x <= y /\ y < z) : nat_scope. Notation "x < y < z" := (x < y /\ y < z) : nat_scope. Notation "x < y <= z" := (x < y /\ y <= z) : nat_scope. +Register le as num.nat.le. +Register lt as num.nat.lt. +Register ge as num.nat.ge. +Register gt as num.nat.gt. + Theorem le_pred : forall n m, n <= m -> pred n <= pred m. Proof. induction 1; auto. destruct m; simpl; auto. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index a5f926f7ab..e4796a8059 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -27,6 +27,10 @@ Require Import Logic. Inductive sig (A:Type) (P:A -> Prop) : Type := exist : forall x:A, P x -> sig P. +Register sig as core.sig.type. +Register exist as core.sig.intro. +Register sig_rect as core.sig.rect. + Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := exist2 : forall x:A, P x -> Q x -> sig2 P Q. @@ -36,6 +40,10 @@ Inductive sig2 (A:Type) (P Q:A -> Prop) : Type := Inductive sigT (A:Type) (P:A -> Type) : Type := existT : forall x:A, P x -> sigT P. +Register sigT as core.sigT.type. +Register existT as core.sigT.intro. +Register sigT_rect as core.sigT.rect. + Inductive sigT2 (A:Type) (P Q:A -> Type) : Type := existT2 : forall x:A, P x -> Q x -> sigT2 P Q. @@ -93,6 +101,9 @@ Section Subset_projections. | exist _ a b => b end. + Register proj1_sig as core.sig.proj1. + Register proj2_sig as core.sig.proj2. + End Subset_projections. @@ -152,6 +163,9 @@ Section Projections. | existT _ _ h => h end. + Register projT1 as core.sigT.proj1. + Register projT2 as core.sigT.proj2. + End Projections. Local Notation "( x ; y )" := (existT _ x y) (at level 0, format "( x ; '/ ' y )"). @@ -681,6 +695,8 @@ Add Printing If sumbool. Arguments left {A B} _, [A] B _. Arguments right {A B} _ , A [B] _. +Register sumbool as core.sumbool.type. + (** [sumor] is an option type equipped with the justification of why it may not be a regular value *) diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index c27ffa33f8..f4cb34c713 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -42,6 +42,8 @@ Section Well_founded. Definition well_founded := forall a:A, Acc a. + Register well_founded as core.wf.well_founded. + (** Well-founded induction on [Set] and [Prop] *) Hypothesis Rwf : well_founded. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 35920d9134..49276f904f 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -87,6 +87,21 @@ Proof. unfold decidable; tauto. Qed. +Register dec_True as core.dec.True. +Register dec_False as core.dec.False. +Register dec_or as core.dec.or. +Register dec_and as core.dec.and. +Register dec_not as core.dec.not. +Register dec_imp as core.dec.imp. +Register dec_iff as core.dec.iff. +Register dec_not_not as core.dec.not_not. +Register not_not as core.dec.dec_not_not. +Register not_or as core.dec.not_or. +Register not_and as core.dec.not_and. +Register not_imp as core.dec.not_imp. +Register imp_simp as core.dec.imp_simp. +Register not_iff as core.dec.not_iff. + (** Results formulated with iff, used in FSetDecide. Negation are expanded since it is unclear whether setoid rewrite will always perform conversion. *) diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 0560d9ed46..4e8b48af9f 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -347,6 +347,8 @@ Proof. apply eq_dec. Qed. +Register inj_pair2_eq_dec as core.eqdep_dec.inj_pair2. + (** Examples of short direct proofs of unicity of reflexivity proofs on specific domains *) diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index 9c56b60aa4..25b7811417 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -28,10 +28,15 @@ Set Elimination Schemes. Arguments JMeq_refl {A x} , [A] x. +Register JMeq as core.JMeq.type. +Register JMeq_refl as core.JMeq.refl. + Hint Resolve JMeq_refl. Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. +Register JMeq_hom as core.JMeq.hom. + Lemma JMeq_sym : forall (A B:Type) (x:A) (y:B), JMeq x y -> JMeq y x. Proof. intros; destruct H; trivial. @@ -39,12 +44,16 @@ Qed. Hint Immediate JMeq_sym. +Register JMeq_sym as core.JMeq.sym. + Lemma JMeq_trans : forall (A B C:Type) (x:A) (y:B) (z:C), JMeq x y -> JMeq y z -> JMeq x z. Proof. destruct 2; trivial. Qed. +Register JMeq_trans as core.JMeq.trans. + Axiom JMeq_eq : forall (A:Type) (x y:A), JMeq x y -> x = y. Lemma JMeq_ind : forall (A:Type) (x:A) (P:A -> Prop), @@ -53,6 +62,8 @@ Proof. intros A x P H y H'; case JMeq_eq with (1 := H'); trivial. Qed. +Register JMeq_ind as core.JMeq.ind. + Lemma JMeq_rec : forall (A:Type) (x:A) (P:A -> Set), P x -> forall y, JMeq x y -> P y. Proof. @@ -89,6 +100,8 @@ Proof. intros A x B f y H; case JMeq_eq with (1 := H); trivial. Qed. +Register JMeq_congr as core.JMeq.congr. + (** [JMeq] is equivalent to [eq_dep Type (fun X => X)] *) Require Import Eqdep. diff --git a/theories/Numbers/BinNums.v b/theories/Numbers/BinNums.v index 7b6740e94b..ef2c688759 100644 --- a/theories/Numbers/BinNums.v +++ b/theories/Numbers/BinNums.v @@ -29,6 +29,10 @@ Bind Scope positive_scope with positive. Arguments xO _%positive. Arguments xI _%positive. +Register xI as num.pos.xI. +Register xO as num.pos.xO. +Register xH as num.pos.xH. + (** [N] is a datatype representing natural numbers in a binary way, by extending the [positive] datatype with a zero. Numbers in [N] will also be denoted using a decimal notation; @@ -43,6 +47,10 @@ Delimit Scope N_scope with N. Bind Scope N_scope with N. Arguments Npos _%positive. +Register N as num.N.type. +Register N0 as num.N.N0. +Register Npos as num.N.Npos. + (** [Z] is a datatype representing the integers in a binary way. An integer is either zero or a strictly positive number (coded as a [positive]) or a strictly negative number @@ -60,3 +68,8 @@ Delimit Scope Z_scope with Z. Bind Scope Z_scope with Z. Arguments Zpos _%positive. Arguments Zneg _%positive. + +Register Z as num.Z.type. +Register Z0 as num.Z.Z0. +Register Zpos as num.Z.Zpos. +Register Zneg as num.Z.Zneg. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index edbae6534a..001e1cfb01 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -237,6 +237,8 @@ Tactic Notation "destruct_call" constr(f) "as" simple_intropattern(l) "in" hyp(i Definition fix_proto {A : Type} (a : A) := a. +Register fix_proto as program.tactic.fix_proto. + Ltac destruct_rec_calls := match goal with | [ H : fix_proto _ |- _ ] => destruct_calls H ; clear H @@ -331,3 +333,5 @@ Ltac program_simpl := program_simplify ; try typeclasses eauto 10 with program ; Obligation Tactic := program_simpl. Definition obligation (A : Type) {a : A} := a. + +Register obligation as program.tactics.obligation. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 6278798543..8479b9a2bb 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -32,6 +32,8 @@ Section Well_founded. Definition Fix_sub (x : A) := Fix_F_sub x (Rwf x). + Register Fix_sub as program.wf.fix_sub. + (* Notation Fix_F := (Fix_F_sub P F_sub) (only parsing). (* alias *) *) (* Definition Fix (x:A) := Fix_F_sub P F_sub x (Rwf x). *) @@ -89,6 +91,8 @@ Section Measure_well_founded. Definition MR (x y: T): Prop := R (m x) (m y). + Register MR as program.wf.mr. + Lemma measure_wf: well_founded MR. Proof with auto. unfold well_founded. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index af06bcf47e..43c8d9bc09 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -17,6 +17,8 @@ Export Morphisms.ProperNotations. Definition Setoid_Theory := @Equivalence. Definition Build_Setoid_Theory := @Build_Equivalence. +Register Build_Setoid_Theory as plugins.setoid_ring.Build_Setoid_Theory. + Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. Proof. unfold Setoid_Theory in s. intros ; reflexivity. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 3f676c1888..d1168694b2 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -20,6 +20,8 @@ Require Import Bool BinPos BinNat PeanoNat Nnat. Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool). +Register Ascii as plugins.syntax.Ascii. + Declare Scope char_scope. Declare ML Module "ascii_syntax_plugin". Delimit Scope char_scope with char. diff --git a/theories/Strings/String.v b/theories/Strings/String.v index b27474ef25..f6cc8c99ed 100644 --- a/theories/Strings/String.v +++ b/theories/Strings/String.v @@ -30,6 +30,9 @@ Delimit Scope string_scope with string. Bind Scope string_scope with string. Local Open Scope string_scope. +Register EmptyString as plugins.syntax.EmptyString. +Register String as plugins.syntax.String. + (** Equality is decidable *) Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 1241345338..8fc3ab56c9 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -38,6 +38,14 @@ Module Z Include BinIntDef.Z. +Register add as num.Z.add. +Register opp as num.Z.opp. +Register succ as num.Z.succ. +Register pred as num.Z.pred. +Register sub as num.Z.sub. +Register mul as num.Z.mul. +Register of_nat as num.Z.of_nat. + (** When including property functors, only inline t eq zero one two *) Set Inline Level 30. @@ -68,6 +76,11 @@ Notation "( x | y )" := (divide x y) (at level 0). Definition Even a := exists b, a = 2*b. Definition Odd a := exists b, a = 2*b+1. +Register le as num.Z.le. +Register lt as num.Z.lt. +Register ge as num.Z.ge. +Register gt as num.Z.gt. + (** * Decidability of equality. *) Definition eq_dec (x y : Z) : {x = y} + {x <> y}. @@ -477,6 +490,10 @@ Qed. Include ZBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties. +Register eq_decidable as num.Z.eq_decidable. +Register le_decidable as num.Z.le_decidable. +Register lt_decidable as num.Z.lt_decidable. + (** ** Specification of absolute value *) @@ -1752,6 +1769,8 @@ weak_Zmult_plus_distr_r (now Z.mul_add_distr_pos) Definition Zne (x y:Z) := x <> y. (* TODO : to remove someday ? *) +Register Zne as plugins.omega.Zne. + Ltac elim_compare com1 com2 := case (Dcompare (com1 ?= com2)%Z); [ idtac | let x := fresh "H" in diff --git a/theories/ZArith/Znat.v b/theories/ZArith/Znat.v index 5c960da1fb..776efa2978 100644 --- a/theories/ZArith/Znat.v +++ b/theories/ZArith/Znat.v @@ -609,6 +609,8 @@ Proof. destruct n. trivial. simpl. apply Pos2Z.inj_succ. Qed. +Register inj_succ as num.Nat2Z.inj_succ. + (** [Z.of_N] produce non-negative integers *) Lemma is_nonneg n : 0 <= Z.of_nat n. @@ -676,11 +678,15 @@ Proof. now rewrite <- !nat_N_Z, Nat2N.inj_add, N2Z.inj_add. Qed. +Register inj_add as num.Nat2Z.inj_add. + Lemma inj_mul n m : Z.of_nat (n*m) = Z.of_nat n * Z.of_nat m. Proof. now rewrite <- !nat_N_Z, Nat2N.inj_mul, N2Z.inj_mul. Qed. +Register inj_mul as num.Nat2Z.inj_mul. + Lemma inj_sub_max n m : Z.of_nat (n-m) = Z.max 0 (Z.of_nat n - Z.of_nat m). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub_max. @@ -692,6 +698,8 @@ Proof. now rewrite <- !nat_N_Z, Nat2N.inj_sub, N2Z.inj_sub. Qed. +Register inj_sub as num.Nat2Z.inj_sub. + Lemma inj_pred_max n : Z.of_nat (Nat.pred n) = Z.max 0 (Z.pred (Z.of_nat n)). Proof. now rewrite <- !nat_N_Z, Nat2N.inj_pred, N2Z.inj_pred_max. @@ -951,6 +959,14 @@ Definition inj_lt n m := proj1 (Nat2Z.inj_lt n m). Definition inj_ge n m := proj1 (Nat2Z.inj_ge n m). Definition inj_gt n m := proj1 (Nat2Z.inj_gt n m). +Register neq as plugins.omega.neq. +Register inj_eq as plugins.omega.inj_eq. +Register inj_neq as plugins.omega.inj_neq. +Register inj_le as plugins.omega.inj_le. +Register inj_lt as plugins.omega.inj_lt. +Register inj_ge as plugins.omega.inj_ge. +Register inj_gt as plugins.omega.inj_gt. + (** For the others, a Notation is fine *) Notation inj_0 := Nat2Z.inj_0 (only parsing). @@ -1017,3 +1033,5 @@ Theorem inj_minus2 : forall n m:nat, (m > n)%nat -> Z.of_nat (n - m) = 0. Proof. intros. rewrite not_le_minus_0; auto with arith. Qed. + +Register inj_minus2 as plugins.omega.inj_minus2. diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 208e84aeb7..bd460f77f0 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -64,6 +64,11 @@ Proof. apply Z.lt_gt_cases. Qed. +Register dec_Zne as plugins.omega.dec_Zne. +Register dec_Zgt as plugins.omega.dec_Zgt. +Register dec_Zge as plugins.omega.dec_Zge. +Register not_Zeq as plugins.omega.not_Zeq. + (** * Relating strict and large orders *) Notation Zgt_lt := Z.gt_lt (compat "8.7"). @@ -119,6 +124,12 @@ Proof. destruct (Z.eq_decidable n m); [assumption|now elim H]. Qed. +Register Znot_le_gt as plugins.omega.Znot_le_gt. +Register Znot_lt_ge as plugins.omega.Znot_lt_ge. +Register Znot_ge_lt as plugins.omega.Znot_ge_lt. +Register Znot_gt_le as plugins.omega.Znot_gt_le. +Register not_Zne as plugins.omega.not_Zne. + (** * Equivalence and order properties *) (** Reflexivity *) diff --git a/theories/ZArith/auxiliary.v b/theories/ZArith/auxiliary.v index 306a856381..fd357502d2 100644 --- a/theories/ZArith/auxiliary.v +++ b/theories/ZArith/auxiliary.v @@ -94,3 +94,10 @@ Proof. now apply Z.add_lt_mono_l. Qed. +Register Zegal_left as plugins.omega.Zegal_left. +Register Zne_left as plugins.omega.Zne_left. +Register Zlt_left as plugins.omega.Zlt_left. +Register Zgt_left as plugins.omega.Zgt_left. +Register Zle_left as plugins.omega.Zle_left. +Register Zge_left as plugins.omega.Zge_left. +Register Zmult_le_approx as plugins.omega.Zmult_le_approx. diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index ff6cefdf24..f94da14cd0 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -72,6 +72,9 @@ module Aux = struct let sep fmt () = fprintf fmt "@;" + (* Creation of paths, aware of the platform separator. *) + let bpath l = String.concat Filename.dir_sep l + module DirOrd = struct type t = string list let compare = list_compare String.compare @@ -83,6 +86,14 @@ module Aux = struct (* Taken from the OCaml std library (c) INRIA / LGPL-2.1 *) module Legacy = struct + + (* Fix once we move to OCaml >= 4.06.0 *) + let list_init len f = + let rec init_aux i n f = + if i >= n then [] + else let r = f i in r :: init_aux (i+1) n f + in init_aux 0 len f + (* Slower version of DirMap.update, waiting for OCaml 4.06.0 *) let dirmap_update key f map = match begin @@ -134,16 +145,9 @@ let filter_no_vo = (* We could have coqdep to output dune files directly *) -(* Fix once we move to OCaml >= 4.06.0 *) -let list_init len f = - let rec init_aux i n f = - if i >= n then [] - else let r = f i in r :: init_aux (i+1) n f - in init_aux 0 len f - let gen_sub n = (* Move to List.init once we can depend on OCaml >= 4.06.0 *) - String.concat "/" (list_init n (fun _ -> "..")) ^ "/" + bpath @@ Legacy.list_init n (fun _ -> "..") let pp_rule fmt targets deps action = (* Special printing of the first rule *) @@ -164,13 +168,13 @@ let pp_vo_dep dir fmt vo = let depth = List.length dir in let sdir = gen_sub depth in (* All files except those in Init implicitly depend on the Prelude, we account for it here. *) - let eflag, edep = if List.tl dir = ["Init"] then "-noinit -R theories Coq", [] else "", ["theories/Init/Prelude.vo"] in + let eflag, edep = if List.tl dir = ["Init"] then "-noinit -R theories Coq", [] else "", [bpath ["theories";"Init";"Prelude.vo"]] in (* Coq flags *) let cflag = Options.build_coq_flags () in (* Correct path from global to local "theories/Init/Decimal.vo" -> "../../theories/Init/Decimal.vo" *) - let deps = List.map (fun s -> sdir ^ s) (edep @ vo.deps) in + let deps = List.map (fun s -> bpath [sdir;s]) (edep @ vo.deps) in (* The source file is also corrected as we will call coqtop from the top dir *) - let source = String.concat "/" dir ^ "/" ^ Filename.(remove_extension vo.target) ^ ".v" in + let source = bpath (dir @ [Filename.(remove_extension vo.target) ^ ".v"]) in (* The final build rule *) let action = sprintf "(chdir %%{project_root} (run coqtop -boot %s %s -compile %s))" eflag cflag source in pp_rule fmt [vo.target] deps action @@ -193,16 +197,16 @@ let pp_dep dir fmt oo = match oo with let out_install fmt dir ff = let itarget = String.concat "/" dir in let ff = pmap (function | VO vo -> Some vo.target | _ -> None) ff in - let pp_ispec fmt tg = fprintf fmt "(%s as %s)" tg (itarget^"/"^tg) in + let pp_ispec fmt tg = fprintf fmt "(%s as %s)" tg (bpath [itarget;tg]) in fprintf fmt "(install@\n @[(section lib)@\n(package coq)@\n(files @[%a@])@])@\n" (pp_list pp_ispec sep) ff (* For each directory, we must record two things, the build rules and the install specification. *) let record_dune d ff = - let sd = String.concat "/" d in + let sd = bpath d in if Sys.file_exists sd && Sys.is_directory sd then - let out = open_out (sd^"/dune") in + let out = open_out (bpath [sd;"dune"]) in let fmt = formatter_of_out_channel out in if List.nth d 0 = "plugins" then fprintf fmt "(include plugin_base.dune)@\n"; @@ -222,11 +226,12 @@ let scan_mlg4 m d = let dir = ["plugins"; d] in let m = DirMap.add dir [] m in let ml4 = Sys.(List.filter (fun f -> Filename.(check_suffix f ".ml4" || check_suffix f ".mlg")) - Array.(to_list @@ readdir String.(concat "/" dir))) in + Array.(to_list @@ readdir (bpath dir))) in List.fold_left (fun m f -> add_map_list ["plugins"; d] (choose_ml4g_form f) m) m ml4 let scan_plugins m = - let dirs = Sys.(List.filter (fun f -> is_directory @@ "plugins/"^f) Array.(to_list @@ readdir "plugins/")) in + let is_plugin_directory dir = Sys.(is_directory dir && file_exists (bpath [dir;"plugin_base.dune"])) in + let dirs = Sys.(List.filter (fun f -> is_plugin_directory @@ bpath ["plugins";f]) Array.(to_list @@ readdir "plugins")) in List.fold_left scan_mlg4 m dirs (* Process .vfiles.d and generate a skeleton for the dune file *) @@ -239,6 +244,10 @@ let parse_coqdep_line l = begin match targets with | [target] -> let dir, target = Filename.(dirname target, basename target) in + (* coqdep outputs with the '/' directory separator regardless of + the platform. Anyways, I hope we can link to coqdep instead + of having to parse its output soon, that should solve this + kind of issues *) Some (String.split_on_char '/' dir, VO { target; deps; }) (* Otherwise a vio file, we ignore *) | _ -> None diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index c3bdf656d1..0e56cc3c0f 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -59,7 +59,7 @@ let usage_coq_makefile () = \n _-extra-phony foo bar \"\"_ is a regular way to add the target \"bar\" as\ \n as a dependencies of an already defined target \"foo\".\ \n[-I dir]: look for Objective Caml dependencies in \"dir\"\ -\n[-R physicalpath logicalpath]: look for Coq dependencies resursively\ +\n[-R physicalpath logicalpath]: look for Coq dependencies recursively\ \n starting from \"physicalpath\". The logical path associated to the\ \n physical path is \"logicalpath\".\ \n[-Q physicalpath logicalpath]: look for Coq dependencies starting from\ diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 8ec8927abd..606d954672 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -71,7 +71,7 @@ let is_tactic = [ "intro"; "intros"; "apply"; "rewrite"; "refine"; "case"; "clear"; "injection"; "elimtype"; "progress"; "setoid_rewrite"; "left"; "right"; "constructor"; "econstructor"; "decide equality"; "abstract"; "exists"; "cbv"; "simple destruct"; - "info"; "field"; "specialize"; "evar"; "solve"; "instanciate"; "info_auto"; "info_eauto"; + "info"; "field"; "specialize"; "evar"; "solve"; "instantiate"; "info_auto"; "info_eauto"; "quote"; "eexact"; "autorewrite"; "destruct"; "destruction"; "destruct_call"; "dependent"; "elim"; "extensionality"; "f_equal"; "generalize"; "generalize_eqs"; "generalize_eqs_vars"; "induction"; "rename"; "move"; "omega"; diff --git a/tools/coqworkmgr.ml b/tools/coqworkmgr.ml index 68aadcfccf..bfea141bb3 100644 --- a/tools/coqworkmgr.ml +++ b/tools/coqworkmgr.ml @@ -169,7 +169,7 @@ let main () = "-j",Arg.Set_int max_tokens, "max number of concurrent jobs"; "-d",Arg.Set debug, "do not detach (debug)"] in let usage = - "Prints on stdout an env variable assignement to be picked up by coq\n"^ + "Prints on stdout an env variable assignment to be picked up by coq\n"^ "instances in order to limit the maximum number of concurrent workers.\n"^ "The default value is 2.\n"^ "Usage:" in diff --git a/tools/dune b/tools/dune index 3358d1a4e2..31b70fb06c 100644 --- a/tools/dune +++ b/tools/dune @@ -23,6 +23,13 @@ (libraries coq.toplevel)) (executable + (name coqworkmgr) + (public_name coqworkmgr) + (package coq) + (modules coqworkmgr) + (libraries coq.stm)) + +(executable (name coqdep) (public_name coqdep) (package coq) @@ -40,16 +47,9 @@ (ocamllex coqwc) -(executable - (name coq_tex) - (public_name coq_tex) - (package coq) - (modules coq_tex) - (libraries str)) - -(executable - (name coq_dune) - (public_name coq_dune) +(executables + (names coq_tex coq_dune) + (public_names coq-tex coq_dune) (package coq) - (modules coq_dune) + (modules coq_tex coq_dune) (libraries str)) diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index dee7541d37..148d4437fa 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -62,29 +62,23 @@ exception NoDecidabilityCoInductive exception ConstructorWithNonParametricInductiveType of inductive exception DecidabilityIndicesNotSupported -let constr_of_global g = lazy (UnivGen.constr_of_global g) - (* Some pre declaration of constant we are going to use *) -let bb = constr_of_global Coqlib.glob_bool - -let andb_prop = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb_prop +let andb_prop = fun _ -> UnivGen.constr_of_global (Coqlib.lib_ref "core.bool.andb_prop") let andb_true_intro = fun _ -> UnivGen.constr_of_global - (Coqlib.build_bool_type()).Coqlib.andb_true_intro - -let tt = constr_of_global Coqlib.glob_true - -let ff = constr_of_global Coqlib.glob_false - -let eq = constr_of_global Coqlib.glob_eq - -let sumbool () = UnivGen.constr_of_global (Coqlib.build_coq_sumbool ()) + (Coqlib.lib_ref "core.bool.andb_true_intro") -let andb = fun _ -> UnivGen.constr_of_global (Coqlib.build_bool_type()).Coqlib.andb +(* We avoid to use lazy as the binding of constants can change *) +let bb () = UnivGen.constr_of_global (Coqlib.lib_ref "core.bool.type") +let tt () = UnivGen.constr_of_global (Coqlib.lib_ref "core.bool.true") +let ff () = UnivGen.constr_of_global (Coqlib.lib_ref "core.bool.false") +let eq () = UnivGen.constr_of_global (Coqlib.lib_ref "core.eq.type") -let induct_on c = induction false None c None None +let sumbool () = UnivGen.constr_of_global (Coqlib.lib_ref "core.sumbool.type") +let andb = fun _ -> UnivGen.constr_of_global (Coqlib.lib_ref "core.bool.andb") +let induct_on c = induction false None c None None let destruct_on c = destruct false None c None None let destruct_on_using c id = @@ -119,7 +113,7 @@ let mkFullInd (ind,u) n = else mkIndU (ind,u) let check_bool_is_defined () = - try let _ = Global.type_of_global_in_context (Global.env ()) Coqlib.glob_bool in () + try let _ = Global.type_of_global_in_context (Global.env ()) Coqlib.(lib_ref "core.bool.type") in () with e when CErrors.noncritical e -> raise (UndefinedCst "bool") let check_no_indices mib = @@ -160,7 +154,7 @@ let build_beq_scheme mode kn = let eqs_typ = List.map (fun aa -> let a = lift !lift_cnt aa in incr lift_cnt; - myArrow a (myArrow a (Lazy.force bb)) + myArrow a (myArrow a (bb ())) ) ext_rel_list in let eq_input = List.fold_left2 @@ -259,7 +253,7 @@ let build_beq_scheme mode kn = List.fold_left (fun a b -> mkLambda(Anonymous,b,a)) (mkLambda (Anonymous, mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - (Lazy.force bb))) + (bb ()))) (List.rev rettyp_l) in (* make_one_eq *) (* do the [| C1 ... => match Y with ... end @@ -270,17 +264,17 @@ let build_beq_scheme mode kn = Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.make n (Lazy.force ff) in + let ar = Array.make n (ff ()) in let eff = ref Safe_typing.empty_private_constants in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in - let ar2 = Array.make n (Lazy.force ff) in + let ar2 = Array.make n (ff ()) in let constrsj = constrs (3+nparrec+nb_cstr_args) in for j=0 to n-1 do if Int.equal i j then ar2.(j) <- let cc = (match nb_cstr_args with - | 0 -> Lazy.force tt - | _ -> let eqs = Array.make nb_cstr_args (Lazy.force tt) in + | 0 -> tt () + | _ -> let eqs = Array.make nb_cstr_args (tt ()) in for ndx = 0 to nb_cstr_args-1 do let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in let eqA, eff' = compute_A_equality rel_list @@ -305,7 +299,7 @@ let build_beq_scheme mode kn = (constrsj.(j).cs_args) ) else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (Lazy.force ff) (constrsj.(j).cs_args) ) + mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) done; ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_name decl, RelDecl.get_type decl, a)) @@ -326,7 +320,7 @@ let build_beq_scheme mode kn = for i=0 to (nb_ind-1) do names.(i) <- Name (Id.of_string (rec_name i)); types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) - (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); + (mkArrow (mkFullInd ((kn,i),u) 1) (bb ())); let c, eff' = make_one_eq i in cores.(i) <- c; eff := Safe_typing.concat_private eff' !eff @@ -570,15 +564,15 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd x (mkVar s) ( mkNamedProd y (mkVar s) ( mkArrow - ( mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(mkVar seq,[|mkVar x;mkVar y|]);(Lazy.force tt)|])) - ( mkApp(Lazy.force eq,[|mkVar s;mkVar x;mkVar y|])) + ( mkApp(eq (),[|bb (); mkApp(mkVar seq,[|mkVar x;mkVar y|]);tt () |])) + ( mkApp(eq (),[|mkVar s;mkVar x;mkVar y|])) )) ) list_id in let bl_input = List.fold_left2 ( fun a (s,_,sbl,_) b -> mkNamedProd sbl b a ) c (List.rev list_id) (List.rev bl_typ) in let eqs_typ = List.map (fun (s,_,_,_) -> - mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(Lazy.force bb))) + mkProd(Anonymous,mkVar s,mkProd(Anonymous,mkVar s,(bb ()))) ) list_id in let eq_input = List.fold_left2 ( fun a (s,seq,_,_) b -> mkNamedProd seq b a @@ -594,8 +588,8 @@ let compute_bl_goal ind lnamesparrec nparrec = mkNamedProd n (mkFullInd (ind,u) nparrec) ( mkNamedProd m (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(Lazy.force eq,[|(Lazy.force bb);mkApp(eqI,[|mkVar n;mkVar m|]);(Lazy.force tt)|])) - (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) + (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) + (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = @@ -651,7 +645,7 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). | App (c,ca) -> ( match EConstr.kind sigma c with | Ind (indeq, u) -> - if GlobRef.equal (IndRef indeq) Coqlib.glob_eq + if GlobRef.equal (IndRef indeq) Coqlib.(lib_ref "core.eq.type") then Tacticals.New.tclTHEN (do_replace_bl mode bl_scheme_key ind @@ -704,7 +698,7 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in - let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in + let eq = eq () and tt = tt () and bb = bb () in let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let eqI, eff = eqI ind lnamesparrec in let create_input c = @@ -827,13 +821,13 @@ let _ = lb_scheme_kind_aux := fun () -> lb_scheme_kind (* Decidable equality *) let check_not_is_defined () = - try ignore (Coqlib.build_coq_not ()) - with e when CErrors.noncritical e -> raise (UndefinedCst "not") + try ignore (Coqlib.lib_ref "core.not.type") + with Not_found -> raise (UndefinedCst "not") (* {n=m}+{n<>m} part *) let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); - let eq = Lazy.force eq and tt = Lazy.force tt and bb = Lazy.force bb in + let eq = eq () and tt = tt () and bb = bb () in let list_id = list_id lnamesparrec in let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in let create_input c = @@ -879,14 +873,14 @@ let compute_dec_goal ind lnamesparrec nparrec = create_input ( mkNamedProd n (mkFullInd ind (2*nparrec)) ( mkNamedProd m (mkFullInd ind (2*nparrec+1)) ( - mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_global @@ Coqlib.build_coq_not(),[|eqnm|])|]) + mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_global @@ Coqlib.lib_ref "core.not.type",[|eqnm|])|]) ) ) ) let compute_dec_tact ind lnamesparrec nparrec = - let eq = Lazy.force eq and tt = Lazy.force tt - and ff = Lazy.force ff and bb = Lazy.force bb in + let eq = eq () and tt = tt () + and ff = ff () and bb = bb () in let list_id = list_id lnamesparrec in let eqI, eff = eqI ind lnamesparrec in let avoid = ref [] in @@ -949,7 +943,7 @@ let compute_dec_tact ind lnamesparrec nparrec = let freshH3 = fresh_id (Id.of_string "H") gl in Tacticals.New.tclTHENLIST [ simplest_right ; - unfold_constr (Lazy.force Coqlib.coq_not_ref); + unfold_constr (Coqlib.lib_ref "core.not.type"); intro; Equality.subst_all (); assert_by (Name freshH3) diff --git a/vernac/class.mli b/vernac/class.mli index f7e837f3bb..80d6d4383c 100644 --- a/vernac/class.mli +++ b/vernac/class.mli @@ -42,8 +42,8 @@ val try_add_new_coercion_with_source : GlobRef.t -> local:bool -> val try_add_new_identity_coercion : Id.t -> local:bool -> Decl_kinds.polymorphic -> source:cl_typ -> target:cl_typ -> unit -val add_coercion_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook +val add_coercion_hook : Decl_kinds.polymorphic -> Lemmas.declaration_hook -val add_subclass_hook : Decl_kinds.polymorphic -> unit Lemmas.declaration_hook +val add_subclass_hook : Decl_kinds.polymorphic -> Lemmas.declaration_hook val class_of_global : GlobRef.t -> cl_typ diff --git a/vernac/classes.ml b/vernac/classes.ml index 37ee33b19f..09e2b8df45 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -149,7 +149,7 @@ let do_abstract_instance env sigma ?hook ~global ~poly k u ctx ctx' pri decl imp let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl len term termtype = let kind = Decl_kinds.Global, poly, Decl_kinds.DefinitionBody Decl_kinds.Instance in if program_mode then - let hook vis gr _ = + let hook _ vis gr = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; let pri = intern_info pri in @@ -163,7 +163,7 @@ let declare_instance_open env sigma ?hook ~tac ~program_mode ~global ~poly k id in obls, Some constr, typ | None -> [||], None, termtype in - let hook = Lemmas.mk_hook hook in + let hook = Obligations.mk_univ_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) @@ -425,7 +425,7 @@ let context poly l = | Some b -> let decl = (Discharge, poly, Definition) in let entry = Declare.definition_entry ~univs ~types:t b in - let hook = Lemmas.mk_hook (fun _ gr -> gr) in + let hook = Lemmas.mk_hook (fun _ _ -> ()) in let _ = DeclareDef.declare_definition id decl entry UnivNames.empty_binders [] hook in Lib.sections_are_opened () || Lib.is_modtype_strict () in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 60f9d67429..cc03473bc6 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -109,10 +109,8 @@ let do_definition ~program_mode ident k univdecl bl red_option c ctypopt hook = Obligations.eterm_obligations env ident evd 0 c typ in let ctx = Evd.evar_universe_context evd in - let hook = Lemmas.mk_hook (fun l r _ -> Lemmas.call_hook (fun exn -> exn) hook l r) in + let hook = Obligations.mk_univ_hook (fun _ l r -> Lemmas.call_hook (fun x -> x) hook l r) in ignore(Obligations.add_definition ident ~term:c cty ctx ~univdecl ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps - (Lemmas.mk_hook - (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) + ignore(DeclareDef.declare_definition ident k ce (Evd.universe_binders evd) imps hook) diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 7f1c902c0f..58007e6a88 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -19,7 +19,7 @@ open Constrexpr val do_definition : program_mode:bool -> Id.t -> definition_kind -> universe_decl_expr option -> local_binder_expr list -> red_expr option -> constr_expr -> - constr_expr option -> unit Lemmas.declaration_hook -> unit + constr_expr option -> Lemmas.declaration_hook -> unit (************************************************************************) (** Internal API *) diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 04cd4173a8..5f340dc144 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -160,14 +160,8 @@ type recursive_preentry = (* Wellfounded definition *) -let contrib_name = "Program" -let subtac_dir = [contrib_name] -let tactics_module = subtac_dir @ ["Tactics"] - -let init_constant dir s sigma = - Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) - -let fix_proto = init_constant tactics_module "fix_proto" +let fix_proto sigma = + Evarutil.new_global sigma (Coqlib.lib_ref "program.tactic.fix_proto") let interp_recursive ~program_mode ~cofix fixl notations = let open Context.Named.Declaration in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 102a98f046..cea8af3f05 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -23,27 +23,16 @@ module RelDecl = Context.Rel.Declaration open Coqlib -let contrib_name = "Program" -let subtac_dir = [contrib_name] -let fixsub_module = subtac_dir @ ["Wf"] -(* let tactics_module = subtac_dir @ ["Tactics"] *) +let init_constant sigma rf = Evarutil.new_global sigma rf +let fix_sub_ref () = lib_ref "program.wf.fix_sub" +let measure_on_R_ref () = lib_ref "program.wf.mr" +let well_founded sigma = init_constant sigma (lib_ref "core.wf.well_founded") -let init_reference dir s () = Coqlib.coq_reference "Command" dir s -let init_constant dir s sigma = - Evarutil.new_global sigma (Coqlib.coq_reference "Command" dir s) - -let make_ref l s = init_reference l s -(* let fix_proto = init_constant tactics_module "fix_proto" *) -let fix_sub_ref = make_ref fixsub_module "Fix_sub" -let measure_on_R_ref = make_ref fixsub_module "MR" -let well_founded = init_constant ["Init"; "Wf"] "well_founded" let mkSubset sigma name typ prop = let open EConstr in let sigma, app_h = Evarutil.new_global sigma (delayed_force build_sigma).typ in sigma, mkApp (app_h, [| typ; mkLambda (name, typ, prop) |]) -let sigT = Lazy.from_fun build_sigma_type - let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" @@ -60,8 +49,8 @@ let rec telescope sigma l = (fun (sigma, ty, tys, (k, constr)) decl -> let t = RelDecl.get_type decl in let pred = mkLambda (RelDecl.get_name decl, t, ty) in - let sigma, ty = Evarutil.new_global sigma (Lazy.force sigT).typ in - let sigma, intro = Evarutil.new_global sigma (Lazy.force sigT).intro in + let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in + let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in (sigma, sigty, pred :: tys, (succ k, intro))) @@ -70,8 +59,8 @@ let rec telescope sigma l = let sigma, last, subst = List.fold_right2 (fun pred decl (sigma, prev, subst) -> let t = RelDecl.get_type decl in - let sigma, p1 = Evarutil.new_global sigma (Lazy.force sigT).proj1 in - let sigma, p2 = Evarutil.new_global sigma (Lazy.force sigT).proj2 in + let sigma, p1 = Evarutil.new_global sigma (lib_ref "core.sigT.proj1") in + let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (sigma, lift 1 proj2, LocalDef (get_name decl, proj1, t) :: subst)) @@ -203,7 +192,7 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let name = add_suffix recname "_func" in (* XXX: Mutating the evar_map in the hook! *) (* XXX: Likely the sigma is out of date when the hook is called .... *) - let hook sigma l gr _ = + let hook sigma _ l gr = let sigma, h_body = Evarutil.new_global sigma gr in let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in @@ -222,13 +211,13 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = hook, name, typ else let typ = it_mkProd_or_LetIn top_arity binders_rel in - let hook sigma l gr _ = + let hook sigma _ l gr = if Impargs.is_implicit_args () || not (List.is_empty impls) then Impargs.declare_manual_implicits false gr [impls] in hook, recname, typ in (* XXX: Capturing sigma here... bad bad *) - let hook = Lemmas.mk_hook (hook sigma) in + let hook = Obligations.mk_univ_hook (hook sigma) in (* XXX: Grounding non-ground terms here... bad bad *) let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in let fullctyp = EConstr.to_constr sigma typ in @@ -255,7 +244,7 @@ let do_program_recursive local poly fixkind fixl ntns = interp_recursive ~cofix ~program_mode:true fixl ntns in (* Program-specific code *) - (* Get the interesting evars, those that were not instanciated *) + (* Get the interesting evars, those that were not instantiated *) let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in (* Solve remaining evars *) let evd = nf_evar_map_undefined evd in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 77177dfa41..35fb18e292 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -33,34 +33,22 @@ let get_locality id ~kind = function | Local -> true | Global -> false -let declare_global_definition ident ce local k pl imps = - let local = get_locality ident ~kind:"definition" local in - let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in - let gr = ConstRef kn in - let () = maybe_declare_manual_implicits false gr imps in - let () = Declare.declare_univ_binders gr pl in - let () = definition_message ident in - gr - let declare_definition ident (local, p, k) ce pl imps hook = let fix_exn = Future.fix_exn_of ce.const_entry_body in - let r = match local with + let gr = match local with | Discharge when Lib.sections_are_opened () -> - let c = SectionLocalDef ce in - let _ = declare_variable ident (Lib.cwd(), c, IsDefinition k) in - let () = definition_message ident in - let gr = VarRef ident in - let () = maybe_declare_manual_implicits false gr imps in - let () = Declare.declare_univ_binders gr pl in - let () = if Proof_global.there_are_pending_proofs () then - warn_definition_not_visible ident - in - gr + 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 + VarRef ident | Discharge | Local | Global -> - declare_global_definition ident ce local k pl imps in - Lemmas.call_hook fix_exn hook local r + let local = get_locality ident ~kind:"definition" local in + let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in + ConstRef kn in + let () = maybe_declare_manual_implicits false gr imps in + let () = Declare.declare_univ_binders gr pl in + let () = definition_message ident in + Lemmas.call_hook fix_exn hook local gr; gr let declare_fix ?(opaque = false) (_,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 ce pl imps (Lemmas.mk_hook (fun _ r -> r)) - + declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ _ -> ())) diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index c5e704a5e9..da11d4d9c0 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -15,7 +15,7 @@ val get_locality : Id.t -> kind:string -> Decl_kinds.locality -> bool val declare_definition : Id.t -> definition_kind -> Safe_typing.private_constants Entries.definition_entry -> UnivNames.universe_binders -> Impargs.manual_implicits -> - GlobRef.t Lemmas.declaration_hook -> GlobRef.t + Lemmas.declaration_hook -> GlobRef.t val declare_fix : ?opaque:bool -> definition_kind -> UnivNames.universe_binders -> Entries.constant_universes_entry -> diff --git a/vernac/egramml.ml b/vernac/egramml.ml index c5dedc880e..89caff847f 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -19,7 +19,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type option * ('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) @@ -40,7 +40,7 @@ let rec ty_rule_of_gram = function AnyTyRule r | GramNonTerminal (_, (t, tok)) :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let inj = Option.map (fun t obj -> Genarg.in_gen t obj) t in + let inj = Some (fun obj -> Genarg.in_gen t obj) in let r = TyNext (rem, tok, inj) in AnyTyRule r diff --git a/vernac/egramml.mli b/vernac/egramml.mli index c4f4fcfaa4..a90ef97e7d 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -17,7 +17,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string - | GramNonTerminal : ('a Genarg.raw_abstract_argument_type option * + | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * ('s, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 895737b538..d7229d32fe 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -212,7 +212,7 @@ GRAMMAR EXTEND Gram | IDENT "Combined"; IDENT "Scheme"; id = identref; IDENT "from"; l = LIST1 identref SEP "," -> { VernacCombinedScheme (id, l) } | IDENT "Register"; g = global; "as"; quid = qualid -> - { VernacRegister(g, RegisterRetroknowledge quid) } + { VernacRegister(g, RegisterCoqlib quid) } | IDENT "Register"; IDENT "Inline"; g = global -> { VernacRegister(g, RegisterInline) } | IDENT "Universe"; l = LIST1 identref -> { VernacUniverse l } @@ -994,7 +994,9 @@ GRAMMAR EXTEND Gram | IDENT "Transparent"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (false, true, qid) } | IDENT "All"; IDENT "Dependencies"; qid = smart_global -> { PrintAssumptions (true, true, qid) } | IDENT "Strategy"; qid = smart_global -> { PrintStrategy (Some qid) } - | IDENT "Strategies" -> { PrintStrategy None } ] ] + | IDENT "Strategies" -> { PrintStrategy None } + | IDENT "Registered" -> { PrintRegistered } + ] ] ; class_rawexpr: [ [ IDENT "Funclass" -> { FunClass } diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index b354ad0521..5f2818c12b 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -451,11 +451,11 @@ let fold_left' f = function [] -> invalid_arg "fold_left'" | hd :: tl -> List.fold_left f hd tl -let mk_coq_and sigma = Evarutil.new_global sigma (Coqlib.build_coq_and ()) -let mk_coq_conj sigma = Evarutil.new_global sigma (Coqlib.build_coq_conj ()) +let mk_coq_and sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.and.type") +let mk_coq_conj sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.and.conj") -let mk_coq_prod sigma = Evarutil.new_global sigma (Coqlib.build_coq_prod ()) -let mk_coq_pair sigma = Evarutil.new_global sigma (Coqlib.build_coq_pair ()) +let mk_coq_prod sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.prod.type") +let mk_coq_pair sigma = Evarutil.new_global sigma (Coqlib.lib_ref "core.prod.intro") let build_combined_scheme env schemes = let evdref = ref (Evd.from_env env) in diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 4f0bf1b5d2..8aa459729c 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -34,7 +34,7 @@ open Impargs module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -type 'a declaration_hook = Decl_kinds.locality -> GlobRef.t -> 'a +type declaration_hook = Decl_kinds.locality -> GlobRef.t -> unit let mk_hook hook = hook let call_hook fix_exn hook l c = try hook l c @@ -179,14 +179,14 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = let const = adjust_guardness_conditions const do_guard in let k = Kindops.logical_kind_of_goal_kind kind in let should_suggest = const.const_entry_opaque && Option.is_empty const.const_entry_secctx in - let l,r = match locality with + let r = match locality with | Discharge when Lib.sections_are_opened () -> let c = SectionLocalDef const in let _ = declare_variable id (Lib.cwd(), c, k) in let () = if should_suggest then Proof_using.suggest_variable (Global.env ()) id in - (Local, VarRef id) + VarRef id | Local | Global | Discharge -> let local = match locality with | Local | Discharge -> true @@ -197,11 +197,11 @@ let save ?export_seff id const uctx do_guard (locality,poly,kind) hook = let () = if should_suggest then Proof_using.suggest_constant (Global.env ()) kn in - (locality, ConstRef kn) + ConstRef kn in definition_message id; Declare.declare_univ_binders r (UState.universe_binders uctx); - call_hook (fun exn -> exn) hook l r + call_hook (fun exn -> exn) hook locality r with e when CErrors.noncritical e -> let e = CErrors.push e in iraise (fix_exn e) @@ -221,12 +221,12 @@ let check_name_freshness locality {CAst.loc;v=id} : unit = let save_remaining_recthms (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 | None -> (match locality with | Discharge -> let impl = false in (* copy values from Vernacentries *) - let k = IsAssumption Conjectural in let univs = match univs with | Polymorphic_const_entry univs -> (* What is going on here? *) @@ -237,7 +237,6 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, let _ = declare_variable id (Lib.cwd(),c,k) in (Discharge, VarRef id,imps) | Local | Global -> - let k = IsAssumption Conjectural in let local = match locality with | Local -> true | Global -> false @@ -277,22 +276,10 @@ let save_remaining_recthms (locality,p,kind) norm univs body opaq i (id,(t_i,(_, let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality,ConstRef kn,imps) -let save_hook = ref ignore -let set_save_hook f = save_hook := f - -let save_named ?export_seff proof = - let id,const,uctx,do_guard,persistence,hook = proof in - save ?export_seff id const uctx do_guard persistence hook - let check_anonymity id save_ident = if not (String.equal (atompart_of_id id) (Id.to_string (default_thm_id))) then user_err Pp.(str "This command can only be used for unnamed theorem.") -let save_anonymous ?export_seff proof save_ident = - let id,const,uctx,do_guard,persistence,hook = proof in - check_anonymity id save_ident; - save ?export_seff save_ident const uctx do_guard persistence hook - (* Admitted *) let warn_let_as_axiom = @@ -312,16 +299,6 @@ let admit (id,k,e) pl hook () = (* Starting a goal *) -let start_hook = ref ignore -let set_start_hook = (:=) start_hook - - -let get_proof proof do_guard hook opacity = - let (id,(const,univs,persistence)) = - Pfedit.cook_this_proof proof - in - id,{const with const_entry_opaque = opacity},univs,do_guard,persistence,hook - let universe_proof_terminator compute_guard hook = let open Proof_global in make_terminator begin function @@ -333,12 +310,12 @@ let universe_proof_terminator compute_guard hook = | Transparent -> false, true | Opaque -> true, false in - let proof = get_proof proof compute_guard - (hook (Some (proof.Proof_global.universes))) is_opaque in - begin match idopt with - | None -> save_named ~export_seff proof - | Some { CAst.v = id } -> save_anonymous ~export_seff proof id - end + let (id,(const,univs,persistence)) = Pfedit.cook_this_proof proof in + let const = {const with const_entry_opaque = is_opaque} in + let id = match idopt with + | None -> id + | Some { CAst.v = save_id } -> check_anonymity id save_id; save_id in + save ~export_seff id const univs compute_guard persistence (hook (Some univs)) end let standard_proof_terminator compute_guard hook = @@ -362,7 +339,6 @@ let start_proof id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard= | Some sign -> sign | None -> initialize_named_context_for_proof () in - !start_hook c; Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_guard=[]) hook = @@ -375,7 +351,6 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_ | Some sign -> sign | None -> initialize_named_context_for_proof () in - !start_hook c; Pfedit.start_proof id ?pl kind sigma sign c ?init_tac terminator let rec_tac_initializer finite guard thms snl = diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 62b25946d9..195fcbf4ca 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -11,47 +11,41 @@ open Names open Decl_kinds -type 'a declaration_hook -val mk_hook : - (Decl_kinds.locality -> GlobRef.t -> 'a) -> 'a declaration_hook - -val call_hook : - Future.fix_exn -> 'a declaration_hook -> Decl_kinds.locality -> GlobRef.t -> 'a - -(** A hook start_proof calls on the type of the definition being started *) -val set_start_hook : (EConstr.types -> unit) -> unit +type declaration_hook +val mk_hook : (Decl_kinds.locality -> GlobRef.t -> unit) -> declaration_hook +val call_hook : Future.fix_exn -> declaration_hook -> Decl_kinds.locality -> GlobRef.t -> unit val start_proof : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> + ?terminator:(Proof_global.lemma_possible_guards -> declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> - unit declaration_hook -> unit + ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + declaration_hook -> unit val start_proof_univs : Id.t -> ?pl:UState.universe_decl -> goal_kind -> Evd.evar_map -> - ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> unit declaration_hook) -> Proof_global.proof_terminator) -> + ?terminator:(Proof_global.lemma_possible_guards -> (UState.t option -> declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> - (UState.t option -> unit declaration_hook) -> unit + ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> + (UState.t option -> declaration_hook) -> unit val start_proof_com : ?inference_hook:Pretyping.inference_hook -> goal_kind -> Vernacexpr.proof_expr list -> - unit declaration_hook -> unit + declaration_hook -> unit val start_proof_with_initialization : 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 declaration_hook -> unit + -> int list option -> declaration_hook -> unit val universe_proof_terminator : Proof_global.lemma_possible_guards -> - (UState.t option -> unit declaration_hook) -> + (UState.t option -> declaration_hook) -> Proof_global.proof_terminator val standard_proof_terminator : - Proof_global.lemma_possible_guards -> unit declaration_hook -> + Proof_global.lemma_possible_guards -> declaration_hook -> Proof_global.proof_terminator val fresh_name_for_anonymous_theorem : unit -> Id.t @@ -63,7 +57,4 @@ val initialize_named_context_for_proof : unit -> Environ.named_context_val (** {6 ... } *) -(** A hook the next three functions pass to cook_proof *) -val set_save_hook : (Proof.t -> unit) -> unit - val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index c4a10b4be6..5352cf5f8c 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -20,6 +20,14 @@ open Pp open CErrors open Util +type univ_declaration_hook = UState.t -> Decl_kinds.locality -> GlobRef.t -> unit +let mk_univ_hook f = f +let call_univ_hook fix_exn hook uctx l c = + try hook uctx l c + with e when CErrors.noncritical e -> + let e = CErrors.push e in + iraise (fix_exn e) + module NamedDecl = Context.Named.Declaration let get_fix_exn, stm_get_fix_exn = Hook.make () @@ -256,11 +264,9 @@ let eterm_obligations env name evm fs ?status t ty = let evmap f c = pi1 (subst_evar_constr evts 0 f c) in Array.of_list (List.rev evars), (evnames, evmap), t', ty -let tactics_module = ["Program";"Tactics"] -let safe_init_constant md name () = - Coqlib.check_required_library ("Coq"::md); - UnivGen.constr_of_global (Coqlib.coq_reference "Obligations" md name) -let hide_obligation = safe_init_constant tactics_module "obligation" +let hide_obligation () = + Coqlib.check_required_library ["Coq";"Program";"Tactics"]; + UnivGen.constr_of_global (Coqlib.lib_ref "program.tactics.obligation") let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) @@ -316,7 +322,7 @@ type program_info_aux = { prg_notations : notations ; prg_kind : definition_kind; prg_reduce : constr -> constr; - prg_hook : (UState.t -> unit) Lemmas.declaration_hook; + prg_hook : univ_declaration_hook; prg_opaque : bool; prg_sign: named_context_val; } @@ -342,7 +348,7 @@ open Goptions let _ = declare_bool_option { optdepr = false; - optname = "Hidding of Program obligations"; + optname = "Hiding of Program obligations"; optkey = ["Hide";"Obligations"]; optread = get_hide_obligations; optwrite = set_hide_obligations; } @@ -490,7 +496,7 @@ let declare_definition prg = let ubinders = UState.universe_binders uctx in DeclareDef.declare_definition prg.prg_name prg.prg_kind ce ubinders prg.prg_implicits - (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r uctx; r)) + (Lemmas.mk_hook (fun l r -> call_univ_hook fix_exn prg.prg_hook uctx l r ; ())) let rec lam_index n t acc = match Constr.kind t with @@ -564,7 +570,7 @@ let declare_mutual_definition l = 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 fix_exn first.prg_hook local gr first.prg_ctx; + call_univ_hook fix_exn first.prg_hook first.prg_ctx local gr; List.iter progmap_remove l; gr let decompose_lam_prod c ty = @@ -1101,7 +1107,7 @@ let show_term n = let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) ?(implicits=[]) ?(kind=Global,false,Definition) ?tactic - ?(reduce=reduce) ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) obls = + ?(reduce=reduce) ?(hook=mk_univ_hook (fun _ _ _ -> ())) ?(opaque = false) obls = let sign = Lemmas.initialize_named_context_for_proof () in let info = Id.print n ++ str " has type-checked" in let prg = init_prog_info sign ~opaque n univdecl term t ctx [] None [] obls implicits kind reduce hook in @@ -1121,7 +1127,7 @@ let add_definition n ?term t ctx ?(univdecl=UState.default_univ_decl) let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic ?(kind=Global,false,Definition) ?(reduce=reduce) - ?(hook=Lemmas.mk_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = + ?(hook=mk_univ_hook (fun _ _ _ -> ())) ?(opaque = false) notations fixkind = let sign = Lemmas.initialize_named_context_for_proof () in let deps = List.map (fun (n, b, t, imps, obls) -> n) l in List.iter diff --git a/vernac/obligations.mli b/vernac/obligations.mli index a37c30aafc..80294c7a76 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -13,6 +13,10 @@ open Constr open Evd open Names +type univ_declaration_hook +val mk_univ_hook : (UState.t -> Decl_kinds.locality -> GlobRef.t -> unit) -> univ_declaration_hook +val call_univ_hook : Future.fix_exn -> univ_declaration_hook -> UState.t -> Decl_kinds.locality -> GlobRef.t -> unit + (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof * is not available here, so we provide a side channel to get it *) @@ -59,7 +63,7 @@ val add_definition : Names.Id.t -> ?term:constr -> types -> ?kind:Decl_kinds.definition_kind -> ?tactic:unit Proofview.tactic -> ?reduce:(constr -> constr) -> - ?hook:(UState.t -> unit) Lemmas.declaration_hook -> ?opaque:bool -> obligation_info -> progress + ?hook:univ_declaration_hook -> ?opaque:bool -> obligation_info -> progress type notations = (lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list @@ -76,7 +80,7 @@ val add_mutual_definitions : ?tactic:unit Proofview.tactic -> ?kind:Decl_kinds.definition_kind -> ?reduce:(constr -> constr) -> - ?hook:(UState.t -> unit) Lemmas.declaration_hook -> ?opaque:bool -> + ?hook:univ_declaration_hook -> ?opaque:bool -> notations -> fixpoint_kind -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b4b3aead91..a0e8f38c0b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -533,6 +533,8 @@ open Pputils keyword "Print Strategies" | PrintStrategy (Some qid) -> keyword "Print Strategy" ++ pr_smart_global qid + | PrintRegistered -> + keyword "Print Registered" let pr_using e = let rec aux = function @@ -1159,14 +1161,16 @@ open Pputils | LocateOther (s, qid) -> keyword s ++ spc () ++ pr_ltac_ref qid in return (keyword "Locate" ++ spc() ++ pr_locate loc) - | VernacRegister (id, RegisterInline) -> + | VernacRegister (qid, RegisterCoqlib name) -> return ( hov 2 - (keyword "Register Inline" ++ spc() ++ pr_qualid id) + (keyword "Register" ++ spc() ++ pr_qualid qid ++ spc () ++ str "as" + ++ spc () ++ pr_qualid name) ) - | VernacRegister (id, RegisterRetroknowledge n) -> + | VernacRegister (qid, RegisterInline) -> return ( - hov 2 (keyword "Register" ++ spc () ++ pr_qualid id ++ spc () ++ keyword "as" ++ pr_qualid n) + hov 2 + (keyword "Register Inline" ++ spc() ++ pr_qualid qid) ) | VernacComments l -> return ( diff --git a/vernac/search.ml b/vernac/search.ml index e8ccec11ca..04dcb7d565 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -236,13 +236,13 @@ let search_pattern gopt pat mods pr_search = (** SearchRewrite *) -let eq = Coqlib.glob_eq +let eq () = Coqlib.(lib_ref "core.eq.type") let rewrite_pat1 pat = - PApp (PRef eq, [| PMeta None; pat; PMeta None |]) + PApp (PRef (eq ()), [| PMeta None; pat; PMeta None |]) let rewrite_pat2 pat = - PApp (PRef eq, [| PMeta None; PMeta None; pat |]) + PApp (PRef (eq ()), [| PMeta None; PMeta None; pat |]) let search_rewrite gopt pat mods pr_search = let pat1 = rewrite_pat1 pat in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index cf2fecb9c1..48d4165830 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -311,6 +311,13 @@ let print_strategy r = let lvl = get_strategy oracle key in pr_strategy (r, lvl) +let print_registered () = + let pr_lib_ref (s,r) = + pr_global r ++ str " registered as " ++ str s + in + hov 0 (prlist_with_sep fnl pr_lib_ref @@ Coqlib.get_lib_refs ()) + + let dump_universes_gen g s = let output = open_out s in let output_constraint, close = @@ -472,10 +479,12 @@ let start_proof_and_print k l hook = let no_hook = Lemmas.mk_hook (fun _ _ -> ()) let vernac_definition_hook p = function -| Coercion -> Class.add_coercion_hook p +| Coercion -> + Class.add_coercion_hook p | CanonicalStructure -> - Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure) -| SubClass -> Class.add_subclass_hook p + Lemmas.mk_hook (fun _ -> Recordops.declare_canonical_structure) +| SubClass -> + Class.add_subclass_hook p | _ -> no_hook let vernac_definition ~atts discharge kind ({loc;v=id}, pl) def = @@ -1866,6 +1875,7 @@ let vernac_print ~atts env sigma = Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in Printer.pr_assumptionset env sigma nassums | PrintStrategy r -> print_strategy r + | PrintRegistered -> print_registered () let global_module qid = try Nametab.full_name_module qid @@ -1972,14 +1982,14 @@ let vernac_register qid r = if not (isConstRef gr) then user_err Pp.(str "Register inline: a constant is expected"); Global.register_inline (destConstRef gr) - | RegisterRetroknowledge n -> + | RegisterCoqlib n -> let path, id = Libnames.repr_qualid n in if DirPath.equal path Retroknowledge.int31_path then let f = Retroknowledge.(KInt31 (int31_field_of_string (Id.to_string id))) in Global.register f gr else - user_err Pp.(str "Register in unknown namespace: " ++ str (DirPath.to_string path)) + Coqlib.register_ref (Libnames.string_of_qualid n) gr (********************) (* Proof management *) @@ -2226,7 +2236,7 @@ let interp ?proof ~atts ~st c = | VernacSearch (s,g,r) -> vernac_search ~atts s g r | VernacLocate l -> Feedback.msg_notice @@ vernac_locate l - | VernacRegister (id, r) -> vernac_register id r + | VernacRegister (qid, r) -> vernac_register qid r | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n") (* Proof management *) @@ -2278,6 +2288,7 @@ let check_vernac_supports_locality c l = | VernacSetOption _ | VernacUnsetOption _ | VernacDeclareReduction _ | VernacExtend _ + | VernacRegister _ | VernacInductive _) -> () | Some _, _ -> user_err Pp.(str "This command does not support Locality") @@ -2496,8 +2507,7 @@ type classifier = Genarg.raw_generic_argument list -> vernac_classification type (_, _) ty_sig = | TyNil : (atts:atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig -| TyNonTerminal : - string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig +| TyNonTerminal : ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig type ty_ml = TyML : bool * ('r, 's) ty_sig * 'r * 's option -> ty_ml @@ -2510,7 +2520,7 @@ let rec untype_classifier : type r s. (r, s) ty_sig -> s -> classifier = functio | _ :: _ -> type_error () end | TyTerminal (_, ty) -> fun f args -> untype_classifier ty f args -| TyNonTerminal (_, tu, ty) -> fun f args -> +| TyNonTerminal (tu, ty) -> fun f args -> begin match args with | [] -> type_error () | Genarg.GenArg (Rawwit tag, v) :: args -> @@ -2527,7 +2537,7 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args vernac_comm | _ :: _ -> type_error () end | TyTerminal (_, ty) -> fun f args -> untype_command ty f args -| TyNonTerminal (_, tu, ty) -> fun f args -> +| TyNonTerminal (tu, ty) -> fun f args -> begin match args with | [] -> type_error () | Genarg.GenArg (Rawwit tag, v) :: args -> @@ -2548,8 +2558,8 @@ let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s let rec untype_grammar : type r s. (r, s) ty_sig -> vernac_expr Egramml.grammar_prod_item list = function | TyNil -> [] | TyTerminal (tok, ty) -> Egramml.GramTerminal tok :: untype_grammar ty -| TyNonTerminal (id, tu, ty) -> - let t = Option.map (fun _ -> rawwit (Egramml.proj_symbol tu)) id in +| TyNonTerminal (tu, ty) -> + let t = rawwit (Egramml.proj_symbol tu) in let symb = untype_user_symbol tu in Egramml.GramNonTerminal (Loc.tag (t, symb)) :: untype_grammar ty @@ -2603,3 +2613,30 @@ let vernac_extend ~command ?classifier ?entry ext = in let () = declare_vernac_classifier command cl in List.iteri iter ext + +(** VERNAC ARGUMENT EXTEND registering *) + +type 'a argument_rule = +| Arg_alias of 'a Pcoq.Entry.t +| Arg_rules of 'a Extend.production_rule list + +type 'a vernac_argument = { + arg_printer : 'a -> Pp.t; + arg_parsing : 'a argument_rule; +} + +let vernac_argument_extend ~name arg = + let wit = Genarg.create_arg name in + let entry = match arg.arg_parsing with + | Arg_alias e -> + let () = Pcoq.register_grammar wit e in + e + | Arg_rules rules -> + let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let () = Pcoq.grammar_extend e None (None, [(None, None, rules)]) in + e + in + let pr = arg.arg_printer in + let pr x = Genprint.PrinterBasic (fun () -> pr x) in + let () = Genprint.register_vernac_print0 wit pr in + (wit, entry) diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index fb2a30bac7..0c4630e45f 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -51,7 +51,6 @@ type (_, _) ty_sig = | TyNil : (atts:Vernacinterp.atts -> st:Vernacstate.t -> Vernacstate.t, Vernacexpr.vernac_classification) ty_sig | TyTerminal : string * ('r, 's) ty_sig -> ('r, 's) ty_sig | TyNonTerminal : - string option * ('a, 'b, 'c) Extend.ty_user_symbol * ('r, 's) ty_sig -> ('a -> 'r, 'a -> 's) ty_sig @@ -64,6 +63,24 @@ val vernac_extend : ?entry:Vernacexpr.vernac_expr Pcoq.Entry.t -> ty_ml list -> unit +(** {5 VERNAC ARGUMENT EXTEND} *) + +type 'a argument_rule = +| Arg_alias of 'a Pcoq.Entry.t + (** This is used because CAMLP5 parser can be dumb about rule factorization, + which sometimes requires two entries to be the same. *) +| Arg_rules of 'a Extend.production_rule list + (** There is a discrepancy here as we use directly extension rules and thus + entries instead of ty_user_symbol and thus arguments as roots. *) + +type 'a vernac_argument = { + arg_printer : 'a -> Pp.t; + arg_parsing : 'a argument_rule; +} + +val vernac_argument_extend : name:string -> 'a vernac_argument -> + ('a, unit, unit) Genarg.genarg_type * 'a Pcoq.Entry.t + (** {5 STM classifiers} *) val get_vernac_classifier : diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index a2ea706b75..27b485d94d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -57,6 +57,7 @@ type printable = | PrintImplicit of qualid or_by_notation | PrintAssumptions of bool * bool * qualid or_by_notation | PrintStrategy of qualid or_by_notation option + | PrintRegistered type search_about_item = | SearchSubPattern of constr_pattern_expr @@ -230,7 +231,7 @@ type extend_name = It will be extended with primitive inductive types and operators *) type register_kind = | RegisterInline - | RegisterRetroknowledge of qualid + | RegisterCoqlib of qualid (** {6 Types concerning the module layer} *) |