diff options
Diffstat (limited to 'plugins')
86 files changed, 2502 insertions, 1999 deletions
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 23f8fe04a3..ac2058ba1b 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -115,7 +115,7 @@ module Bool = struct | Case (info, r, _iv, arg, pats) -> let is_bool = let i = info.ci_ind in - Names.eq_ind i (Lazy.force ind) + Names.Ind.CanOrd.equal i (Lazy.force ind) in if is_bool then Ifb ((aux arg), (aux pats.(0)), (aux pats.(1))) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 6f5c910297..129b220680 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -145,7 +145,7 @@ let rec term_equal t1 t2 = | Appli (t1, u1), Appli (t2, u2) -> term_equal t1 t2 && term_equal u1 u2 | Constructor {ci_constr=(c1,u1); ci_arity=i1; ci_nhyps=j1}, Constructor {ci_constr=(c2,u2); ci_arity=i2; ci_nhyps=j2} -> - Int.equal i1 i2 && Int.equal j1 j2 && eq_constructor c1 c2 (* FIXME check eq? *) + Int.equal i1 i2 && Int.equal j1 j2 && Construct.CanOrd.equal c1 c2 (* FIXME check eq? *) | _ -> false open Hashset.Combine @@ -155,7 +155,7 @@ let rec hash_term = function | Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) - | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j + | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (Construct.CanOrd.hash c) i j type ccpattern = PApp of term * ccpattern list (* arguments are reversed *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index c485c38009..23a7b89d2c 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -443,7 +443,7 @@ let cc_tactic depth additionnal_terms = let pr_missing (c, missing) = let c = Detyping.detype Detyping.Now ~lax:true false Id.Set.empty env sigma c in let holes = List.init missing (fun _ -> hole) in - Printer.pr_glob_constr_env env (DAst.make @@ GApp (c, holes)) + Printer.pr_glob_constr_env env sigma (DAst.make @@ GApp (c, holes)) in let msg = Pp.(str "Goal is solvable by congruence but some arguments are missing." ++ fnl () ++ diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 2dca1d5e49..6869f9c47e 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -741,7 +741,7 @@ and extract_cst_app env sg mle mlt kn args = (* Can we instantiate types variables for this constant ? *) (* In Ocaml, inside the definition of this constant, the answer is no. *) let instantiated = - if lang () == Ocaml && List.mem_f Constant.equal kn !current_fixpoints + if lang () == Ocaml && List.mem_f Constant.CanOrd.equal kn !current_fixpoints then var2var' (snd schema) else instantiation schema in diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index b1ce10985a..da4a50b674 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -399,7 +399,11 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | MLuint i1, MLuint i2 -> Uint63.equal i1 i2 | MLfloat f1, MLfloat f2 -> Float64.equal f1 f2 -| _, _ -> false +| MLparray (t1,def1), MLparray (t2, def2) -> Array.equal eq_ml_ast t1 t2 && eq_ml_ast def1 def2 +| (MLrel _|MLapp _|MLlam _|MLletin _|MLglob _|MLcons _ + |MLtuple _|MLcase _|MLfix _|MLexn _|MLdummy _|MLaxiom + | MLmagic _| MLuint _| MLfloat _|MLparray _), _ + -> false and eq_ml_pattern p1 p2 = match p1, p2 with | Pcons (gr1, p1), Pcons (gr2, p2) -> @@ -685,7 +689,7 @@ let is_regular_match br = | _ -> raise Impossible in let is_ref i tr = match get_r tr with - | GlobRef.ConstructRef (ind', j) -> eq_ind ind ind' && Int.equal j (i + 1) + | GlobRef.ConstructRef (ind', j) -> Ind.CanOrd.equal ind ind' && Int.equal j (i + 1) | _ -> false in Array.for_all_i is_ref 0 br diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index f8449bcda1..e56d66ca2d 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -32,7 +32,7 @@ module Refset' = GlobRef.Set_env let occur_kn_in_ref kn = let open GlobRef in function | IndRef (kn',_) - | ConstructRef ((kn',_),_) -> MutInd.equal kn kn' + | ConstructRef ((kn',_),_) -> MutInd.CanOrd.equal kn kn' | ConstRef _ | VarRef _ -> false let repr_of_r = let open GlobRef in function diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 6ddc6ba21e..d6790d008a 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -108,10 +108,6 @@ let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_qualid let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (Pputils.pr_or_var (fun x -> pr_global (snd x))) let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global -let warn_deprecated_syntax = - CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated" - (fun () -> Pp.strbrk "Deprecated syntax; use \",\" as separator") - } ARGUMENT EXTEND firstorder_using @@ -119,12 +115,7 @@ ARGUMENT EXTEND firstorder_using 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 - } +| [ "using" ne_reference_list_sep(l,",") ] -> { l } | [ ] -> { [] } END diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index f13901c36d..4adad53899 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -38,7 +38,7 @@ let compare_gr id1 id2 = if id1==id2 then 0 else if id1==dummy_id then 1 else if id2==dummy_id then -1 - else GlobRef.Ordered.compare id1 id2 + else GlobRef.CanOrd.compare id1 id2 module OrderedInstance= struct diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index db3631daa4..99c5f85125 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -62,7 +62,7 @@ module Hitem= struct type t = h_item let compare (id1,co1) (id2,co2)= - let c = GlobRef.Ordered.compare id1 id2 in + let c = GlobRef.CanOrd.compare id1 id2 in if c = 0 then let cmp (i1, c1) (i2, c2) = let c = Int.compare i1 i2 in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index e50c6087bb..73eb943418 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -674,7 +674,7 @@ let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos |Prod _ -> let new_infos = {dyn_infos with info = (f, args)} in build_proof_args env sigma do_finalize new_infos - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + | Const (c, _) when not (List.mem_f Constant.CanOrd.equal c fnames) -> let new_infos = {dyn_infos with info = (f, args)} in (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) build_proof_args env sigma do_finalize new_infos diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 1ab747ca09..0ab9ac65d7 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -100,8 +100,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match Constr.kind c with - | Ind ((u, _), _) -> MutInd.equal u rel_as_kn - | Construct (((u, _), _), _) -> MutInd.equal u rel_as_kn + | Ind ((u, _), _) -> Environ.QMutInd.equal env u rel_as_kn + | Construct (((u, _), _), _) -> Environ.QMutInd.equal env u rel_as_kn | _ -> false in let get_fun_num c = diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index bbc4df7dde..ca6ae150a7 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -147,19 +147,19 @@ END module Vernac = Pvernac.Vernac_ module Tactic = Pltac -let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = - Genarg.create_arg "function_rec_definition_loc" +let (wit_function_fix_definition : Vernacexpr.fixpoint_expr Loc.located Genarg.uniform_genarg_type) = + Genarg.create_arg "function_fix_definition" -let function_rec_definition_loc = - Pcoq.create_generic_entry2 "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) +let function_fix_definition = + Pcoq.create_generic_entry2 "function_fix_definition" (Genarg.rawwit wit_function_fix_definition) } GRAMMAR EXTEND Gram - GLOBAL: function_rec_definition_loc ; + GLOBAL: function_fix_definition ; - function_rec_definition_loc: - [ [ g = Vernac.rec_definition -> { Loc.tag ~loc g } ]] + function_fix_definition: + [ [ g = Vernac.fix_definition -> { Loc.tag ~loc g } ]] ; END @@ -168,7 +168,7 @@ END let () = let raw_printer env sigma _ _ _ (loc,body) = Ppvernac.pr_rec_definition body in - Pptactic.declare_extra_vernac_genarg_pprule wit_function_rec_definition_loc raw_printer + Pptactic.declare_extra_vernac_genarg_pprule wit_function_fix_definition raw_printer let is_proof_termination_interactively_checked recsl = List.exists (function @@ -196,7 +196,7 @@ let is_interactive recsl = } VERNAC COMMAND EXTEND Function STATE CUSTOM -| ["Function" ne_function_rec_definition_loc_list_sep(recsl,"with")] +| ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { if is_interactive recsl then diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 012fcee486..314c8abcaf 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -1316,9 +1316,9 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in List.map - (function - | cst -> List.assoc_f Constant.equal (fst cst) this_block_funs_indexes) + (function cst -> List.assoc_f eq (fst cst) this_block_funs_indexes) funs in let ind_list = @@ -2228,7 +2228,8 @@ let build_case_scheme fa = let prop_sort = Sorts.InProp in let funs_indexes = let this_block_funs_indexes = Array.to_list this_block_funs_indexes in - List.assoc_f Constant.equal funs this_block_funs_indexes + let eq c1 c2 = Environ.QConstant.equal env c1 c2 in + List.assoc_f eq funs this_block_funs_indexes in let ind, sf = let ind = (first_fun_kn, funs_indexes) in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 6ed61043f9..5bfb37f4cb 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -332,7 +332,7 @@ let add_pat_variables sigma pat typ env : Environ.env = let constructors = Inductiveops.get_constructors env indf in let constructor : Inductiveops.constructor_summary = List.find - (fun cs -> eq_constructor c (fst cs.Inductiveops.cs_cstr)) + (fun cs -> Construct.CanOrd.equal c (fst cs.Inductiveops.cs_cstr)) (Array.to_list constructors) in let cs_args_types : types list = @@ -402,7 +402,8 @@ let rec pattern_to_term_and_type env typ = let constructors = Inductiveops.get_constructors env indf in let constructor = List.find - (fun cs -> eq_constructor (fst cs.Inductiveops.cs_cstr) constr) + (fun cs -> + Construct.CanOrd.equal (fst cs.Inductiveops.cs_cstr) constr) (Array.to_list constructors) in let cs_args_types : types list = @@ -457,9 +458,11 @@ let rec pattern_to_term_and_type env typ = but only the value of the function *) +let pr_glob_constr_env env x = pr_glob_constr_env env (Evd.from_env env) x + let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_return = - observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); + observe (str " Entering : " ++ pr_glob_constr_env env rt); let open CAst in match DAst.get rt with | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ @@ -637,9 +640,7 @@ let rec build_entry_lc env sigma funnames avoid rt : with Not_found -> user_err ( str "Cannot find the inductive associated to " - ++ Printer.pr_glob_constr_env env b - ++ str " in " - ++ Printer.pr_glob_constr_env env rt + ++ pr_glob_constr_env env b ++ str " in " ++ pr_glob_constr_env env rt ++ str ". try again with a cast" ) in let case_pats = build_constructors_of_type (fst ind) [] in @@ -661,9 +662,7 @@ let rec build_entry_lc env sigma funnames avoid rt : with Not_found -> user_err ( str "Cannot find the inductive associated to " - ++ Printer.pr_glob_constr_env env b - ++ str " in " - ++ Printer.pr_glob_constr_env env rt + ++ pr_glob_constr_env env b ++ str " in " ++ pr_glob_constr_env env rt ++ str ". try again with a cast" ) in let case_pats = build_constructors_of_type (fst ind) nal_as_glob_constr in @@ -1320,11 +1319,11 @@ let do_build_inductive evd (funconstants : pconstant list) @@ Constrexpr.CLetIn ( CAst.make n , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) , acc ) | None -> @@ -1334,7 +1333,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( [CAst.make n] , Constrexpr_ops.default_binder_kind , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t ) ] , acc )) rel_first_args @@ -1409,11 +1408,11 @@ let do_build_inductive evd (funconstants : pconstant list) @@ Constrexpr.CLetIn ( CAst.make n , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) , acc ) | None -> @@ -1423,7 +1422,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( [CAst.make n] , Constrexpr_ops.default_binder_kind , with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) t ) ] , acc )) rel_first_args @@ -1447,16 +1446,16 @@ let do_build_inductive evd (funconstants : pconstant list) | Some typ -> Constrexpr.CLocalDef ( CAst.make n - , Constrextern.extern_glob_constr Id.Set.empty t + , Constrextern.(extern_glob_constr empty_extern_env) t , Some (with_full_print - (Constrextern.extern_glob_constr Id.Set.empty) + Constrextern.(extern_glob_constr empty_extern_env) typ) ) | None -> Constrexpr.CLocalAssum ( [CAst.make n] , Constrexpr_ops.default_binder_kind - , Constrextern.extern_glob_constr Id.Set.empty t )) + , Constrextern.(extern_glob_constr empty_extern_env) t )) rels_params in let ext_rels_constructors = @@ -1465,7 +1464,7 @@ let do_build_inductive evd (funconstants : pconstant list) ( false , ( CAst.make id , with_full_print - (Constrextern.extern_glob_type Id.Set.empty) + Constrextern.(extern_glob_type empty_extern_env) ((* zeta_normalize *) alpha_rt rel_params_ids t) ) ))) rel_constructors in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 8e1331ace9..164a446fe3 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -444,7 +444,8 @@ let rec are_unifiable_aux = function match (DAst.get l, DAst.get r) with | PatVar _, _ | _, PatVar _ -> are_unifiable_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs @@ -464,7 +465,8 @@ let rec eq_cases_pattern_aux = function match (DAst.get l, DAst.get r) with | PatVar _, PatVar _ -> eq_cases_pattern_aux eqs | PatCstr (constructor1, cpl1, _), PatCstr (constructor2, cpl2, _) -> - if not (eq_constructor constructor2 constructor1) then raise NotUnifiable + if not (Construct.CanOrd.equal constructor2 constructor1) then + raise NotUnifiable else let eqs' = try List.combine cpl1 cpl2 @ eqs diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 0179215d6a..6464556e4e 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -108,7 +108,7 @@ let with_full_print f a = Constrextern.print_universes := old_printuniverses; Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); + Dumpglob.pop_output (); res with reraise -> Impargs.make_implicit_args old_implicit_args; @@ -118,7 +118,7 @@ let with_full_print f a = Constrextern.print_universes := old_printuniverses; Goptions.set_bool_option_value Detyping.print_allow_match_default_opt_name old_printallowmatchdefaultclause; - Dumpglob.continue (); + Dumpglob.pop_output (); raise reraise (**********************) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5d631aac84..118a917381 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -27,12 +27,13 @@ open Indfun_common *) let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in let sigma = project gl in let typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma typ with | App (i, args) when isInd sigma i -> let ((kn', num) as ind'), u = destInd sigma i in - if MutInd.equal kn kn' then + if Environ.QMutInd.equal env kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = match find_Function_of_graph ind' with diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 33076a876b..9d896e9182 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -776,7 +776,7 @@ let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos let a' = infos.info in let new_info = { infos with - info = mkCase (ci, t, iv, a', l) + info = mkCase (ci, a, iv, a', l) ; is_main_branch = expr_info.is_main_branch ; is_final = expr_info.is_final } in diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index b7ac71181a..e39c066c95 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -122,10 +122,10 @@ END TACTIC EXTEND constructor | [ "constructor" ] -> { Tactics.any_constructor false None } -| [ "constructor" int_or_var(i) ] -> { +| [ "constructor" nat_or_var(i) ] -> { Tactics.constructor_tac false None i NoBindings } -| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "constructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac false None i bl in Tacticals.New.tclDELAYEDWITHHOLES false bl tac } @@ -133,10 +133,10 @@ END TACTIC EXTEND econstructor | [ "econstructor" ] -> { Tactics.any_constructor true None } -| [ "econstructor" int_or_var(i) ] -> { +| [ "econstructor" nat_or_var(i) ] -> { Tactics.constructor_tac true None i NoBindings } -| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> { +| [ "econstructor" nat_or_var(i) "with" bindings(bl) ] -> { let tac bl = Tactics.constructor_tac true None i bl in Tacticals.New.tclDELAYEDWITHHOLES true bl tac } diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index ad4374dba3..daed855600 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -41,7 +41,7 @@ let () = create_generic_quotation "ipattern" Pltac.simple_intropattern wit_simpl let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr let () = let inject (loc, v) = Tacexpr.Tacexp v in - Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) + Tacentries.create_ltac_quotation "ltac" inject (Pltac.ltac_expr, Some 5) (** Backward-compatible tactic notation entry names *) @@ -150,7 +150,7 @@ let pr_occurrences = pr_occurrences () () () let pr_gen env sigma prc _prlc _prtac x = prc env sigma x let pr_globc env sigma _prc _prlc _prtac (_,glob) = - Printer.pr_glob_constr_env env glob + Printer.pr_glob_constr_env env sigma glob let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index a2a47c0bf4..0b5d36b845 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -41,7 +41,7 @@ DECLARE PLUGIN "ltac_plugin" (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) -(* dependent rewrite *) +(* cutrewrite, dependent rewrite *) let with_delayed_uconstr ist c tac = let flags = { @@ -201,6 +201,12 @@ TACTIC EXTEND dependent_rewrite -> { rewriteInHyp b c id } END +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> { cutRewriteInHyp b eqn id } +END + (**********************************************************************) (* Decompose *) @@ -686,7 +692,7 @@ let hResolve_auto id c t = } 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) ")" "at" nat_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 @@ -695,7 +701,7 @@ END *) TACTIC EXTEND hget_evar -| [ "hget_evar" int_or_var(n) ] -> { Evar_tactics.hget_evar n } +| [ "hget_evar" nat_or_var(n) ] -> { Evar_tactics.hget_evar n } END (**********************************************************************) diff --git a/plugins/ltac/g_auto.mlg b/plugins/ltac/g_auto.mlg index 44472a1995..069a342b2a 100644 --- a/plugins/ltac/g_auto.mlg +++ b/plugins/ltac/g_auto.mlg @@ -63,7 +63,7 @@ let eval_uconstrs ist cs = let pr_auto_using_raw env sigma _ _ _ = Pptactic.pr_auto_using @@ Ppconstr.pr_constr_expr env sigma let pr_auto_using_glob env sigma _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> - Printer.pr_glob_constr_env env c) + Printer.pr_glob_constr_env env sigma c) let pr_auto_using env sigma _ _ _ = Pptactic.pr_auto_using @@ Printer.pr_closed_glob_env env sigma @@ -96,17 +96,17 @@ TACTIC EXTEND debug_trivial END TACTIC EXTEND auto -| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> +| [ "auto" nat_or_var_opt(n) auto_using(lems) hintbases(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) ] -> +| [ "info_auto" nat_or_var_opt(n) auto_using(lems) hintbases(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) ] -> +| [ "debug" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db } END @@ -116,16 +116,29 @@ END let make_depth n = snd (Eauto.make_dimension n None) +(* deprecated in 8.13; the second int_or_var will be removed *) +let deprecated_eauto_bfs = + CWarnings.create + ~name:"eauto_bfs" ~category:"deprecated" + (fun () -> Pp.str "The syntax [eauto @int_or_var @int_or_var] is deprecated. Use [bfs eauto] instead.") + +let deprecated_bfs tacname = + CWarnings.create + ~name:"eauto_bfs" ~category:"deprecated" + (fun () -> Pp.str "The syntax [" ++ Pp.str tacname ++ Pp.str "@int_or_var @int_or_var] is deprecated. No replacement yet.") + } TACTIC EXTEND eauto -| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> deprecated_eauto_bfs () | _ -> () ); + 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) +TACTIC EXTEND new_eauto (* todo: name doesn't match syntax *) +| [ "new" "auto" nat_or_var_opt(n) auto_using(lems) hintbases(db) ] -> { match db with | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) @@ -133,23 +146,33 @@ TACTIC EXTEND new_eauto END TACTIC EXTEND debug_eauto -| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) +| [ "debug" "eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> (deprecated_bfs "debug eauto") () | _ -> () ); + 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) +| [ "info_eauto" nat_or_var_opt(n) nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> - { Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db } + { + ( match n,p with Some _, Some _ -> (deprecated_bfs "info_eauto") () | _ -> () ); + 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) +| [ "dfs" "eauto" nat_or_var_opt(p) auto_using(lems) hintbases(db) ] -> { Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db } END +TACTIC EXTEND bfs_eauto +| [ "bfs" "eauto" nat_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + { Eauto.gen_eauto (true, Eauto.make_depth p) (eval_uconstrs ist lems) db } +END + TACTIC EXTEND autounfold | [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> { Eauto.autounfold_tac db cl } END @@ -240,10 +263,21 @@ ARGUMENT EXTEND opthints END VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF -| #[ locality = Attributes.locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { - let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in - let locality = if Locality.make_section_locality locality then Goptions.OptLocal else Goptions.OptGlobal in - Hints.add_hints ~locality - (match dbnames with None -> ["core"] | Some l -> l) entry; +| #[ locality = Attributes.option_locality; ] [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> { + let open Goptions in + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in + let () = match locality with + | OptGlobal -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the global attribute in sections."); + | OptExport -> + if Global.sections_are_opened () then + CErrors.user_err Pp.(str + "This command does not support the export attribute in sections."); + | OptDefault | OptLocal -> () + in + Hints.add_hints ~locality + (match dbnames with None -> ["core"] | Some l -> l) entry; } END diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 8c2e633be5..0f59ac07b4 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -86,13 +86,13 @@ 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" "bfs" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs l } - | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + | [ "typeclasses" "eauto" nat_or_var_opt(d) "with" ne_preident_list(l) ] -> { typeclasses_eauto ~depth:d l } - | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" "bfs" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~strategy:Bfs ~only_classes:true [Class_tactics.typeclasses_db] } - | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> { + | [ "typeclasses" "eauto" nat_or_var_opt(d) ] -> { typeclasses_eauto ~depth:d ~only_classes:true [Class_tactics.typeclasses_db] } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 6cf5d30a95..b1b96ea9a7 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -74,22 +74,22 @@ let hint = G_proofs.hint } GRAMMAR EXTEND Gram - GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + GLOBAL: tactic tacdef_body ltac_expr binder_tactic tactic_value command hint tactic_mode constr_may_eval constr_eval toplevel_selector - operconstr; + term; tactic_then_last: - [ [ "|"; lta = LIST0 (OPT tactic_expr) SEP "|" -> + [ [ "|"; lta = LIST0 (OPT ltac_expr) SEP "|" -> { Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) } | -> { [||] } ] ] ; - tactic_then_gen: - [ [ 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)) } + for_each_goal: + [ [ ta = ltac_expr; "|"; tg = for_each_goal -> { let (first,last) = tg in (ta::first, last) } + | ta = ltac_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) } + | ta = ltac_expr -> { ([ta], None) } + | "|"; tg = for_each_goal -> { let (first,last) = tg in (TacId [] :: first, last) } | -> { ([TacId []], None) } ] ] ; @@ -97,13 +97,13 @@ GRAMMAR EXTEND Gram for [TacExtend] *) [ [ "[" ; l = OPT">" -> { if Option.is_empty l then true else false } ] ] ; - tactic_expr: + ltac_expr: [ "5" RIGHTA [ 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; tg = tactic_then_gen; "]" -> { + [ ta0 = ltac_expr; ";"; ta1 = binder_tactic -> { TacThen (ta0, ta1) } + | ta0 = ltac_expr; ";"; ta1 = ltac_expr -> { TacThen (ta0,ta1) } + | ta0 = ltac_expr; ";"; l = tactic_then_locality; tg = for_each_goal; "]" -> { let (first,tail) = tg in match l , tail with | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) @@ -111,51 +111,51 @@ GRAMMAR EXTEND Gram | false , None -> TacThen (ta0,TacDispatch 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 = ltac_expr -> { TacTry ta } + | IDENT "do"; n = nat_or_var; ta = ltac_expr -> { TacDo (n,ta) } + | IDENT "timeout"; n = nat_or_var; ta = ltac_expr -> { TacTimeout (n,ta) } + | IDENT "time"; s = OPT string; ta = ltac_expr -> { TacTime (s,ta) } + | IDENT "repeat"; ta = ltac_expr -> { TacRepeat ta } + | IDENT "progress"; ta = ltac_expr -> { TacProgress ta } + | IDENT "once"; ta = ltac_expr -> { TacOnce ta } + | IDENT "exactly_once"; ta = ltac_expr -> { TacExactlyOnce ta } + | IDENT "infoH"; ta = ltac_expr -> { TacShowHyps ta } (*To do: put Abstract in Refiner*) | 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) } ] + | IDENT "only"; sel = selector; ":"; ta = ltac_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) } - | 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) } ] + [ ta0 = ltac_expr; "+"; ta1 = binder_tactic -> { TacOr (ta0,ta1) } + | ta0 = ltac_expr; "+"; ta1 = ltac_expr -> { TacOr (ta0,ta1) } + | IDENT "tryif" ; ta = ltac_expr ; + "then" ; tat = ltac_expr ; + "else" ; tae = ltac_expr -> { TacIfThenCatch(ta,tat,tae) } + | ta0 = ltac_expr; "||"; ta1 = binder_tactic -> { TacOrelse (ta0,ta1) } + | ta0 = ltac_expr; "||"; ta1 = ltac_expr -> { TacOrelse (ta0,ta1) } ] | "1" RIGHTA [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,false,mrl) } | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; mrl = match_context_list; "end" -> { TacMatchGoal (b,true,mrl) } - | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + | b = match_key; c = ltac_expr; "with"; mrl = match_list; "end" -> { TacMatch (b,c,mrl) } - | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "first" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst l } - | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + | IDENT "solve" ; "["; l = LIST0 ltac_expr SEP "|"; "]" -> { TacSolve l } | IDENT "idtac"; l = LIST0 message_token -> { TacId l } | g=failkw; n = [ n = int_or_var -> { n } | -> { fail_default_value } ]; l = LIST0 message_token -> { TacFail (g,n,l) } | st = simple_tactic -> { st } - | a = tactic_arg -> { TacArg(CAst.make ~loc a) } - | r = reference; la = LIST0 tactic_arg_compat -> + | a = tactic_value -> { TacArg(CAst.make ~loc a) } + | r = reference; la = LIST0 tactic_arg -> { TacArg(CAst.make ~loc @@ TacCall (CAst.make ~loc (r,la))) } ] | "0" - [ "("; a = tactic_expr; ")" -> { a } - | "["; ">"; tg = tactic_then_gen; "]" -> { + [ "("; a = ltac_expr; ")" -> { a } + | "["; ">"; tg = for_each_goal; "]" -> { let (tf,tail) = tg in begin match tail with | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) @@ -166,24 +166,24 @@ GRAMMAR EXTEND Gram failkw: [ [ IDENT "fail" -> { TacLocal } | IDENT "gfail" -> { TacGlobal } ] ] ; - (* binder_tactic: level 5 of tactic_expr *) + (* binder_tactic: level 5 of ltac_expr *) binder_tactic: [ RIGHTA - [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + [ "fun"; it = LIST1 input_fun ; "=>"; body = ltac_expr LEVEL "5" -> { 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) } ] ] + body = ltac_expr LEVEL "5" -> { TacLetIn (isrec,llc,body) } ] ] ; (* Tactic arguments to the right of an application *) - tactic_arg_compat: - [ [ a = tactic_arg -> { a } + tactic_arg: + [ [ a = tactic_value -> { 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 (None, genarg_of_unit ()) } ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) - tactic_arg: + tactic_value: [ [ c = constr_eval -> { ConstrMayEval c } | IDENT "fresh"; l = LIST0 fresh_id -> { TacFreshId l } | IDENT "type_term"; c=uconstr -> { TacPretype c } @@ -223,20 +223,20 @@ GRAMMAR EXTEND Gram | l = ident -> { Name.Name l } ] ] ; let_clause: - [ [ idr = identref; ":="; te = tactic_expr -> + [ [ idr = identref; ":="; te = ltac_expr -> { (CAst.map (fun id -> Name id) idr, arg_of_expr te) } - | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = tactic_expr -> + | na = ["_" -> { CAst.make ~loc Anonymous } ]; ":="; te = ltac_expr -> { (na, arg_of_expr te) } - | idr = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + | idr = identref; args = LIST1 input_fun; ":="; te = ltac_expr -> { (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; "]" -> + "["; pc = Constr.cpattern; "]" -> { Subterm (oid, pc) } - | pc = Constr.lconstr_pattern -> { Term pc } ] ] + | pc = Constr.cpattern -> { Term pc } ] ] ; - match_hyps: + match_hyp: [ [ 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 -> @@ -250,19 +250,19 @@ GRAMMAR EXTEND Gram ] ] ; match_context_rule: - [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; - "=>"; 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 } ] ] + [ [ largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "["; largs = LIST0 match_hyp SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = ltac_expr -> { Pat (largs, mp, te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_context_list: [ [ 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 = ltac_expr -> { Pat ([],mp,te) } + | "_"; "=>"; te = ltac_expr -> { All te } ] ] ; match_list: [ [ mrl = LIST1 match_rule SEP "|" -> { mrl } @@ -282,13 +282,13 @@ GRAMMAR EXTEND Gram (* Definitions for tactics *) tacdef_body: [ [ name = Constr.global; it=LIST1 input_fun; - redef = ltac_def_kind; body = tactic_expr -> + redef = ltac_def_kind; body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) else let id = reference_to_id name in Tacexpr.TacticDefinition (id, TacFun (it, body)) } | name = Constr.global; redef = ltac_def_kind; - body = tactic_expr -> + body = ltac_expr -> { if redef then Tacexpr.TacticRedefinition (name, body) else let id = reference_to_id name in @@ -296,7 +296,7 @@ GRAMMAR EXTEND Gram ] ] ; tactic: - [ [ tac = tactic_expr -> { tac } ] ] + [ [ tac = ltac_expr -> { tac } ] ] ; range_selector: @@ -314,15 +314,12 @@ GRAMMAR EXTEND Gram { let open Goal_select in Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l } ] ] ; - selector_body: + selector: [ [ l = range_selector_or_nth -> { l } | test_bracket_ident; "["; id = ident; "]" -> { Goal_select.SelectId id } ] ] ; - selector: - [ [ IDENT "only"; sel = selector_body; ":" -> { sel } ] ] - ; toplevel_selector: - [ [ sel = selector_body; ":" -> { sel } + [ [ sel = selector; ":" -> { sel } | "!"; ":" -> { Goal_select.SelectAlreadyFocused } | IDENT "all"; ":" -> { Goal_select.SelectAll } ] ] ; @@ -332,19 +329,19 @@ GRAMMAR EXTEND Gram ; command: [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; - l = OPT [ "using"; l = G_vernac.section_subset_expr -> { l } ] -> + l = OPT [ IDENT "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) } ] ] + | IDENT "Proof"; IDENT "using"; l = G_vernac.section_subset_expr; + "with"; ta = Pltac.tactic -> + { Vernacexpr.VernacProof (Some (in_tac ta),Some l) } ] ] ; hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ] ; - operconstr: LEVEL "0" - [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + term: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.ltac_expr; ")" -> { let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in CAst.make ~loc @@ CHole (None, IntroAnonymous, Some arg) } ] ] ; @@ -402,7 +399,7 @@ VERNAC { tactic_mode } EXTEND VernacSolve STATE proof { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in let global = match g with Goal_select.SelectAll | Goal_select.SelectList _ -> true | _ -> false in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global; ast = t; } in ComTactic.solve g ~info t ~with_end_tac } END @@ -415,7 +412,7 @@ VERNAC { tactic_mode } EXTEND VernacSolveParallel STATE proof VtProofStep{ proof_block_detection = pbr } } -> { let t, abstract = rm_abstract t in - let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global = true; ast = t; }) in + let t = Tacinterp.hide_interp { Tacinterp.global = true; ast = t; } in ComTactic.solve_parallel ~info t ~abstract ~with_end_tac } END @@ -469,7 +466,7 @@ END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - { Feedback.msg_notice (Tacintern.print_ltac r) } + { Feedback.msg_notice (Tacentries.print_ltac r) } END VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY diff --git a/plugins/ltac/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index ee94fd565a..f12ca0685e 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -40,9 +40,9 @@ type glob_constr_with_bindings = glob_constr_and_expr with_bindings type glob_constr_with_bindings_sign = interp_sign * glob_constr_and_expr with_bindings let pr_glob_constr_with_bindings_sign env sigma _ _ _ (ge : glob_constr_with_bindings_sign) = - Printer.pr_glob_constr_env env (fst (fst (snd ge))) + Printer.pr_glob_constr_env env sigma (fst (fst (snd ge))) let pr_glob_constr_with_bindings env sigma _ _ _ (ge : glob_constr_with_bindings) = - Printer.pr_glob_constr_env env (fst (fst ge)) + Printer.pr_glob_constr_env env sigma (fst (fst ge)) let pr_constr_expr_with_bindings env sigma prc _ _ (ge : constr_expr_with_bindings) = prc env sigma (fst ge) let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l @@ -67,12 +67,12 @@ END { type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast -type glob_strategy = (glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (glob_constr_and_expr, Tacexpr.glob_red_expr) strategy_ast let interp_strategy ist gl s = let sigma = project gl in - sigma, strategy_of_ast s -let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s + sigma, strategy_of_ast ist s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (Tacintern.intern_red_expr ist) s let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" @@ -80,12 +80,9 @@ let pr_raw_strategy env sigma prc prlc _ (s : raw_strategy) = let prr = Pptactic.pr_red_expr env sigma (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_qualid, prc) in Rewrite.pr_strategy (prc env sigma) prr s let pr_glob_strategy env sigma prc prlc _ (s : glob_strategy) = - let prr = Pptactic.pr_red_expr env sigma - (Ppconstr.pr_constr_expr, - Ppconstr.pr_lconstr_expr, - Pputils.pr_or_by_notation Libnames.pr_qualid, - Ppconstr.pr_constr_expr) - in + let prpat env sigma (_,c,_) = prc env sigma c in + let prcst = Pputils.pr_or_var Pptactic.(pr_and_short_name (pr_evaluable_reference_env env)) in + let prr = Pptactic.pr_red_expr env sigma (prc, prlc, prcst, prpat) in Rewrite.pr_strategy (prc env sigma) prr s } @@ -130,15 +127,15 @@ END { 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)) +let cl_rewrite_clause_db ist db = cl_rewrite_clause_strat (strategy_of_ast ist (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_db" preident(db) "in" hyp(id) ] -> { cl_rewrite_clause_db ist db (Some id) } +| [ "rewrite_db" preident(db) ] -> { cl_rewrite_clause_db ist db None } END { diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index c186a83a5c..43957bbde5 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -121,8 +121,8 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind -let mkNumeral n = - Numeral (NumTok.Signed.of_int_string (string_of_int n)) +let mkNumber n = + Number (NumTok.Signed.of_int_string (string_of_int n)) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> @@ -130,7 +130,7 @@ let mkTacCase with_evar = function (* Reinterpret numbers as a notation for terms *) | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (clear,(CAst.make @@ CPrim (mkNumeral n), + (clear,(CAst.make @@ CPrim (mkNumber n), NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) @@ -190,7 +190,7 @@ open Pvernac.Vernac_ GRAMMAR EXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis - bindings red_expr int_or_var open_constr uconstr + bindings red_expr int_or_var nat_or_var open_constr uconstr simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: @@ -234,9 +234,7 @@ GRAMMAR EXTEND Gram ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } - | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) - { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] + | "-"; nl = LIST1 nat_or_var -> { AllOccurrencesBut nl } ] ] ; occs: [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] @@ -291,7 +289,7 @@ GRAMMAR EXTEND Gram ; simple_intropattern: [ [ pat = simple_intropattern_closed; - l = LIST0 ["%"; c = operconstr LEVEL "0" -> { c } ] -> + l = LIST0 ["%"; c = term LEVEL "0" -> { c } ] -> { let {CAst.loc=loc0;v=pat} = pat in let f c pat = let loc1 = Constrexpr_ops.constr_loc c in @@ -320,7 +318,7 @@ GRAMMAR EXTEND Gram with_bindings: [ [ "with"; bl = bindings -> { bl } | -> { NoBindings } ] ] ; - red_flags: + red_flag: [ [ IDENT "beta" -> { [FBeta] } | IDENT "iota" -> { [FMatch;FFix;FCofix] } | IDENT "match" -> { [FMatch] } @@ -337,7 +335,7 @@ GRAMMAR EXTEND Gram ] ] ; strategy_flag: - [ [ s = LIST1 red_flags -> { Redops.make_red_flag (List.flatten s) } + [ [ s = LIST1 red_flag -> { Redops.make_red_flag (List.flatten s) } | d = delta_flag -> { all_with d } ] ] ; @@ -379,9 +377,11 @@ GRAMMAR EXTEND Gram { {onhyps=None; concl_occs=occs} } | "*"; "|-"; occs=concl_occ -> { {onhyps=None; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + | "|-"; occs=concl_occ -> + { {onhyps=Some []; concl_occs=occs} } + | hl = LIST1 hypident_occ SEP ","; "|-"; occs=concl_occ -> { {onhyps=Some hl; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP"," -> + | hl = LIST1 hypident_occ SEP "," -> { {onhyps=Some hl; concl_occs=NoOccurrences} } ] ] ; clause_dft_concl: @@ -407,8 +407,8 @@ GRAMMAR EXTEND Gram | -> { [] } ] ] ; in_hyp_as: - [ [ "in"; id = id_or_meta; ipat = as_ipat -> { Some (id,ipat) } - | -> { None } ] ] + [ [ "in"; l = LIST1 [id = id_or_meta; ipat = as_ipat -> { (id,ipat) } ] SEP "," -> { l } + | -> { [] } ] ] ; orient_rw: [ [ "->" -> { true } @@ -450,6 +450,11 @@ GRAMMAR EXTEND Gram ; as_or_and_ipat: [ [ "as"; ipat = or_and_intropattern_loc -> { Some ipat } + | "as"; ipat = equality_intropattern -> + { match ipat with + | IntroRewrite _ -> user_err Pp.(str "Disjunctive/conjunctive pattern expected.") + | IntroInjection _ -> user_err Pp.(strbrk "Found an injection pattern while a disjunctive/conjunctive pattern was expected; use " ++ str "\"injection as pattern\"" ++ strbrk " instead.") + | _ -> assert false } | -> { None } ] ] ; eqn_ipat: @@ -460,7 +465,7 @@ GRAMMAR EXTEND Gram [ [ "as"; id = ident -> { Names.Name.Name id } | -> { Names.Name.Anonymous } ] ] ; by_tactic: - [ [ "by"; tac = tactic_expr LEVEL "3" -> { Some tac } + [ [ "by"; tac = ltac_expr LEVEL "3" -> { Some tac } | -> { None } ] ] ; rewriter : diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index b7b54143df..80c13a3698 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -29,6 +29,7 @@ let quantified_hypothesis = Entry.create "quantified_hypothesis" let destruction_arg = Entry.create "destruction_arg" let int_or_var = Entry.create "int_or_var" +let nat_or_var = Entry.create "nat_or_var" let simple_intropattern = Entry.create "simple_intropattern" let in_clause = Entry.create "in_clause" @@ -37,19 +38,20 @@ let clause_dft_concl = (* Main entries for ltac *) -let tactic_arg = Entry.create "tactic_arg" -let tactic_expr = Entry.create "tactic_expr" +let tactic_value = Entry.create "tactic_value" +let tactic_arg = tactic_value +let ltac_expr = Entry.create "ltac_expr" +let tactic_expr = ltac_expr let binder_tactic = Entry.create "binder_tactic" let tactic = Entry.create "tactic" (* Main entry for quotations *) -let tactic_eoi = eoi_entry tactic - let () = let open Stdarg in let open Tacarg in register_grammar wit_int_or_var (int_or_var); + register_grammar wit_nat_or_var (nat_or_var); register_grammar wit_intro_pattern (simple_intropattern); (* To remove at end of deprecation phase *) (* register_grammar wit_intropattern (intropattern); *) (* To be added at end of deprecation phase *) register_grammar wit_simple_intropattern (simple_intropattern); diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli index 8565c4b4d6..73bce84d18 100644 --- a/plugins/ltac/pltac.mli +++ b/plugins/ltac/pltac.mli @@ -27,12 +27,16 @@ val uconstr : constr_expr Entry.t val quantified_hypothesis : quantified_hypothesis Entry.t val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Entry.t val int_or_var : int Locus.or_var Entry.t +val nat_or_var : int Locus.or_var Entry.t val simple_tactic : raw_tactic_expr Entry.t val simple_intropattern : constr_expr intro_pattern_expr CAst.t Entry.t val in_clause : Names.lident Locus.clause_expr Entry.t val clause_dft_concl : Names.lident Locus.clause_expr Entry.t +val tactic_value : raw_tactic_arg Entry.t val tactic_arg : raw_tactic_arg Entry.t + [@@deprecated "Deprecated in 8.13; use 'tactic_value' instead"] +val ltac_expr : raw_tactic_expr Entry.t val tactic_expr : raw_tactic_expr Entry.t + [@@deprecated "Deprecated in 8.13; use 'ltac_expr' instead"] val binder_tactic : raw_tactic_expr Entry.t val tactic : raw_tactic_expr Entry.t -val tactic_eoi : raw_tactic_expr Entry.t diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index fe896f9351..faad792ea9 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -458,8 +458,8 @@ let string_of_genarg_arg (ArgumentType arg) = | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) let pr_in_hyp_as prc pr_id = function - | None -> mt () - | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep pr_comma (fun (id,ipat) -> pr_id id ++ pr_as_ipat prc ipat) l) let pr_in_clause pr_id = function | { onhyps=None; concl_occs=NoOccurrences } -> @@ -1131,12 +1131,12 @@ let pr_goal_selector ~toplevel s = let rec prtac n (t:glob_tactic_expr) = let pr = { pr_tactic = prtac; - pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); - pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); - pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)); - pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env)); - pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env)); + pr_constr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); + pr_lconstr = (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)); + pr_pattern = (fun env sigma -> pr_pat_and_constr_expr (pr_glob_constr_env env sigma)); pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); + pr_lpattern = (fun env sigma -> pr_pat_and_constr_expr (pr_lglob_constr_env env sigma)); pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); pr_name = pr_lident; pr_generic = Pputils.pr_glb_generic; @@ -1167,7 +1167,7 @@ let pr_goal_selector ~toplevel s = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); pr_constr = pr_econstr_env; - pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)); + pr_dconstr = (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)); pr_lconstr = pr_leconstr_env; pr_pattern = pr_constr_pattern_env; pr_lpattern = pr_lconstr_pattern_env; @@ -1190,7 +1190,7 @@ let pr_goal_selector ~toplevel s = let pr_raw_extend env sigma = pr_raw_extend_rec @@ pr_raw_tactic_level env sigma - let pr_glob_extend env sigma = pr_glob_extend_rec (pr_glob_tactic_level env) + let pr_glob_extend env = pr_glob_extend_rec (pr_glob_tactic_level env) let pr_alias pr lev key args = pr_alias_gen (fun _ arg -> pr arg) lev key args @@ -1213,8 +1213,8 @@ let declare_extra_genarg_pprule wit f env sigma pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x) in let g x = Genprint.PrinterBasic (fun env sigma -> - g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) - (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)) (fun env sigma -> pr_glob_tactic_level env) x) in let h x = @@ -1243,8 +1243,8 @@ let declare_extra_genarg_pprule_with_level wit default_already_surrounded = default_surrounded; default_ensure_surrounded = default_non_surrounded; printer = (fun env sigma n -> - g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env)) - (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env)) + g env sigma (fun env sigma -> pr_and_constr_expr (pr_glob_constr_env env sigma)) + (fun env sigma -> pr_and_constr_expr (pr_lglob_constr_env env sigma)) (fun env sigma -> pr_glob_tactic_level env) n x) } in let h x = @@ -1302,10 +1302,10 @@ let register_basic_print0 wit f g h = Genprint.register_print0 wit (lift f) (lift g) (lift_top h) let pr_glob_constr_pptac env sigma c = - pr_glob_constr_env env c + pr_glob_constr_env env sigma c let pr_lglob_constr_pptac env sigma c = - pr_lglob_constr_env env c + pr_lglob_constr_env env sigma c let pr_raw_intro_pattern = lift_env (fun env sigma -> Miscprint.pr_intro_pattern @@ pr_constr_expr env sigma) @@ -1318,6 +1318,7 @@ let () = let pr_unit _ = str "()" in let open Genprint in register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; + register_basic_print0 wit_nat_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref pr_qualid (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_smart_global @@ -1334,8 +1335,8 @@ let () = ; Genprint.register_print0 wit_constr - (lift_env Ppconstr.pr_lconstr_expr) - (lift_env (fun env sigma (c, _) -> pr_lglob_constr_pptac env sigma c)) + (lift_env Ppconstr.pr_constr_expr) + (lift_env (fun env sigma (c, _) -> pr_glob_constr_pptac env sigma c)) (make_constr_printer Printer.pr_econstr_n_env) ; Genprint.register_print0 diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli index 6a9fb5c2ea..79e0adf9f7 100644 --- a/plugins/ltac/pptactic.mli +++ b/plugins/ltac/pptactic.mli @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** This module implements pretty-printers for tactic_expr syntactic +(** This module implements pretty-printers for ltac_expr syntactic objects and their subcomponents. *) open Genarg @@ -124,7 +124,7 @@ val pr_glb_generic : env -> Evd.evar_map -> glevel generic_argument -> Pp.t val pr_raw_extend: env -> Evd.evar_map -> int -> ml_tactic_entry -> raw_tactic_arg list -> Pp.t -val pr_glob_extend: env -> Evd.evar_map -> int -> +val pr_glob_extend: env -> int -> ml_tactic_entry -> glob_tactic_arg list -> Pp.t val pr_extend : diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 9c15d24dd3..aa2449d962 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -244,7 +244,8 @@ let string_of_call ck = (Pptactic.pr_glob_tactic (Global.env ()) (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, _) -> - pr_glob_constr_env (Global.env ()) c + let env = Global.env () in + pr_glob_constr_env env (Evd.from_env env) c | Tacexpr.LtacMLCall te -> (Pptactic.pr_glob_tactic (Global.env ()) te) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 9bb435f4dc..77162ce89a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -13,7 +13,6 @@ open CErrors open Util open Names open Nameops -open Namegen open Constr open Context open EConstr @@ -485,7 +484,7 @@ let rec decompose_app_rel env evd t = let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Retyping.get_type_of env evd argl in let r = Retyping.relevance_of_type env evd ty in - let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + let f'' = mkLambda (make_annot (Name Namegen.default_dependent_ident) r, ty, mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) @@ -968,7 +967,7 @@ let fold_match ?(force=false) env sigma c = let unfold_match env sigma sk app = match EConstr.kind sigma app with - | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> + | App (f', args) when QConstant.equal env (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in Reductionops.whd_beta env sigma (mkApp (v, args)) @@ -1119,7 +1118,14 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in + let unfresh, n' = + let id = match n.binder_name with + | Anonymous -> Namegen.default_dependent_ident + | Name id -> id + in + let id = Tactics.fresh_id_in_env unfresh id env in + Id.Set.add id unfresh, {n with binder_name = Name id} + in let unfresh = match n'.binder_name with | Anonymous -> unfresh | Name id -> Id.Set.add id unfresh @@ -1542,7 +1548,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = (* For compatibility *) let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in - let treat sigma res = + let treat sigma res state = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> @@ -1553,7 +1559,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in - let gls = List.map Proofview.with_empty_state gls in + let gls = List.map (fun gl -> Proofview.goal_with_state gl state) gls in match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ @@ -1583,6 +1589,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in + let state = Proofview.Goal.state gl in let sigma = Tacmach.New.project gl in let ty = match clause with | None -> concl @@ -1602,7 +1609,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = cl_rewrite_clause_aux ?abs strat env Id.Set.empty sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma res <*> + treat sigma res state <*> (* For compatibility *) beta <*> Proofview.shelve_unifiable with @@ -1638,9 +1645,9 @@ let cl_rewrite_clause l left2right occs clause = let cl_rewrite_clause_strat strat clause = cl_rewrite_clause_strat false strat clause -let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> +let apply_glob_constr ist c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = - let (sigma, c) = Pretyping.understand_tcc env sigma c in + let (sigma, c) = Tacinterp.interp_open_constr ist env sigma c in (sigma, (c, NoBindings)) in let flags = general_rewrite_unif_flags () in @@ -1717,12 +1724,12 @@ let rec pr_strategy prc prr = function | StratEval r -> str "eval" ++ spc () ++ prr r | StratFold c -> str "fold" ++ spc () ++ prc c -let rec strategy_of_ast = function +let rec strategy_of_ast ist = function | StratId -> Strategies.id | StratFail -> Strategies.fail | StratRefl -> Strategies.refl | StratUnary (f, s) -> - let s' = strategy_of_ast s in + let s' = strategy_of_ast ist s in let f' = match f with | Subterms -> all_subterms | Subterm -> one_subterm @@ -1736,13 +1743,13 @@ let rec strategy_of_ast = function | Repeat -> Strategies.repeat in f' s' | StratBinary (f, s, t) -> - let s' = strategy_of_ast s in - let t' = strategy_of_ast t in + let s' = strategy_of_ast ist s in + let t' = strategy_of_ast ist t in let f' = match f with | Compose -> Strategies.seq | Choice -> Strategies.choice in f' s' t' - | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } + | StratConstr (c, b) -> { strategy = apply_glob_constr ist c b AllOccurrences } | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id | StratTerms l -> { strategy = (fun ({ state = () ; env } as input) -> @@ -1751,7 +1758,7 @@ let rec strategy_of_ast = function } | StratEval r -> { strategy = (fun ({ state = () ; env ; evars } as input) -> - let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + let (sigma,r_interp) = Tacinterp.interp_red_expr ist env (goalevars evars) r in (Strategies.reduce r_interp).strategy { input with evars = (sigma,cstrevars evars) }) } | StratFold c -> Strategies.fold_glob (fst c) diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli index 60a66dd861..8e0ce183c2 100644 --- a/plugins/ltac/rewrite.mli +++ b/plugins/ltac/rewrite.mli @@ -62,7 +62,7 @@ type rewrite_result = type strategy -val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy +val strategy_of_ast : interp_sign -> (glob_constr_and_expr, glob_red_expr) strategy_ast -> strategy val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index ee28229cb7..4c1fe6417e 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -394,8 +394,13 @@ type appl = (* Values for interpretation *) type tacvalue = - | VFun of appl * Tacexpr.ltac_trace * Loc.t option * Val.t Id.Map.t * - Name.t list * Tacexpr.glob_tactic_expr + | VFun of + appl * + Tacexpr.ltac_trace * + Loc.t option * (* when executing a global Ltac function: the location where this function was called *) + Val.t Id.Map.t * (* closure *) + Name.t list * (* binders *) + Tacexpr.glob_tactic_expr (* body *) | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 6823b6411f..29e29044f1 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -33,7 +33,7 @@ type argument = Genarg.ArgT.any Extend.user_symbol let atactic n = if n = 5 then Pcoq.Symbol.nterm Pltac.binder_tactic - else Pcoq.Symbol.nterml Pltac.tactic_expr (string_of_int n) + else Pcoq.Symbol.nterml Pltac.ltac_expr (string_of_int n) type entry_name = EntryName : 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Pcoq.Symbol.t -> entry_name @@ -116,7 +116,7 @@ let get_tactic_entry n = else if Int.equal n 5 then Pltac.binder_tactic, None else if 1<=n && n<5 then - Pltac.tactic_expr, Some (Gramlib.Gramext.Level (string_of_int n)) + Pltac.ltac_expr, Some (Gramlib.Gramext.Level (string_of_int n)) else user_err Pp.(str ("Invalid Tactic Notation level: "^(string_of_int n)^".")) @@ -383,7 +383,7 @@ let add_ml_tactic_notation name ~level ?deprecation prods = in List.iteri iter (List.rev prods); (* We call [extend_atomic_tactic] only for "basic tactics" (the ones - at tactic_expr level 0) *) + at ltac_expr level 0) *) if Int.equal level 0 then extend_atomic_tactic name prods (**********************************************************************) @@ -420,7 +420,7 @@ let create_ltac_quotation name cast (e, l) = in let action _ v _ _ _ loc = cast (Some loc, v) in let gram = (level, assoc, [Pcoq.Production.make rule action]) in - Pcoq.grammar_extend Pltac.tactic_arg {pos=None; data=[gram]} + Pcoq.grammar_extend Pltac.tactic_value {pos=None; data=[gram]} (** Command *) @@ -528,16 +528,40 @@ let print_ltacs () = let locatable_ltac = "Ltac" +let split_ltac_fun = function + | Tacexpr.TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg n = spc () ++ Name.print n + +let print_ltac_body qid tac = + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid qid ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined + let () = let open Prettyp in - let locate qid = try Some (Tacenv.locate_tactic qid) with Not_found -> None in - let locate_all = Tacenv.locate_extended_all_tactic in - let shortest_qualid = Tacenv.shortest_qualid_of_tactic in - let name kn = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in - let print kn = - let qid = qualid_of_path (Tacenv.path_of_tactic kn) in - Tacintern.print_ltac qid - in + let locate qid = try Some (qid, Tacenv.locate_tactic qid) with Not_found -> None in + let locate_all qid = List.map (fun kn -> (qid,kn)) (Tacenv.locate_extended_all_tactic qid) in + let shortest_qualid (qid,kn) = Tacenv.shortest_qualid_of_tactic kn in + let name (qid,kn) = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in + let print (qid,kn) = + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + print_ltac_body qid tac in let about = name in register_locatable locatable_ltac { locate; @@ -551,14 +575,25 @@ let () = let print_located_tactic qid = Feedback.msg_notice (Prettyp.print_located_other locatable_ltac qid) +let print_ltac id = + try + let kn = Tacenv.locate_tactic id in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + print_ltac_body id tac + with + Not_found -> + user_err ~hdr:"print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") + (** Grammar *) let () = let entries = [ - AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.ltac_expr; AnyEntry Pltac.binder_tactic; AnyEntry Pltac.simple_tactic; - AnyEntry Pltac.tactic_arg; + AnyEntry Pltac.tactic_value; ] in register_grammars_by_name "tactic" entries diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index 6ee3ce091b..fc9ab54eba 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -69,6 +69,9 @@ val print_ltacs : unit -> unit val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +val print_ltac : Libnames.qualid -> Pp.t +(** Display the definition of a tactic. *) + (** {5 Low-level registering of tactics} *) type (_, 'a) ml_ty_sig = diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index eaedf8d9c1..7b2c8e1d04 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -108,7 +108,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 50767821e4..2382dcfbb9 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -107,7 +107,7 @@ type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr CAst.t list | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * - ('nam * 'dtrm intro_pattern_expr CAst.t option) option + ('nam * 'dtrm intro_pattern_expr CAst.t option) list | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option | TacCase of evars_flag * 'trm with_bindings_arg | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 9c3b05fdf1..8bee7afa2c 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -444,11 +444,11 @@ let intern_red_expr ist = function | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r -let intern_in_hyp_as ist lf (id,ipat) = - (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) - let intern_hyp_list ist = List.map (intern_hyp ist) +let intern_in_hyp_as ist lf (idl,ipat) = + (intern_hyp ist idl, Option.map (intern_intro_pattern lf ist) ipat) + let intern_inversion_strength lf ist = function | NonDepInversion (k,idl,ids) -> NonDepInversion (k,intern_hyp_list ist idl, @@ -527,7 +527,7 @@ let rec intern_atomic lf ist x = TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) | TacApply (a,ev,cb,inhyp) -> TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, - Option.map (intern_in_hyp_as ist lf) inhyp) + List.map (intern_in_hyp_as ist lf) inhyp) | TacElim (ev,cb,cbo) -> TacElim (ev,intern_constr_with_bindings_arg ist cb, Option.map (intern_constr_with_bindings ist) cbo) @@ -769,38 +769,6 @@ let glob_tactic_env l env x = (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars }) x -let split_ltac_fun = function - | TacFun (l,t) -> (l,t) - | t -> ([],t) - -let pr_ltac_fun_arg n = spc () ++ Name.print n - -let print_ltac id = - try - let kn = Tacenv.locate_tactic id in - let entries = Tacenv.ltac_entries () in - let tac = KNmap.find kn entries in - let filter mp = - try Some (Nametab.shortest_qualid_of_module mp) - with Not_found -> None - in - let mods = List.map_filter filter tac.Tacenv.tac_redef in - let redefined = match mods with - | [] -> mt () - | mods -> - let redef = prlist_with_sep fnl pr_qualid mods in - fnl () ++ str "Redefined by:" ++ fnl () ++ redef - in - let l,t = split_ltac_fun tac.Tacenv.tac_body in - hv 2 ( - hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ - prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") - ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined - with - Not_found -> - user_err ~hdr:"print_ltac" - (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") - (** Registering *) let lift intern = (); fun ist x -> (ist, intern ist x) @@ -831,6 +799,7 @@ let intern_ltac ist tac = let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_nat_or_var (lift intern_int_or_var); Genintern.register_intern0 wit_smart_global (lift intern_smart_global); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli index 22ec15566b..f779aa470c 100644 --- a/plugins/ltac/tacintern.mli +++ b/plugins/ltac/tacintern.mli @@ -55,9 +55,6 @@ val intern_hyp : glob_sign -> lident -> lident val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument -(** printing *) -val print_ltac : Libnames.qualid -> Pp.t - (** Reduction expressions *) val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 12bfb4d09e..f2241e78d2 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -153,11 +153,15 @@ let add_extra_loc loc extra = match loc with | None -> extra | Some loc -> TacStore.set extra f_loc loc -let add_loc loc ist = +let extract_loc ist = TacStore.get ist.extra f_loc + +let ensure_loc loc ist = match loc with | None -> ist - | Some loc -> { ist with extra = TacStore.set ist.extra f_loc loc } -let extract_loc ist = TacStore.get ist.extra f_loc + | Some loc -> + match extract_loc ist with + | None -> { ist with extra = TacStore.set ist.extra f_loc loc } + | Some _ -> ist let print_top_val env v = Pptactic.pr_value Pptactic.ltop v @@ -769,7 +773,7 @@ let interp_may_eval f ist env sigma = function function already use effect, I call [run] hoping it doesn't mess up with any assumption. *) Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> - str"interpretation of term " ++ pr_glob_constr_env env (fst c))); + str"interpretation of term " ++ pr_glob_constr_env env sigma (fst c))); Exninfo.iraise reraise (* Interprets a constr expression possibly to first evaluate *) @@ -1175,7 +1179,7 @@ and eval_tactic_ist ist tac : unit Proofview.tactic = match tac with | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg {CAst.loc} -> Ftactic.run (val_interp (add_loc loc ist) tac) (fun v -> tactic_of_value ist v) + | TacArg {CAst.loc} -> Ftactic.run (val_interp (ensure_loc loc ist) tac) (fun v -> tactic_of_value ist v) | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> @@ -1254,9 +1258,12 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in + (* We call a global ltac reference: add a loc on its executation only if not + already in another global reference *) + let ist = ensure_loc loc ist in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false - (catch_error_tac_loc (* interp *) loc false trace - (val_interp ~appl (add_loc (* exec *) loc ist) (Tacenv.interp_ltac r))) + (catch_error_tac_loc (* loc for interpretation *) loc false trace + (val_interp ~appl ist (Tacenv.interp_ltac r))) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1325,7 +1332,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac_loc loc false trace (val_interp (add_loc loc ist) body)) >>= fun v -> + (catch_error_tac_loc loc false trace (val_interp (ensure_loc loc ist) body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1660,10 +1667,10 @@ and interp_atomic ist tac : unit Proofview.tactic = (k,(make ?loc f))) cb in let sigma,tac = match cl with - | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l - | Some cl -> - let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in - sigma, Tactics.apply_delayed_in a ev id l cl in + | [] -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | cl -> + let sigma,cl = List.fold_left_map (interp_in_hyp_as ist env) sigma cl in + sigma, List.fold_right (fun (id,ipat) -> Tactics.apply_delayed_in a ev id l ipat) cl Tacticals.New.tclIDTAC in Tacticals.New.tclWITHHOLES ev tac sigma end end @@ -1997,7 +2004,7 @@ let interp_tac_gen lfun avoid_ids debug t = let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t (* MUST be marshallable! *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } @@ -2019,7 +2026,7 @@ let hide_interp {global;ast} = hide_interp (Proofview.Goal.env gl) end -let hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp +let ComTactic.Interpreter hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp (***************************************************************************) (** Register standard arguments *) @@ -2092,6 +2099,7 @@ let interp_pre_ident ist env sigma s = let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_nat_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); register_interp0 wit_smart_global (lift interp_reference); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_pre_ident (lift interp_pre_ident); diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index 01d7306c9d..a74f4592f7 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -77,6 +77,9 @@ val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tac val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic (** Interprets redexp arguments *) +val interp_red_expr : interp_sign -> Environ.env -> Evd.evar_map -> glob_red_expr -> Evd.evar_map * red_expr + +(** Interprets redexp arguments from a raw one *) val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr (** Interprets tactic expressions *) @@ -126,12 +129,12 @@ val interp_tac_gen : value Id.Map.t -> Id.Set.t -> val interp : raw_tactic_expr -> unit Proofview.tactic (** Hides interpretation for pretty-print *) -type tactic_expr = { +type ltac_expr = { global: bool; ast: Tacexpr.raw_tactic_expr; } -val hide_interp : tactic_expr ComTactic.tactic_interpreter +val hide_interp : ltac_expr -> ComTactic.interpretable (** Internals that can be useful for syntax extensions. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index ec44ae4698..90546ea939 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -128,7 +128,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) | TacApply (a,ev,cb,cl) -> - TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb, + List.map (on_snd (Option.map (subst_intro_pattern subst))) cl) | TacElim (ev,cb,cbo) -> TacElim (ev,subst_glob_with_bindings_arg subst cb, Option.map (subst_glob_with_bindings subst) cbo) @@ -278,6 +279,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_nat_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; Genintern.register_subst0 wit_smart_global subst_global_reference; Genintern.register_subst0 wit_pre_ident (fun _ v -> v); diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 5fbea4eeef..c4c528d373 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -16,11 +16,12 @@ open Tacexpr let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () let prtac x = - Pptactic.pr_glob_tactic (Global.env()) x + let env = Global.env () in + Pptactic.pr_glob_tactic env x let prmatchpatt env sigma hyp = Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp let prmatchrl env sigma rl = - Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) + Pptactic.pr_match_rule false prtac (fun (_,p) -> Printer.pr_constr_pattern_env env sigma p) rl (* This module intends to be a beginning of debugger for tactic expressions. @@ -366,24 +367,22 @@ let explain_ltac_call_trace last trace loc = | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Tacexpr.LtacMLCall t -> - quote (Pptactic.pr_glob_tactic (Global.env()) t) + quote (prtac t) | Tacexpr.LtacVarCall (id,t) -> quote (Id.print id) ++ strbrk " (bound to " ++ - Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + prtac t ++ str ")" | Tacexpr.LtacAtomCall te -> - quote (Pptactic.pr_glob_tactic (Global.env()) - (Tacexpr.TacAtom (CAst.make te))) + quote (prtac (Tacexpr.TacAtom (CAst.make te))) | Tacexpr.LtacConstrInterp (c, { Ltac_pretype.ltac_constrs = vars }) -> - quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (* XXX: This hooks into the CErrors's additional error info API so + it is tricky to provide the right env for now. *) + let env = Global.env() in + let sigma = Evd.from_env env in + quote (Printer.pr_glob_constr_env env sigma c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ prlist_with_sep pr_comma (fun (id,c) -> - (* XXX: This hooks into the CErrors's additional error - info API so it is tricky to provide the right env for - now. *) - let env = Global.env () in - let sigma = Evd.from_env env in Id.print id ++ str ":=" ++ Printer.pr_lconstr_under_binders_env env sigma c) (List.rev (Id.Map.bindings vars)) ++ str ")" else mt()) diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9008691bca..74d5374193 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -385,6 +385,16 @@ let subst sys = sys'; sys' +let tr_sys str f sys = + let sys' = f sys in + if debug then ( + Printf.fprintf stdout "[%s\n" str; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; + Printf.fprintf stdout "\n => \n"; + List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; + Printf.fprintf stdout "]\n" ); + sys' + (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. For integers, the obtained constraints are sound but not complete. @@ -392,11 +402,7 @@ let subst sys = let saturate_by_linear_equalities sys0 = WithProof.saturate_subst false sys0 let saturate_by_linear_equalities sys = - let sys' = saturate_by_linear_equalities sys in - if debug then - Printf.fprintf stdout "[saturate_by_linear_equalities:\n%a\n==>\n%a\n]" - output_sys sys output_sys sys'; - sys' + tr_sys "saturate_by_linear_equalities" saturate_by_linear_equalities sys let bound_monomials (sys : WithProof.t list) = let l = @@ -497,10 +503,10 @@ let nlinear_prover prfdepth sys = 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)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in - let env = CList.interval 0 id in + let env = List.map (fun i -> ProofFormat.Hyp i) (CList.interval 0 id) in match linear_prover_cstr sys with | None -> Unknown | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q env cert) @@ -514,7 +520,7 @@ let linear_prover_with_cert prfdepth sys = | Some cert -> Prf (ProofFormat.cmpl_prf_rule Mc.normQ CamlToCoq.q - (List.mapi (fun i e -> i) sys) + (List.mapi (fun i e -> ProofFormat.Hyp i) sys) cert) (* The prover is (probably) incomplete -- @@ -885,6 +891,11 @@ let check_sys sys = open ProofFormat +let output_cstr_sys sys = + (pp_list ";" (fun o (c, wp) -> + Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) + sys + let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -922,16 +933,10 @@ let xlia (can_enum : bool) reduction_equations sys = | _ -> Unknown ) and aux_lia (id : int) (sys : prf_sys) = assert (check_sys sys); - if debug then - Printf.printf "xlia: %a \n" - (pp_list ";" (fun o (c, _) -> output_cstr o c)) - sys; + if debug then Printf.printf "xlia: %a \n" output_cstr_sys 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; + if debug then Printf.printf "after reduction: %a \n" output_cstr_sys sys; match linear_prover_cstr sys with | Some prf -> Prf (Step (id, prf, Done)) | None -> if can_enum then enum_proof id sys else Unknown @@ -943,7 +948,7 @@ let xlia (can_enum : bool) reduction_equations sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let orpf = @@ -973,7 +978,7 @@ let xlia_simplex env red sys = let id = 1 + List.fold_left - (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_id r)) + (fun acc (_, r) -> max acc (ProofFormat.pr_rule_max_hyp r)) 0 sys in let env = CList.interval 0 (id - 1) in @@ -1007,6 +1012,128 @@ let gen_bench (tac, prover) can_enum prfdepth sys = flush o; close_out o ); res +let normalise sys = + List.fold_left + (fun acc s -> + match WithProof.cutting_plane s with + | None -> s :: acc + | Some s' -> s' :: acc) + [] sys + +let normalise = tr_sys "normalise" normalise + +let elim_redundant sys = + let module VectMap = Map.Make (Vect) in + let elim_eq sys = + List.fold_left + (fun acc (((v, o), prf) as wp) -> + match o with + | Gt -> assert false + | Ge -> wp :: acc + | Eq -> wp :: WithProof.neg wp :: acc) + [] sys + in + let of_list l = + List.fold_left + (fun m (((v, o), prf) as wp) -> + let q, v' = Vect.decomp_cst v in + try + let q', wp' = VectMap.find v' m in + match Q.compare q q' with + | 0 -> if o = Eq then VectMap.add v' (q, wp) m else m + | 1 -> m + | _ -> VectMap.add v' (q, wp) m + with Not_found -> VectMap.add v' (q, wp) m) + VectMap.empty l + in + let to_list m = VectMap.fold (fun _ (_, wp) sys -> wp :: sys) m [] in + to_list (of_list (elim_eq sys)) + +let elim_redundant sys = tr_sys "elim_redundant" elim_redundant sys + +(** [fourier_small] performs some variable elimination and keeps the cutting planes. + To decide which elimination to perform, the constraints are sorted according to + 1 - the number of variables + 2 - the value of the smallest coefficient + Given the smallest constraint, we eliminate the variable with the smallest coefficient. + The rational is that a constraint with a single variable provides some bound information. + When there are several variables, we hope to eliminate all the variables. + A necessary condition is to take the variable with the smallest coefficient *) + +let fourier_small (sys : WithProof.t list) = + let gen_pivot acc (q, x) wp l = + List.fold_left + (fun acc (s, wp') -> + match WithProof.simple_pivot (q, x) wp wp' with + | None -> acc + | Some wp2 -> ( + match WithProof.cutting_plane wp2 with + | Some wp2 -> (s, wp2) :: acc + | _ -> acc )) + acc l + in + let rec all_pivots acc l = + match l with + | [] -> acc + | ((_, qx), wp) :: l' -> all_pivots (gen_pivot acc qx wp (acc @ l')) l' + in + List.rev_map snd (all_pivots [] (WithProof.sort sys)) + +let fourier_small = tr_sys "fourier_small" fourier_small + +(** [propagate_bounds sys] generate new constraints by exploiting bounds. + A bound is a constraint of the form c + a.x >= 0 + *) + +(*let propagate_bounds sys = + let bounds, sys' = + List.fold_left + (fun (b, r) (((c, o), prf) as wp) -> + match Vect.Bound.of_vect c with + | None -> (b, wp :: r) + | Some b' -> ((b', wp) :: b, r)) + ([], []) sys + in + let exploit_bound acc (b, wp) = + let cf = b.Vect.Bound.coeff in + let vr = b.Vect.Bound.var in + List.fold_left + (fun acc (((c, o), prf) as wp') -> + let cf' = Vect.get vr c in + if Q.sign (cf */ cf') = -1 then + WithProof.( + let wf2 = + addition + (mult (LinPoly.constant (Q.abs cf')) wp) + (mult (LinPoly.constant (Q.abs cf)) wp') + in + match cutting_plane wf2 with None -> acc | Some cp -> cp :: acc) + else acc) + acc sys' + in + List.fold_left exploit_bound [] bounds + *) + +let rev_concat l = + let rec conc acc l = + match l with [] -> acc | l1 :: lr -> conc (List.rev_append l1 acc) lr + in + conc [] l + +let pre_process sys = + let sys = normalise sys in + let bnd1 = bound_monomials sys in + let sys1 = normalise (subst sys) in + let pbnd1 = fourier_small sys1 in + let sys2 = elim_redundant (List.rev_append pbnd1 sys1) in + let bnd2 = bound_monomials sys2 in + let pbnd2 = [] (*fourier_small sys2*) in + (* Should iterate ? *) + let sys = + rev_concat [pbnd2; bnd1; bnd2; saturate_by_linear_equalities sys2; sys2] + in + sys + let lia (can_enum : bool) (prfdepth : int) sys = let sys = develop_constraints prfdepth z_spec sys in if debug then begin @@ -1020,11 +1147,7 @@ let lia (can_enum : bool) (prfdepth : int) sys = p) sys end; - let bnd1 = bound_monomials sys in - let sys = subst sys in - let bnd2 = bound_monomials sys in - (* To deal with non-linear monomials *) - let sys = bnd1 @ bnd2 @ saturate_by_linear_equalities sys @ sys in + let sys = pre_process sys in let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' @@ -1039,7 +1162,8 @@ let nlia enum prfdepth sys = 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) + xlia (List.map fst sys) enum reduction_equations + (make_cstr_system (pre_process sys)) else (* let sys1 = elim_every_substitution sys in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 542b99075d..e119ceb241 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -12,7 +12,7 @@ (* *) (* ** Toplevel definition of tactics ** *) (* *) -(* - Modules M, Mc, Env, Cache, CacheZ *) +(* - Modules Mc, Env, Cache, CacheZ *) (* *) (* Frédéric Besson (Irisa/Inria) 2006-2019 *) (* *) @@ -197,6 +197,7 @@ let coq_proofTerm = lazy (constr_of_ref "micromega.ZArithProof.type") let coq_doneProof = lazy (constr_of_ref "micromega.ZArithProof.DoneProof") let coq_ratProof = lazy (constr_of_ref "micromega.ZArithProof.RatProof") let coq_cutProof = lazy (constr_of_ref "micromega.ZArithProof.CutProof") +let coq_splitProof = lazy (constr_of_ref "micromega.ZArithProof.SplitProof") let coq_enumProof = lazy (constr_of_ref "micromega.ZArithProof.EnumProof") let coq_ExProof = lazy (constr_of_ref "micromega.ZArithProof.ExProof") let coq_IsProp = lazy (constr_of_ref "micromega.kind.isProp") @@ -1341,6 +1342,12 @@ let rec dump_proof_term = function EConstr.mkApp ( Lazy.force coq_cutProof , [|dump_psatz coq_Z dump_z cone; dump_proof_term prf|] ) + | Micromega.SplitProof (p, prf1, prf2) -> + EConstr.mkApp + ( Lazy.force coq_splitProof + , [| dump_pol (Lazy.force coq_Z) dump_z p + ; dump_proof_term prf1 + ; dump_proof_term prf2 |] ) | Micromega.EnumProof (c1, c2, prfs) -> EConstr.mkApp ( Lazy.force coq_enumProof @@ -1364,6 +1371,7 @@ let rec size_of_pf = function | Micromega.DoneProof -> 1 | Micromega.RatProof (p, a) -> size_of_pf a + size_of_psatz p | Micromega.CutProof (p, a) -> size_of_pf a + size_of_psatz p + | Micromega.SplitProof (_, p1, p2) -> size_of_pf p1 + size_of_pf p2 | Micromega.EnumProof (p1, p2, l) -> size_of_psatz p1 + size_of_psatz p2 + List.fold_left (fun acc p -> size_of_pf p + acc) 0 l @@ -1382,6 +1390,9 @@ let rec pp_proof_term o = function Printf.fprintf o "R[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst | Micromega.CutProof (cone, rst) -> Printf.fprintf o "C[%a,%a]" (pp_psatz pp_z) cone pp_proof_term rst + | Micromega.SplitProof (p, p1, p2) -> + Printf.fprintf o "S[%a,%a,%a]" (pp_pol pp_z) p pp_proof_term p1 + pp_proof_term p2 | Micromega.EnumProof (c1, c2, rst) -> Printf.fprintf o "EP[%a,%a,%a]" (pp_psatz pp_z) c1 (pp_psatz pp_z) c2 (pp_list "[" "]" pp_proof_term) @@ -2064,7 +2075,11 @@ module MakeCache (T : sig val hash_coeff : int -> coeff -> int val eq_prover_option : prover_option -> prover_option -> bool val eq_coeff : coeff -> coeff -> bool -end) = +end) : +sig + type key = T.prover_option * (T.coeff Mc.pol * Mc.op1) list + val memo_opt : (unit -> bool) -> string -> (key -> 'a) -> key -> 'a +end = struct module E = struct type t = T.prover_option * (T.coeff Mc.pol * Mc.op1) list @@ -2196,6 +2211,7 @@ let hyps_of_pt pt = | Mc.DoneProof -> acc | Mc.RatProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) | Mc.CutProof (c, pt) -> xhyps (base + 1) pt (xhyps_of_cone base acc c) + | Mc.SplitProof (p, p1, p2) -> xhyps (base + 1) p1 (xhyps (base + 1) p2 acc) | Mc.EnumProof (c1, c2, l) -> let s = xhyps_of_cone base (xhyps_of_cone base acc c2) c1 in List.fold_left (fun s x -> xhyps (base + 1) x s) s l @@ -2212,6 +2228,8 @@ let compact_pt pt f = Mc.RatProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) | Mc.CutProof (c, pt) -> Mc.CutProof (compact_cone c (translate ofset), compact_pt (ofset + 1) pt) + | Mc.SplitProof (p, p1, p2) -> + Mc.SplitProof (p, compact_pt (ofset + 1) p1, compact_pt (ofset + 1) p2) | Mc.EnumProof (c1, c2, l) -> Mc.EnumProof ( compact_cone c1 (translate ofset) diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index 40eea91b31..852a485329 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -29,7 +29,7 @@ open Tacarg DECLARE PLUGIN "micromega_plugin" TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i +| [ "psatz_Z" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Z" tactic(t)] -> { (Coq_micromega.psatz_Z (-1)) (Tacinterp.tactic_of_value ist t) } @@ -74,12 +74,12 @@ TACTIC EXTEND LRA_R END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_R" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_R i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_R" tactic(t) ] -> { (Coq_micromega.psatz_R (-1) (Tacinterp.tactic_of_value ist t)) } END TACTIC EXTEND PsatzQ -| [ "psatz_Q" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } +| [ "psatz_Q" nat_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Q i (Tacinterp.tactic_of_value ist t)) } | [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } END diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index b231779c7b..57de80bd24 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1384,11 +1384,13 @@ let rxcnf_or unsat deduce rXCNF polarity k e1 e2 = let rxcnf_impl unsat deduce rXCNF polarity k e1 e2 = let e3,t1 = rXCNF (negb polarity) k e1 in if polarity - then if is_cnf_ff e3 - then rXCNF polarity k e2 - else let e4,t2 = rXCNF polarity k e2 in - let f',t' = ror_cnf_opt unsat deduce e3 e4 in - f',(rev_append t1 (rev_append t2 t')) + then if is_cnf_tt e3 + then e3,t1 + else if is_cnf_ff e3 + then rXCNF polarity k e2 + else let e4,t2 = rXCNF polarity k e2 in + let f',t' = ror_cnf_opt unsat deduce e3 e4 in + f',(rev_append t1 (rev_append t2 t')) else let e4,t2 = rXCNF polarity k e2 in (and_cnf_opt e3 e4),(rev_append t1 t2) @@ -2140,6 +2142,11 @@ let zWeakChecker = let psub1 = psub0 Z0 Z.add Z.sub Z.opp zeq_bool +(** val popp1 : z pol -> z pol **) + +let popp1 = + popp0 Z.opp + (** val padd1 : z pol -> z pol -> z pol **) let padd1 = @@ -2233,6 +2240,7 @@ type zArithProof = | DoneProof | RatProof of zWitness * zArithProof | CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof | EnumProof of zWitness * zWitness * zArithProof list | ExProof of positive * zArithProof @@ -2344,6 +2352,15 @@ let rec zChecker l = function | Some cp -> zChecker ((nformula_of_cutting_plane cp)::l) pf0 | None -> true) | None -> false) +| SplitProof (p, pf1, pf2) -> + (match genCuttingPlane (p,NonStrict) with + | Some cp1 -> + (match genCuttingPlane ((popp1 p),NonStrict) with + | Some cp2 -> + (&&) (zChecker ((nformula_of_cutting_plane cp1)::l) pf1) + (zChecker ((nformula_of_cutting_plane cp2)::l) pf2) + | None -> false) + | None -> false) | EnumProof (w1, w2, pf0) -> (match eval_Psatz0 l w1 with | Some f1 -> diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index 53f62e0f5b..f75d8880c6 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,942 +1,740 @@ + type __ = Obj.t -type unit0 = Tt + +type unit0 = +| Tt val negb : bool -> bool -type nat = O | S of nat -type ('a, 'b) sum = Inl of 'a | Inr of 'b +type nat = +| O +| S of nat + +type ('a, 'b) sum = +| Inl of 'a +| Inr of 'b + +val fst : ('a1 * 'a2) -> 'a1 + +val snd : ('a1 * 'a2) -> 'a2 -val fst : 'a1 * 'a2 -> 'a1 -val snd : 'a1 * 'a2 -> 'a2 val app : 'a1 list -> 'a1 list -> 'a1 list -type comparison = Eq | Lt | Gt +type comparison = +| Eq +| Lt +| Gt val compOpp : comparison -> comparison + val add : nat -> nat -> nat + val nth : nat -> 'a1 list -> 'a1 -> 'a1 + val rev_append : 'a1 list -> 'a1 list -> 'a1 list + val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list -val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -type positive = XI of positive | XO of positive | XH -type n = N0 | Npos of positive -type z = Z0 | Zpos of positive | Zneg of positive +val fold_left : ('a1 -> 'a2 -> 'a1) -> 'a2 list -> 'a1 -> 'a1 -module Pos : sig - type mask = IsNul | IsPos of positive | IsNeg -end +val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -module Coq_Pos : sig +type positive = +| XI of positive +| XO of positive +| XH + +type n = +| N0 +| Npos of positive + +type z = +| Z0 +| Zpos of positive +| Zneg of positive + +module Pos : + sig + type mask = + | IsNul + | IsPos of positive + | IsNeg + end + +module Coq_Pos : + sig val succ : positive -> positive + val add : positive -> positive -> positive + val add_carry : positive -> positive -> positive + val pred_double : positive -> positive - type mask = Pos.mask = IsNul | IsPos of positive | IsNeg + type mask = Pos.mask = + | IsNul + | IsPos of positive + | IsNeg val succ_double_mask : mask -> mask + val double_mask : mask -> mask + val double_pred_mask : positive -> mask + val sub_mask : positive -> positive -> mask + val sub_mask_carry : positive -> positive -> mask + val sub : positive -> positive -> positive + val mul : positive -> positive -> positive + val iter : ('a1 -> 'a1) -> 'a1 -> positive -> 'a1 + val size_nat : positive -> nat + val compare_cont : comparison -> positive -> positive -> comparison + val compare : positive -> positive -> comparison + val max : positive -> positive -> positive + val leb : positive -> positive -> bool + val gcdn : nat -> positive -> positive -> positive + val gcd : positive -> positive -> positive + val of_succ_nat : nat -> positive -end + end -module N : sig +module N : + sig val of_nat : nat -> n -end + end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 -module Z : sig +module Z : + sig val double : z -> z + val succ_double : z -> z + val pred_double : z -> z + val pos_sub : positive -> positive -> z + val add : z -> z -> z + val opp : z -> z + val sub : z -> z -> z + val mul : z -> z -> z + val pow_pos : z -> positive -> z + val pow : z -> z -> z + val compare : z -> z -> comparison + val leb : z -> z -> bool + val ltb : z -> z -> bool + val gtb : z -> z -> bool + val max : z -> z -> z + val abs : z -> z + val to_N : z -> n + val of_nat : nat -> z + val of_N : n -> z + val pos_div_eucl : positive -> z -> z * z + val div_eucl : z -> z -> z * z + val div : z -> z -> z + val gcd : z -> z -> z -end + end val zeq_bool : z -> z -> bool type 'c pExpr = - | PEc of 'c - | PEX of positive - | PEadd of 'c pExpr * 'c pExpr - | PEsub of 'c pExpr * 'c pExpr - | PEmul of 'c pExpr * 'c pExpr - | PEopp of 'c pExpr - | PEpow of 'c pExpr * n +| PEc of 'c +| PEX of positive +| PEadd of 'c pExpr * 'c pExpr +| PEsub of 'c pExpr * 'c pExpr +| PEmul of 'c pExpr * 'c pExpr +| PEopp of 'c pExpr +| PEpow of 'c pExpr * n type 'c pol = - | Pc of 'c - | Pinj of positive * 'c pol - | PX of 'c pol * positive * 'c pol +| Pc of 'c +| Pinj of positive * 'c pol +| PX of 'c pol * positive * 'c pol val p0 : 'a1 -> 'a1 pol + val p1 : 'a1 -> 'a1 pol + val peq : ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol -> bool + 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 + val mkX : 'a1 -> 'a1 -> 'a1 pol + val popp : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol + 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 + ('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 + ('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 -> ('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 + '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 + '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 + '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 + '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 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol 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 + '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 kind = IsProp | IsBool +type kind = +| IsProp +| IsBool type ('tA, 'tX, 'aA, 'aF) gFormula = - | TT of kind - | FF of kind - | X of kind * 'tX - | A of kind * 'tA * 'aA - | AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula - | IMPL of - kind - * ('tA, 'tX, 'aA, 'aF) gFormula - * 'aF option - * ('tA, 'tX, 'aA, 'aF) gFormula - | IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula - | EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| TT of kind +| FF of kind +| X of kind * 'tX +| A of kind * 'tA * 'aA +| AND of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| OR of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| NOT of kind * ('tA, 'tX, 'aA, 'aF) gFormula +| IMPL of kind * ('tA, 'tX, 'aA, 'aF) gFormula * 'aF option * ('tA, 'tX, 'aA, 'aF) gFormula +| IFF of kind * ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula +| EQ of ('tA, 'tX, 'aA, 'aF) gFormula * ('tA, 'tX, 'aA, 'aF) gFormula val mapX : - (kind -> 'a2 -> 'a2) - -> kind - -> ('a1, 'a2, 'a3, 'a4) gFormula - -> ('a1, 'a2, 'a3, 'a4) gFormula + (kind -> 'a2 -> 'a2) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> ('a1, 'a2, 'a3, 'a4) gFormula -val foldA : - ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 +val foldA : ('a5 -> 'a3 -> 'a5) -> kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a5 -> 'a5 val cons_id : 'a1 option -> 'a1 list -> 'a1 list + val ids_of_formula : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a4 list + val collect_annot : kind -> ('a1, 'a2, 'a3, 'a4) gFormula -> 'a3 list type rtyp = __ + type eKind = __ + type 'a bFormula = ('a, eKind, unit0, unit0) gFormula val map_bformula : - kind - -> ('a1 -> 'a2) - -> ('a1, 'a3, 'a4, 'a5) gFormula - -> ('a2, 'a3, 'a4, 'a5) gFormula + kind -> ('a1 -> 'a2) -> ('a1, 'a3, 'a4, 'a5) gFormula -> ('a2, 'a3, 'a4, 'a5) gFormula type ('x, 'annot) clause = ('x * 'annot) list + type ('x, 'annot) cnf = ('x, 'annot) clause list val cnf_tt : ('a1, 'a2) cnf + val cnf_ff : ('a1, 'a2) cnf val add_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> ('a1, 'a2) + clause option val or_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause - -> ('a1, 'a2) clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) clause -> ('a1, + 'a2) clause option val xor_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf val or_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val and_cnf : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf type ('term, 'annot, 'tX, 'aF) tFormula = ('term, 'tX, 'annot, 'aF) gFormula val is_cnf_tt : ('a1, 'a2) cnf -> bool + val is_cnf_ff : ('a1, 'a2) cnf -> bool + val and_cnf_opt : ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val or_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf val mk_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val mk_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf) - -> kind - -> bool - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf) -> kind -> bool -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val is_bool : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool option val xcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf val radd_term : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> 'a1 * 'a2 - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) -> ('a1, 'a2) clause -> (('a1, 'a2) + clause, 'a2 list) sum val ror_clause : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause - -> (('a1, 'a2) clause, 'a2 list) sum + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause -> (('a1, + 'a2) clause, 'a2 list) sum val xror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_clause_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1 * 'a2) list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1 * 'a2) list -> ('a1, 'a2) clause list -> ('a1, + 'a2) clause list * 'a2 list val ror_cnf : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) clause list - -> ('a1, 'a2) clause list - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) clause list -> ('a1, 'a2) clause list -> + ('a1, 'a2) cnf * 'a2 list val ror_cnf_opt : - ('a1 -> bool) - -> ('a1 -> 'a1 -> 'a1 option) - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf - -> ('a1, 'a2) cnf * 'a2 list + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> ('a1, 'a2) cnf -> ('a1, 'a2) cnf -> ('a1, 'a2) + cnf * 'a2 list val ratom : ('a1, 'a2) cnf -> 'a2 -> ('a1, 'a2) cnf * 'a2 list val rxcnf_and : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_or : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_impl : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf_iff : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ( bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> (bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> + ('a2, 'a3) cnf * 'a3 list) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a1, 'a3, 'a4, + 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list val rxcnf : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> bool - -> kind - -> ('a1, 'a3, 'a4, 'a5) tFormula - -> ('a2, 'a3) cnf * 'a3 list - -type ('term, 'annot, 'tX) to_constrT = - { mkTT : kind -> 'tX - ; mkFF : kind -> 'tX - ; mkA : kind -> 'term -> 'annot -> 'tX - ; mkAND : kind -> 'tX -> 'tX -> 'tX - ; mkOR : kind -> 'tX -> 'tX -> 'tX - ; mkIMPL : kind -> 'tX -> 'tX -> 'tX - ; mkIFF : kind -> 'tX -> 'tX -> 'tX - ; mkNOT : kind -> 'tX -> 'tX - ; mkEQ : 'tX -> 'tX -> 'tX } - -val aformula : - ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> bool -> kind -> ('a1, 'a3, 'a4, 'a5) tFormula -> ('a2, 'a3) cnf * 'a3 list + +type ('term, 'annot, 'tX) to_constrT = { mkTT : (kind -> 'tX); mkFF : (kind -> 'tX); + mkA : (kind -> 'term -> 'annot -> 'tX); + mkAND : (kind -> 'tX -> 'tX -> 'tX); + mkOR : (kind -> 'tX -> 'tX -> 'tX); + mkIMPL : (kind -> 'tX -> 'tX -> 'tX); + mkIFF : (kind -> 'tX -> 'tX -> 'tX); + mkNOT : (kind -> 'tX -> 'tX); mkEQ : ('tX -> 'tX -> 'tX) } + +val aformula : ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 val is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> 'a3 option val abs_and : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_or : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ( kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val abs_not : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> (kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> ('a1, 'a3, 'a2, 'a4) gFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> (kind -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula) -> ('a1, 'a3, 'a2, 'a4) gFormula val mk_arrow : - 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_simpl : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, + 'a3, 'a4) tFormula val abst_and : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_or : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_impl : - ('a1, 'a2, 'a3) to_constrT - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> 'a4 option - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula) -> bool -> 'a4 option -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -val or_is_X : - kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool +val or_is_X : kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> bool val abs_iff : - ('a1, 'a2, 'a3) to_constrT - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula -> kind -> ('a1, 'a2, + 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_iff : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, + 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_eq : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> ( bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula) - -> bool - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> (bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula) -> bool -> ('a1, 'a2, 'a3, 'a4) tFormula -> ('a1, 'a2, 'a3, 'a4) + tFormula -> ('a1, 'a2, 'a3, 'a4) tFormula val abst_form : - ('a1, 'a2, 'a3) to_constrT - -> ('a2 -> bool) - -> bool - -> kind - -> ('a1, 'a2, 'a3, 'a4) tFormula - -> ('a1, 'a2, 'a3, 'a4) tFormula + ('a1, 'a2, 'a3) to_constrT -> ('a2 -> bool) -> bool -> kind -> ('a1, 'a2, 'a3, 'a4) tFormula -> + ('a1, 'a2, 'a3, 'a4) tFormula -val cnf_checker : - (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool +val cnf_checker : (('a1 * 'a2) list -> 'a3 -> bool) -> ('a1, 'a2) cnf -> 'a3 list -> bool val tauto_checker : - ('a2 -> bool) - -> ('a2 -> 'a2 -> 'a2 option) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) - -> (('a2 * 'a3) list -> 'a4 -> bool) - -> ('a1, rtyp, 'a3, unit0) gFormula - -> 'a4 list - -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a3 -> ('a2, 'a3) cnf) -> ('a1 -> 'a3 -> + ('a2, 'a3) cnf) -> (('a2 * 'a3) list -> 'a4 -> bool) -> ('a1, rtyp, 'a3, unit0) gFormula -> 'a4 + list -> bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool + val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol -type op1 = Equal | NonEqual | Strict | NonStrict + +type op1 = +| Equal +| NonEqual +| Strict +| NonStrict + type 'c nFormula = 'c polC * op1 val opMult : op1 -> op1 -> op1 option + val opAdd : op1 -> op1 -> op1 option type 'c psatz = - | PsatzIn of nat - | PsatzSquare of 'c polC - | PsatzMulC of 'c polC * 'c psatz - | PsatzMulE of 'c psatz * 'c psatz - | PsatzAdd of 'c psatz * 'c psatz - | PsatzC of 'c - | PsatzZ +| PsatzIn of nat +| PsatzSquare of 'c polC +| PsatzMulC of 'c polC * 'c psatz +| PsatzMulE of 'c psatz * 'c psatz +| PsatzAdd of 'c psatz * 'c psatz +| PsatzC of 'c +| PsatzZ 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 + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> 'a1 nFormula -> 'a1 nFormula + option val eval_Psatz : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> 'a1 nFormula option - -val check_inconsistent : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> bool + '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_normalised_formulas : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a1 psatz - -> bool - -type op2 = OpEq | OpNEq | OpLe | OpGe | OpLt | OpGt -type 't formula = {flhs : 't pExpr; fop : op2; frhs : 't pExpr} + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> + bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + +type op2 = +| OpEq +| OpNEq +| OpLe +| OpGe +| OpLt +| OpGt + +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 + '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 popp0 : ('a1 -> 'a1) -> 'a1 pol -> 'a1 pol val normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a1 nFormula + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula val xnormalise : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list + val xnegate : ('a1 -> 'a1) -> 'a1 nFormula -> 'a1 nFormula list val cnf_of_list : - 'a1 - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 nFormula list - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a2 -> ('a1 nFormula, + 'a2) cnf val cnf_normalise : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val cnf_negate : - 'a1 - -> 'a1 - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1 -> 'a1) - -> ('a1 -> 'a1) - -> ('a1 -> 'a1 -> bool) - -> ('a1 -> 'a1 -> bool) - -> 'a1 formula - -> 'a2 - -> ('a1 nFormula, 'a2) cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1) -> + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a2 -> ('a1 nFormula, 'a2) cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr + val denorm : 'a1 pol -> 'a1 pExpr + 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} +type q = { qnum : z; qden : positive } val qeq_bool : q -> q -> bool + val qle_bool : q -> q -> bool + val qplus : q -> q -> q + val qmult : q -> q -> q + val qopp : q -> q + val qminus : q -> q -> q + val qinv : q -> q + val qpower_positive : q -> positive -> q + val qpower : q -> z -> q -type 'a t = Empty | Elt of 'a | Branch of 'a t * 'a * 'a t +type 'a t = +| Empty +| Elt of 'a +| Branch of 'a t * 'a * 'a t val find : 'a1 -> 'a1 t -> positive -> 'a1 + val singleton : 'a1 -> positive -> 'a1 -> 'a1 t + val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t + val zeval_const : z pExpr -> z option type zWitness = z psatz val zWeakChecker : z nFormula list -> z psatz -> bool + val psub1 : z pol -> z pol -> z pol + +val popp1 : z pol -> z pol + val padd1 : z pol -> z pol -> z pol + val normZ : z pExpr -> z pol + val zunsat : z nFormula -> bool + val zdeduce : z nFormula -> z nFormula -> z nFormula option + val xnnormalise : z formula -> z nFormula + val xnormalise0 : z nFormula -> z nFormula list + val cnf_of_list0 : 'a1 -> z nFormula list -> (z nFormula * 'a1) list list + val normalise0 : z formula -> 'a1 -> (z nFormula, 'a1) cnf + val xnegate0 : z nFormula -> z nFormula list + val negate : z formula -> 'a1 -> (z nFormula, 'a1) cnf -val cnfZ : - kind - -> (z formula, 'a1, 'a2, 'a3) tFormula - -> (z nFormula, 'a1) cnf * 'a1 list +val cnfZ : kind -> (z formula, 'a1, 'a2, 'a3) tFormula -> (z nFormula, 'a1) cnf * 'a1 list val ceiling : z -> z -> z type zArithProof = - | DoneProof - | RatProof of zWitness * zArithProof - | CutProof of zWitness * zArithProof - | EnumProof of zWitness * zWitness * zArithProof list - | ExProof of positive * zArithProof +| DoneProof +| RatProof of zWitness * zArithProof +| CutProof of zWitness * zArithProof +| SplitProof of z polC * zArithProof * zArithProof +| EnumProof of zWitness * zWitness * zArithProof list +| ExProof of positive * zArithProof val zgcdM : z -> z -> z + val zgcd_pol : z polC -> z * z + val zdiv_pol : z polC -> z -> z polC + val makeCuttingPlane : z polC -> z polC * z + val genCuttingPlane : z nFormula -> ((z polC * z) * op1) option -val nformula_of_cutting_plane : (z polC * z) * op1 -> z nFormula + +val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula + val is_pol_Z0 : z polC -> bool + val eval_Psatz0 : z nFormula list -> zWitness -> z nFormula option + val valid_cut_sign : op1 -> bool + val bound_var : positive -> z formula + val mk_eq_pos : positive -> positive -> positive -> z formula + val max_var : positive -> z pol -> positive + val max_var_nformulae : z nFormula list -> positive + val zChecker : z nFormula list -> zArithProof -> bool + val zTautoChecker : z formula bFormula -> zArithProof list -> bool type qWitness = q psatz val qWeakChecker : q nFormula list -> q psatz -> bool + val qnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val qunsat : q nFormula -> bool + val qdeduce : q nFormula -> q nFormula -> q nFormula option + val normQ : q pExpr -> q pol -val cnfQ : - kind - -> (q formula, 'a1, 'a2, 'a3) tFormula - -> (q nFormula, 'a1) cnf * 'a1 list +val cnfQ : kind -> (q formula, 'a1, 'a2, 'a3) tFormula -> (q nFormula, 'a1) cnf * 'a1 list val qTautoChecker : q formula bFormula -> qWitness list -> bool type rcst = - | C0 - | C1 - | CQ of q - | CZ of z - | CPlus of rcst * rcst - | CMinus of rcst * rcst - | CMult of rcst * rcst - | CPow of rcst * (z, nat) sum - | CInv of rcst - | COpp of rcst +| C0 +| C1 +| CQ of q +| CZ of z +| CPlus of rcst * rcst +| CMinus of rcst * rcst +| CMult of rcst * rcst +| CPow of rcst * (z, nat) sum +| CInv of rcst +| COpp of rcst val z_of_exp : (z, nat) sum -> z + val q_of_Rcst : rcst -> q type rWitness = q psatz val rWeakChecker : q nFormula list -> q psatz -> bool + val rnormalise : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val rnegate : q formula -> 'a1 -> (q nFormula, 'a1) cnf + val runsat : q nFormula -> bool + val rdeduce : q nFormula -> q nFormula -> q nFormula option + val rTautoChecker : rcst formula bFormula -> rWitness list -> bool diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 3360a9a51c..6e997696cb 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -33,13 +33,32 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct type key = Key.t - module Table = Hashtbl.Make (Key) - - exception InvalidTableFormat - exception UnboundTable - - type mode = Closed | Open - type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} + module Table : + sig + type 'a t + val empty : 'a t + val add : int -> 'a -> 'a t -> 'a t + val find : int -> 'a t -> 'a list + val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end = + struct + type 'a t = 'a list Int.Map.t + let empty = Int.Map.empty + let add h pos tab = + try Int.Map.modify h (fun _ l -> pos :: l) tab + with Not_found -> Int.Map.add h [pos] tab + + let fold f tab accu = + let fold h l accu = List.fold_left (fun accu pos -> f h pos accu) accu l in + Int.Map.fold fold tab accu + + let find h tab = Int.Map.find h tab + end + (* A mapping key hash -> file position *) + + type 'a data = { pos : int; mutable obj : (Key.t * 'a) option } + + type 'a t = {outch : out_channel; mutable htbl : 'a data Table.t; file : string } (* XXX: Move to Fun.protect once in Ocaml 4.08 *) let fun_protect ~(finally : unit -> unit) work = @@ -57,10 +76,19 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct finally_no_exn (); Printexc.raise_with_backtrace work_exn work_bt - let read_key_elem inch = - try Some (Marshal.from_channel inch) with - | End_of_file -> None - | e when CErrors.noncritical e -> raise InvalidTableFormat + let skip_blob ch = + let hd = Bytes.create Marshal.header_size in + let () = really_input ch hd 0 Marshal.header_size in + let len = Marshal.data_size hd 0 in + let pos = pos_in ch in + seek_in ch (pos + len) + + let read_key_elem inch = match input_binary_int inch with + | hash -> + let pos = pos_in inch in + let () = skip_blob inch in + Some (hash, pos) + | exception End_of_file -> None (** We used to only lock/unlock regions. @@ -102,52 +130,97 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct let do_under_lock kd fd f = if lock kd fd then fun_protect f ~finally:(fun () -> unlock fd) else f () - let open_in f = + let fopen_in = open_in + + let open_in (type a) f : a t = let flags = [O_RDONLY; O_CREAT] in let finch = openfile f flags 0o666 in let inch = in_channel_of_descr finch in - let htbl = Table.create 100 in - let rec xload () = + let exception InvalidTableFormat of a data Table.t in + let rec xload table = match read_key_elem inch with - | None -> () - | Some (key, elem) -> Table.add htbl key elem; xload () + | None -> table + | Some (hash, pos) -> xload (Table.add hash { pos; obj = None } table) + | exception e when CErrors.noncritical e -> raise (InvalidTableFormat table) in try (* Locking of the (whole) file while reading *) - do_under_lock Read finch xload; - close_in_noerr inch; - { outch = - out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) - ; status = Open - ; htbl } - with InvalidTableFormat -> + let htbl = do_under_lock Read finch (fun () -> xload Table.empty) in + let () = close_in_noerr inch in + let outch = out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) in + { outch ; file = f; htbl } + with InvalidTableFormat htbl -> (* The file is corrupted *) - close_in_noerr inch; + let fold hash data accu = + let () = seek_in inch data.pos in + match Marshal.from_channel inch with + | (k, v) -> (hash, k, v) :: accu + | exception e -> accu + in + (* Try to salvage what we can *) + let data = do_under_lock Read finch (fun () -> Table.fold fold htbl []) in + let () = close_in_noerr inch in let flags = [O_WRONLY; O_TRUNC; O_CREAT] in let out = openfile f flags 0o666 in let outch = out_channel_of_descr out in - do_under_lock Write out (fun () -> - Table.iter - (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) - htbl; - flush outch); - {outch; status = Open; htbl} + let fold htbl (h, k, e) = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + Table.add h { pos; obj = None } htbl + in + let dump () = + let htbl = List.fold_left fold Table.empty data in + let () = flush outch in + htbl + in + let htbl = do_under_lock Write out dump in + {outch; htbl; file = f} let add t k e = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let fd = descr_of_out_channel outch in - Table.add tbl k e; - do_under_lock Write fd (fun _ -> - Marshal.to_channel outch (k, e) [Marshal.No_sharing]; - flush outch) + let {outch} = t in + let fd = descr_of_out_channel outch in + let h = Key.hash k land 0x7FFFFFFF in + let dump () = + let () = output_binary_int outch h in + let pos = pos_out outch in + let () = Marshal.to_channel outch (k, e) [] in + let () = flush outch in + pos + in + let pos = do_under_lock Write fd dump in + t.htbl <- Table.add h { pos; obj = Some (k, e) } t.htbl let find t k = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let res = Table.find tbl k in + let {outch; htbl = tbl} = t in + let h = Key.hash k land 0x7FFFFFFF in + let lpos = Table.find h tbl in + (* First look for already live data *) + let find data = match data.obj with + | Some (k', v) -> if Key.equal k k' then Some v else None + | None -> None + in + match CList.find_map find lpos with + | res -> res + | exception Not_found -> + (* Otherwise perform I/O and look at the disk cache *) + let lpos = List.filter (fun data -> Option.is_empty data.obj) lpos in + let () = if CList.is_empty lpos then raise Not_found in + let ch = fopen_in t.file in + let find data = + let () = seek_in ch data.pos in + match Marshal.from_channel ch with + | (k', v) -> + if Key.equal k k' then + (* Store the data in memory *) + let () = data.obj <- Some (k, v) in + Some v + else None + | exception _ -> None + in + let lookup () = CList.find_map find lpos in + let res = do_under_lock Read (descr_of_out_channel outch) lookup in + let () = close_in_noerr ch in res let memo cache f = diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 5c0aa9ef0d..7b29aa15f9 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -254,6 +254,16 @@ let is_strict c = c.op = Gt let eval_op = function Eq -> ( =/ ) | Ge -> ( >=/ ) | Gt -> ( >/ ) let string_of_op = function Eq -> "=" | Ge -> ">=" | Gt -> ">" +let compare_op o1 o2 = + match (o1, o2) with + | Eq, Eq -> 0 + | Eq, _ -> -1 + | _, Eq -> 1 + | Ge, Ge -> 0 + | Ge, _ -> -1 + | _, Ge -> 1 + | Gt, Gt -> 0 + let output_cstr o {coeffs; op; cst} = Printf.fprintf o "%a %s %s" Vect.pp coeffs (string_of_op op) (Q.to_string cst) @@ -284,7 +294,11 @@ module LinPoly = struct if !fresh > vr then failwith (Printf.sprintf "Cannot reserve %i" vr) else fresh := vr + 1 - let get_fresh () = !fresh + let safe_reserve vr = if !fresh > vr then () else fresh := vr + 1 + + let get_fresh () = + let vr = !fresh in + incr fresh; vr let register m = try MonoMap.find m !index_of_monomial @@ -445,6 +459,7 @@ module ProofFormat = struct type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof @@ -471,6 +486,9 @@ module ProofFormat = struct | Done -> Printf.fprintf o "." | Step (i, p, pf) -> Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + | Split (i, v, p1, p2) -> + Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 + output_proof p2 | 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 @@ -489,23 +507,36 @@ module ProofFormat = struct | CutPrf p -> pr_size p | MulC (v, p) -> pr_size p - let rec pr_rule_max_id = function - | Annot (_, p) -> pr_rule_max_id p - | Hyp i | Def i -> i + let rec pr_rule_max_hyp = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> i + | Def i -> -1 + | Cst _ | Zero | Square _ -> -1 + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_hyp p + | MulPrf (p1, p2) | AddPrf (p1, p2) -> + max (pr_rule_max_hyp p1) (pr_rule_max_hyp p2) + + let rec pr_rule_max_def = function + | Annot (_, p) -> pr_rule_max_hyp p + | Hyp i -> -1 + | Def i -> i | Cst _ | Zero | Square _ -> -1 - | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_id p + | MulC (_, p) | CutPrf p | Gcd (_, p) -> pr_rule_max_def p | MulPrf (p1, p2) | AddPrf (p1, p2) -> - max (pr_rule_max_id p1) (pr_rule_max_id p2) + max (pr_rule_max_def p1) (pr_rule_max_def p2) - let rec proof_max_id = function + let rec proof_max_def = function | Done -> -1 - | Step (i, pr, prf) -> max i (max (pr_rule_max_id pr) (proof_max_id prf)) + | Step (i, pr, prf) -> max i (max (pr_rule_max_def pr) (proof_max_def prf)) + | Split (i, _, p1, p2) -> max i (max (proof_max_def p1) (proof_max_def p2)) | 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 m = max (pr_rule_max_def p1) (pr_rule_max_def p2) in + List.fold_left (fun i prf -> max i (proof_max_def prf)) (max i m) l | ExProof (i, j, k, _, _, _, prf) -> - max (max (max i j) k) (proof_max_id prf) + max (max (max i j) k) (proof_max_def prf) + (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. + This is because the Coq proof format only accept they as a proof-step *) let rec pr_rule_def_cut id = function | Annot (_, p) -> pr_rule_def_cut id p | MulC (p, prf) -> @@ -536,46 +567,51 @@ module ProofFormat = struct let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p - let rec pr_rule_collect_hyps pr = + let rec pr_rule_collect_defs pr = match pr with - | Annot (_, pr) -> pr_rule_collect_hyps pr - | Hyp i | Def i -> ISet.add i ISet.empty + | Annot (_, pr) -> pr_rule_collect_defs pr + | Def i -> ISet.add i ISet.empty + | Hyp i -> ISet.empty | Cst _ | Zero | Square _ -> ISet.empty - | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_hyps pr + | MulC (_, pr) | Gcd (_, pr) | CutPrf pr -> pr_rule_collect_defs pr | MulPrf (p1, p2) | AddPrf (p1, p2) -> - ISet.union (pr_rule_collect_hyps p1) (pr_rule_collect_hyps p2) + ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs 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) ) - | ExProof (i, j, k, x, z, t, prf) -> - let prf', hyps = simplify_proof prf in - if - (not (ISet.mem i hyps)) - && (not (ISet.mem j hyps)) - && not (ISet.mem k hyps) - then (prf', hyps) - else - ( ExProof (i, j, k, x, z, t, prf') - , ISet.add i (ISet.add j (ISet.add k hyps)) ) - in - fst (simplify_proof p) + (** [simplify_proof p] removes proof steps that are never re-used. *) + let rec simplify_proof p = + match p with + | Done -> (Done, ISet.empty) + | Step (i, pr, Done) -> (p, ISet.add i (pr_rule_collect_defs 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_defs pr) hyps) ) + | Split (i, v, p1, p2) -> + let p1, h1 = simplify_proof p1 in + let p2, h2 = simplify_proof p2 in + if not (ISet.mem i h1) then (p1, h1) (* Should not have computed p2 *) + else if not (ISet.mem i h2) then (p2, h2) + else (Split (i, v, p1, p2), ISet.add i (ISet.union h1 h2)) + | 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_defs p1) (pr_rule_collect_defs p2)) + hyps) ) + | ExProof (i, j, k, x, z, t, prf) -> + let prf', hyps = simplify_proof prf in + if + (not (ISet.mem i hyps)) + && (not (ISet.mem j hyps)) + && not (ISet.mem k hyps) + then (prf', hyps) + else + ( ExProof (i, j, k, x, z, t, prf') + , ISet.add i (ISet.add j (ISet.add k hyps)) ) let rec normalise_proof id prf = match prf with @@ -591,6 +627,10 @@ module ProofFormat = struct bds in (id, prf) + | Split (i, v, p1, p2) -> + let id, p1 = normalise_proof id p1 in + let id, p2 = normalise_proof id p2 in + (id, Split (i, v, p1, p2)) | ExProof (i, j, k, x, z, t, prf) -> let id, prf = normalise_proof id prf in (id, ExProof (i, j, k, x, z, t, prf)) @@ -612,7 +652,7 @@ module ProofFormat = struct (bds2 @ bds1) ) let normalise_proof id prf = - let prf = simplify_proof prf in + let prf = fst (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 @@ -652,9 +692,9 @@ module ProofFormat = struct | Gcd (b1, p1), Gcd (b2, p2) -> cmp_pair Z.compare compare (b1, p1) (b2, p2) | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) - | AddPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, q1) (p2, q2) + cmp_pair compare compare (p1, p2) (q1, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, p2) (q1, q2) | CutPrf p, CutPrf p' -> compare p p' | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) end @@ -746,16 +786,23 @@ module ProofFormat = struct Zero vect module Env = struct - let rec string_of_int_list l = + let output_hyp_or_def o = function + | Hyp i -> Printf.fprintf o "Hyp %i" i + | Def i -> Printf.fprintf o "Def %i" i + | _ -> () + + let rec output_hyps o l = match l with - | [] -> "" - | i :: l -> Printf.sprintf "%i,%s" i (string_of_int_list l) + | [] -> () + | i :: l -> Printf.fprintf o "%a,%a" output_hyp_or_def i output_hyps 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)) + Printf.fprintf stdout "\nid_of_hyp: %a notin [%a]\n" output_hyp_or_def + hyp output_hyps l; + failwith "Cannot find hyp or def" | hyp' :: l' -> if hyp = hyp' then i else xid_of_hyp (i + 1) l' in xid_of_hyp 0 l @@ -764,7 +811,7 @@ module ProofFormat = struct let cmpl_prf_rule norm (cst : Q.t -> '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)) + | (Hyp _ | Def _) as h -> Mc.PsatzIn (CamlToCoq.nat (Env.id_of_hyp h env)) | Cst i -> Mc.PsatzC (cst i) | Zero -> Mc.PsatzZ | MulPrf (p1, p2) -> Mc.PsatzMulE (cmpl p1, cmpl p2) @@ -780,25 +827,40 @@ module ProofFormat = struct let cmpl_prf_rule_z env r = cmpl_prf_rule Mc.normZ (fun x -> CamlToCoq.bigint (Q.num x)) env r + let cmpl_pol_z lp = + try + let cst x = CamlToCoq.bigint (Q.num x) in + Mc.normZ (LinPoly.coq_poly_of_linpol cst lp) + with x -> + Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; + raise x + let rec cmpl_proof env = function | Done -> Mc.DoneProof | Step (i, p, prf) -> ( 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) ) + Mc.CutProof (cmpl_prf_rule_z env p', cmpl_proof (Def i :: env) prf) + | _ -> Mc.RatProof (cmpl_prf_rule_z env p, cmpl_proof (Def i :: env) prf) + ) + | Split (i, v, p1, p2) -> + Mc.SplitProof + ( cmpl_pol_z v + , cmpl_proof (Def i :: env) p1 + , cmpl_proof (Def i :: env) p2 ) | 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 ) + , List.map (cmpl_proof (Def i :: env)) l ) | ExProof (i, j, k, x, _, _, prf) -> - Mc.ExProof (CamlToCoq.positive x, cmpl_proof (i :: j :: k :: env) prf) + Mc.ExProof + (CamlToCoq.positive x, cmpl_proof (Def i :: Def j :: Def k :: env) prf) let compile_proof env prf = - let id = 1 + proof_max_id prf in + let id = 1 + proof_max_def prf in let _, prf = normalise_proof id prf in - cmpl_proof env prf + cmpl_proof (List.map (fun i -> Hyp i) env) prf let rec eval_prf_rule env = function | Annot (s, p) -> eval_prf_rule env p @@ -848,6 +910,7 @@ module ProofFormat = struct false end else eval_proof (IMap.add i (p, o) env) rst + | Split (i, v, p1, p2) -> failwith "Not implemented" | 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 @@ -863,7 +926,7 @@ module WithProof = struct let compare : t -> t -> int = fun ((lp1, o1), _) ((lp2, o2), _) -> let c = Vect.compare lp1 lp2 in - if c = 0 then compare o1 o2 else c + if c = 0 then compare_op o1 o2 else c let annot s (p, prf) = (p, ProofFormat.Annot (s, prf)) @@ -887,6 +950,13 @@ module WithProof = struct fun ((p1, o1), prf1) ((p2, o2), prf2) -> ((Vect.add p1 p2, opAdd o1 o2), ProofFormat.add_proof prf1 prf2) + let neg : t -> t = + fun ((p1, o1), prf1) -> + match o1 with + | Eq -> + ((Vect.mul Q.minus_one p1, o1), ProofFormat.mul_cst_proof Q.minus_one prf1) + | _ -> failwith "neg: invalid proof" + let mult p ((p1, o1), prf1) = match o1 with | Eq -> ((LinPoly.product p p1, o1), ProofFormat.sMulC p prf1) @@ -912,13 +982,13 @@ module WithProof = struct else match o with | Eq -> - Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) + Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.CutPrf prf) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> (* This is a non-trivial common divisor *) Some ( (Vect.set 0 c1' (Vect.div (Q.of_bigint g) p), o) - , ProofFormat.Gcd (g, prf) ) + , ProofFormat.CutPrf prf ) let construct_sign p = let c, p' = Vect.decomp_cst p in @@ -1011,6 +1081,22 @@ module WithProof = struct | None -> sys0 | Some sys' -> sys' ) + let sort (sys : t list) = + let size ((p, o), prf) = + let _, p' = Vect.decomp_cst p in + let (x, q), p' = Vect.decomp_fst p' in + Vect.fold + (fun (l, (q, x)) x' q' -> + let q' = Q.abs q' in + (l + 1, if q </ q then (q, x) else (q', x'))) + (1, (Q.abs q, x)) + p + in + let cmp ((l1, (q1, _)), ((_, o), _)) ((l2, (q2, _)), ((_, o'), _)) = + if l1 < l2 then -1 else if l1 = l2 then Q.compare q1 q2 else 1 + in + List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) + let subst sys0 = let elim sys = let oeq, sys' = extract (is_substitution true) sys in @@ -1018,7 +1104,7 @@ module WithProof = struct | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in - iterate_until_stable elim sys0 + iterate_until_stable elim (List.map snd (sort sys0)) let saturate_subst b sys0 = let select = is_substitution b in @@ -1029,6 +1115,26 @@ module WithProof = struct in saturate select gen sys0 + let simple_pivot (q1, x) ((v1, o1), prf1) ((v2, o2), prf2) = + let q2 = Vect.get x v2 in + if q2 =/ Q.zero then None + else + let cv1, cv2 = + if Q.sign q1 <> Q.sign q2 then (Q.abs q2, Q.abs q1) + else + match (o1, o2) with + | Eq, _ -> (q2, Q.abs q1) + | _, Eq -> (Q.abs q2, q2) + | _, _ -> (Q.zero, Q.zero) + in + if cv2 =/ Q.zero then None + else + Some + ( (Vect.mul_add cv1 v1 cv2 v2, opAdd o1 o2) + , ProofFormat.add_proof + (ProofFormat.mul_cst_proof cv1 prf1) + (ProofFormat.mul_cst_proof cv2 prf2) ) + open Vect.Bound let mul_bound w1 w2 = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 9c09f76691..84b5421207 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -120,6 +120,7 @@ type cstr = {coeffs : Vect.t; op : op; cst : Q.t} and op = Eq | Ge | Gt val eval_op : op -> Q.t -> Q.t -> bool +val compare_op : op -> op -> int (*val opMult : op -> op -> op*) @@ -153,6 +154,9 @@ module LinPoly : sig (** [reserve i] reserves the integer i *) val reserve : int -> unit + (** [safe_reserve i] reserves the integer i *) + val safe_reserve : int -> unit + (** [get_fresh ()] return the first fresh variable *) val get_fresh : unit -> int @@ -283,14 +287,16 @@ module ProofFormat : sig type proof = | Done | Step of int * prf_rule * proof + | Split of int * Vect.t * proof * proof | Enum of int * prf_rule * Vect.t * prf_rule * proof list | ExProof of int * int * int * var * var * var * proof (* x = z - t, z >= 0, t >= 0 *) val pr_size : prf_rule -> Q.t - val pr_rule_max_id : prf_rule -> int - val proof_max_id : proof -> int + val pr_rule_max_def : prf_rule -> int + val pr_rule_max_hyp : prf_rule -> int + val proof_max_def : proof -> int val normalise_proof : int -> proof -> int * proof val output_prf_rule : out_channel -> prf_rule -> unit val output_proof : out_channel -> proof -> unit @@ -302,13 +308,16 @@ module ProofFormat : sig val cmpl_prf_rule : ('a Micromega.pExpr -> 'a Micromega.pol) -> (Q.t -> 'a) - -> int list + -> prf_rule 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 + val simplify_proof : proof -> proof * Mutils.ISet.t + + module PrfRuleMap : Map.S with type key = prf_rule end val output_cstr : out_channel -> cstr -> unit @@ -344,6 +353,12 @@ module WithProof : sig @return the polynomial p+q with its sign and proof *) val addition : t -> t -> t + (** [neg p] + @return the polynomial -p with its sign and proof + @raise an error if this not an equality + *) + val neg : 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 *) @@ -360,6 +375,13 @@ module WithProof : sig *) val linear_pivot : t list -> t -> Vect.var -> t -> t option + (** [simple_pivot (c,x) p q] performs a pivoting over the variable [x] where + p = c+a1.x1+....+c.x+...an.xn and c <> 0 *) + val simple_pivot : Q.t * var -> t -> t -> t option + + (** [sort sys] sorts constraints according to the lexicographic order (number of variables, size of the smallest coefficient *) + val sort : t list -> ((int * (Q.t * var)) * t) list + (** [subst sys] performs the equivalent of the 'subst' tactic of Coq. For every p=0 \in sys such that p is linear in x with coefficient +/- 1 i.e. p = 0 <-> x = e and x \notin e. diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index f59d65085a..39024819be 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -60,6 +60,77 @@ let get_profile_info () = ( try (p.success_pivots + p.failure_pivots) / p.average_pivots with Division_by_zero -> 0 ) } +(* SMT output for debugging *) + +(* +let pp_smt_row o (k, v) = + Printf.fprintf o "(assert (= x%i %a))\n" k Vect.pp_smt v + +let pp_smt_assert_tbl o tbl = IMap.iter (fun k v -> pp_smt_row o (k, v)) tbl + +let pp_smt_goal_tbl o tbl = + let pp_rows o tbl = + IMap.iter (fun k v -> Printf.fprintf o "(= x%i %a)" k Vect.pp_smt v) tbl + in + Printf.fprintf o "(assert (not (and %a)))\n" pp_rows tbl + +let pp_smt_vars s o var = + ISet.iter + (fun i -> + Printf.fprintf o "(declare-const x%i %s);%a\n" i s LinPoly.pp_var i) + (ISet.remove 0 var) + +let pp_smt_goal s o tbl1 tbl2 = + let set_of_row vr v = ISet.add vr (Vect.variables v) in + let var = + IMap.fold (fun k v acc -> ISet.union (set_of_row k v) acc) tbl1 ISet.empty + in + Printf.fprintf o "(echo \"%s\")\n(push) %a %a %a (check-sat) (pop)\n" s + (pp_smt_vars "Real") var pp_smt_assert_tbl tbl1 pp_smt_goal_tbl tbl2; + flush stdout + +let pp_smt_cut o lp c = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + Printf.fprintf o + "(push) \n\ + (echo \"new cut\")\n\ + %a %a (assert (not (>= %a 0)))\n\ + (check-sat) (pop)\n" + (pp_smt_vars "Int") var pp_list lp Vect.pp_smt c + +let pp_smt_sat o lp sol = + let var = + ISet.remove 0 + (List.fold_left + (fun acc ((c, o), _) -> ISet.union (Vect.variables c) acc) + ISet.empty lp) + in + let pp_list o l = + List.iter + (fun ((c, _), _) -> Printf.fprintf o "(assert (>= %a 0))\n" Vect.pp_smt c) + l + in + let pp_model o v = + Vect.fold + (fun () v x -> + Printf.fprintf o "(assert (= x%i %a))\n" v Vect.pp_smt (Vect.cst x)) + () v + in + Printf.fprintf o + "(push) \n(echo \"check base\")\n%a %a %a\n(check-sat) (pop)\n" + (pp_smt_vars "Real") var pp_list lp pp_model sol + *) + type iset = unit IMap.t (** Mapping basic variables to their equation. @@ -375,38 +446,6 @@ open Polynomial (*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 Q.neg n) acc) - Vect.null l) - -(** [eliminate_equalities vr0 l] - represents an equality e = 0 of index idx in the list l - by 2 constraints (vr:e >= 0) and (vr+1:-e >= 0) - The mapping vm maps vr to idx - *) - -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 (Q.neg 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 (Q.neg c.cst) c.coeffs in - let v2 = Vect.mul Q.minus_one 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 -> @@ -440,19 +479,9 @@ let rec solve opt l (rst : Restricted.t) (t : tableau) = | 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*) - match l with - | [] -> Inl (rst, t', x) - | _ -> solve opt l rst t' ) + match l with [] -> Inl (rst, t', x) | _ -> solve opt l rst t' ) | Unsat c -> Inr c ) -let find_unsat_certificate (l : Polynomial.cstr list) = - let vr = LinPoly.MonT.get_fresh () 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 fresh_var l = 1 + @@ -463,64 +492,110 @@ let fresh_var l = ISet.empty l) with Not_found -> 0 +module PrfEnv = struct + type t = WithProof.t IMap.t + + let empty = IMap.empty + + let register prf env = + let fr = LinPoly.MonT.get_fresh () in + (fr, IMap.add fr prf env) + + (* let register_def (v, op) {fresh; env} = + LinPoly.MonT.reserve fresh; + (fresh, {fresh = fresh + 1; env = IMap.add fresh ((v, op), Def fresh) env}) *) + + let set_prf i prf env = IMap.add i prf env + let find idx env = IMap.find idx env + + let rec of_list acc env l = + match l with + | [] -> (acc, env) + | (((lp, op), prf) as wp) :: l -> ( + match op with + | Gt -> raise Strict (* Should be eliminated earlier *) + | Ge -> + (* Simply register *) + let f, env' = register wp env in + of_list ((f, lp) :: acc) env' l + | Eq -> + (* Generate two constraints *) + let f1, env = register wp env in + let wp' = WithProof.neg wp in + let f2, env = register wp' env in + of_list ((f1, lp) :: (f2, fst (fst wp')) :: acc) env l ) + + let map f env = IMap.map f env +end + +let make_env (l : Polynomial.cstr list) = + PrfEnv.of_list [] PrfEnv.empty + (List.rev_map WithProof.of_cstr + (List.mapi (fun i x -> (x, ProofFormat.Hyp i)) l)) + let find_point (l : Polynomial.cstr list) = let vr = fresh_var l in - let _, vm, l' = eliminate_equalities vr l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env 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 = LinPoly.MonT.get_fresh () in - let _, vm, l' = eliminate_equalities (vr0 + 1) l in + let vr = fresh_var l in + LinPoly.MonT.safe_reserve vr; + let l', _ = make_env l in let bound pos res = match res with | Opt (_, Max n) -> Some (if pos then n else Q.neg n) | Opt (_, Ubnd _) -> None | Opt (_, Feas) -> None in - match solve false l' (Restricted.make vr0) IMap.empty with + match solve false l' (Restricted.make vr) 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)) ) + ( bound false (simplex true vr rst (add_row vr t (Vect.uminus obj))) + , bound true (simplex true vr rst (add_row vr t obj)) ) | _ -> None -open Polynomial +(** [make_certificate env l] makes very strong assumptions + about the form of the environment. + Each proof is assumed to be either: + - an hypothesis Hyp i + - or, the negation of an hypothesis (MulC(-1,Hyp i)) + *) -let env_of_list l = - List.fold_left (fun (i, m) l -> (i + 1, IMap.add i l m)) (0, IMap.empty) l +let make_certificate env l = + Vect.normalise + (Vect.fold + (fun acc x n -> + let _, prf = PrfEnv.find x env in + ProofFormat.( + match prf with + | Hyp i -> Vect.set i n acc + | MulC (_, Hyp i) -> Vect.set i (Q.neg n) acc + | _ -> failwith "make_certificate: invalid proof")) + Vect.null l) + +let find_unsat_certificate (l : Polynomial.cstr list) = + let l', env = make_env l in + let vr = fresh_var l in + match solve false l' (Restricted.make vr) IMap.empty with + | Inr c -> Some (make_certificate env c) + | Inl _ -> None +open Polynomial open ProofFormat -let make_farkas_certificate (env : WithProof.t IMap.t) vm v = +let make_farkas_certificate (env : PrfEnv.t) 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 Q.neg n) (snd (IMap.find x' env)) - with Not_found -> - (* This is an introduced hypothesis *) - mul_cst_proof n (snd (IMap.find x env)) - end) + (fun acc x n -> add_proof acc (mul_cst_proof n (snd (PrfEnv.find x env)))) Zero v -let make_farkas_proof (env : WithProof.t IMap.t) vm v = +let make_farkas_proof (env : PrfEnv.t) 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 Q.neg n in - let prf = IMap.find x' env in - WithProof.mult (Vect.cst n) prf - with Not_found -> - let prf = IMap.find x env in - WithProof.mult (Vect.cst n) prf - end) + WithProof.addition wp (WithProof.mult (Vect.cst n) (PrfEnv.find x env))) WithProof.zero v let frac_num n = n -/ Q.floor n @@ -532,9 +607,15 @@ type ('a, 'b) hitkind = (* Yes, we have a positive result *) | Keep of 'b -let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = +let violation sol vect = + let sol = Vect.set 0 Q.one sol in + let c = Vect.get 0 vect in + if Q.zero =/ c then Vect.dotproduct sol vect + else Q.abs (Vect.dotproduct sol vect // c) + +let cut env rmin sol (rst : Restricted.t) tbl (x, v) = let n, r = Vect.decomp_cst v in - let fn = frac_num n in + let fn = frac_num (Q.abs n) in if fn =/ Q.zero then Forget (* The solution is integral *) else (* The cut construction is from: @@ -580,7 +661,7 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = in let lcut = ( fst ccoeff - , make_farkas_proof env vm (Vect.normalise (cut_vector (snd ccoeff))) ) + , make_farkas_proof env (Vect.normalise (cut_vector (snd ccoeff))) ) in let check_cutting_plane (p, c) = match WithProof.cutting_plane c with @@ -592,7 +673,9 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = | Some (v, prf) -> if debug then ( Printf.printf "%s: This is a cutting plane for %a:" p LinPoly.pp_var x; - Printf.printf " %a\n" WithProof.output (v, prf) ); + Printf.printf "(viol %f) %a\n" + (Q.to_float (violation sol (fst v))) + WithProof.output (v, prf) ); Some (x, (v, prf)) in match check_cutting_plane lcut with @@ -621,30 +704,69 @@ let merge_best lt oldr newr = | Forget, Keep v -> Keep v | Keep v, Keep v' -> Keep v' -let find_cut nb env u sol vm rst tbl = +(*let size_vect v = + let abs z = if Z.compare z Z.zero < 0 then Z.neg z else z in + Vect.fold + (fun acc _ q -> Z.add (abs (Q.num q)) (Z.add (Q.den q) acc)) + Z.zero v + *) + +let find_cut nb env u sol rst tbl = if nb = 0 then IMap.fold - (fun x v acc -> merge_result_old acc (cut env u sol vm rst tbl) (x, v)) + (fun x v acc -> merge_result_old acc (cut env u sol rst tbl) (x, v)) tbl Forget else - let lt (_, (_, p1)) (_, (_, p2)) = + let lt (_, ((v1, _), p1)) (_, ((v2, _), p2)) = + (*violation sol v1 >/ violation sol v2*) ProofFormat.pr_size p1 </ ProofFormat.pr_size p2 in IMap.fold - (fun x v acc -> merge_best lt acc (cut env u sol vm rst tbl (x, v))) + (fun x v acc -> merge_best lt acc (cut env u sol rst tbl (x, v))) tbl Forget +let find_split env tbl rst = + let is_split x v = + let v, n = + let n, _ = Vect.decomp_cst v in + if Restricted.is_restricted x rst then + let n', v = Vect.decomp_cst (fst (fst (PrfEnv.find x env))) in + (v, n -/ n') + else (Vect.set x Q.one Vect.null, n) + in + if Restricted.is_restricted x rst then None + else + let fn = frac_num n in + if fn =/ Q.zero then None + else + let fn = Q.abs fn in + let score = Q.min fn (Q.one -/ fn) in + let vect = Vect.add (Vect.cst (Q.neg n)) v in + Some (Vect.normalise vect, score) + in + IMap.fold + (fun x v acc -> + match is_split x v with + | None -> acc + | Some (v, s) -> ( + match acc with + | None -> Some (v, s) + | Some (v', s') -> if s' >/ s then acc else Some (v, s) )) + tbl None + let var_of_vect v = fst (fst (Vect.decomp_fst v)) -let eliminate_variable (bounded, vr, env, tbl) x = +let eliminate_variable (bounded, env, tbl) x = if debug then Printf.printf "Eliminating variable %a from tableau\n%a\n" LinPoly.pp_var x output_tableau tbl; (* We identify the new variables with the constraint. *) - LinPoly.MonT.reserve vr; - let z = LinPoly.var (vr + 1) in + let vr = LinPoly.MonT.get_fresh () in + let vr1 = LinPoly.MonT.get_fresh () in + let vr2 = LinPoly.MonT.get_fresh () in + let z = LinPoly.var vr1 in let zv = var_of_vect z in - let t = LinPoly.var (vr + 2) in + let t = LinPoly.var vr2 in let tv = var_of_vect t in (* x = z - t *) let xdef = Vect.add z (Vect.uminus t) in @@ -653,9 +775,9 @@ let eliminate_variable (bounded, vr, env, tbl) x = let tp = ((t, Ge), Def tv) in (* Pivot the current tableau using xdef *) let tbl = IMap.map (fun v -> Vect.subst x xdef v) tbl in - (* Pivot the environment *) + (* Pivot the proof environment *) let env = - IMap.map + PrfEnv.map (fun lp -> let (v, o), p = lp in let ai = Vect.get x v in @@ -664,77 +786,123 @@ let eliminate_variable (bounded, vr, env, tbl) x = env in (* Add the variables to the environment *) - let env = IMap.add vr xp (IMap.add zv zp (IMap.add tv tp env)) in + let env = + PrfEnv.set_prf vr xp (PrfEnv.set_prf zv zp (PrfEnv.set_prf tv tp env)) + in (* Remember the mapping *) let bounded = IMap.add x (vr, zv, tv) bounded in if debug then ( Printf.printf "Tableau without\n %a\n" output_tableau tbl; Printf.printf "Environment\n %a\n" output_env env ); - (bounded, vr + 3, env, tbl) + (bounded, env, tbl) let integer_solver lp = - let l, _ = List.split lp in - let vr0 = 3 * LinPoly.MonT.get_fresh () 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) + | Sat (t', x) -> + (*pp_smt_goal stdout tbl vr v t';*) + Inl (Restricted.restrict vr rst, t', x) | Unsat c -> Inr c in + let vr0 = LinPoly.MonT.get_fresh () in + (* Initialise the proof environment mapping variables of the simplex to their proof. *) + let l', env = + PrfEnv.of_list [] PrfEnv.empty (List.rev_map WithProof.of_cstr lp) + in let nb = ref 0 in - let rec isolve env cr vr res = + let rec isolve env cr res = incr nb; match res with | Inr c -> - Some (Step (vr, make_farkas_certificate env vm (Vect.normalise c), Done)) + Some + (Step + ( LinPoly.MonT.get_fresh () + , make_farkas_certificate env (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; flush stdout - (* Printf.fprintf stdout "Bounding box\n%a\n" output_box (bounding_box (vr+1) rst tbl l')*) end; - let sol = find_full_solution rst tbl in - match find_cut (!nb mod 2) env cr (*x*) sol vm rst tbl with - | Forget -> - None (* There is no hope, there should be an integer solution *) - | Hit (cr, ((v, op), cut)) -> - if op = Eq then - (* This is a contradiction *) - Some (Step (vr, CutPrf cut, Done)) - else ( - LinPoly.MonT.reserve vr; - 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 + if !nb mod 3 = 0 then + match find_split env tbl rst with + | None -> + None (* There is no hope, there should be an integer solution *) + | Some (v, s) -> ( + let vr = LinPoly.MonT.get_fresh () in + let wp1 = ((v, Ge), Def vr) in + let wp2 = ((Vect.mul Q.minus_one v, Ge), Def vr) in + match (WithProof.cutting_plane wp1, WithProof.cutting_plane wp2) with + | None, _ | _, None -> + failwith "Error: splitting over an integer variable" + | Some wp1, Some wp2 -> ( + if debug then + Printf.fprintf stdout "Splitting over (%s) %a:%a or %a \n" + (Q.to_string s) LinPoly.pp_var vr WithProof.output wp1 + WithProof.output wp2; + let v1', v2' = (fst (fst wp1), fst (fst wp2)) in + if debug then + Printf.fprintf stdout "Solving with %a\n" LinPoly.pp v1'; + let res1 = insert_row vr v1' (Restricted.set_exc vr rst) tbl in + let prf1 = isolve (IMap.add vr ((v1', Ge), Def vr) env) cr res1 in + match prf1 with + | None -> None + | Some prf1 -> + let prf', hyps = ProofFormat.simplify_proof prf1 in + if not (ISet.mem vr hyps) then Some prf' + else ( + if debug then + Printf.fprintf stdout "Solving with %a\n" Vect.pp v2'; + let res2 = insert_row vr v2' (Restricted.set_exc vr rst) tbl in + let prf2 = + isolve (IMap.add vr ((v2', Ge), Def vr) env) cr res2 + in + match prf2 with + | None -> None + | Some prf2 -> Some (Split (vr, v, prf1, prf2)) ) ) ) + else + let sol = find_full_solution rst tbl in + match find_cut (!nb mod 2) env cr (*x*) sol rst tbl with + | Forget -> + None (* There is no hope, there should be an integer solution *) + | Hit (cr, ((v, op), cut)) -> ( + let vr = LinPoly.MonT.get_fresh () in + if 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) res + in + match prf with + | None -> None + | Some p -> Some (Step (vr, CutPrf cut, p)) ) + | Keep (x, v) -> ( + if debug then + Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; + let bounded, env, tbl = + Vect.fold + (fun acc x n -> + if x <> 0 && not (Restricted.is_restricted x rst) then + eliminate_variable acc x + else acc) + (IMap.empty, env, tbl) v in + let prf = isolve env cr (Inl (rst, tbl, None)) in match prf with | None -> None - | Some p -> Some (Step (vr, CutPrf cut, p)) ) - | Keep (x, v) -> ( - if debug then - Printf.fprintf stdout "Remove %a from Tableau\n" LinPoly.pp_var x; - let bounded, vr, env, tbl = - Vect.fold - (fun acc x n -> - if x <> 0 && not (Restricted.is_restricted x rst) then - eliminate_variable acc x - else acc) - (IMap.empty, vr, env, tbl) v - in - let prf = isolve env cr vr (Inl (rst, tbl, None)) in - match prf with - | None -> None - | Some pf -> - Some - (IMap.fold - (fun x (vr, zv, tv) acc -> ExProof (vr, zv, tv, x, zv, tv, acc)) - bounded pf) ) ) + | Some pf -> + Some + (IMap.fold + (fun x (vr, zv, tv) acc -> + ExProof (vr, zv, tv, x, zv, tv, acc)) + bounded pf) ) ) in let res = solve true l' (Restricted.make vr0) IMap.empty in - isolve env None vr res + isolve env None res let integer_solver lp = nb_pivot := 0; diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index 4df32f2ba4..fe1d721b89 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -57,12 +57,17 @@ let pp_var_num pp_var o {var = v; coe = n} = else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v let pp_var_num_smt pp_var o {var = v; coe = n} = - if Int.equal v 0 then - if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) + let pp_num o q = + let nn = Q.num n in + let dn = Q.den n in + if Z.equal dn Z.one then output_string o (Z.to_string nn) + else Printf.fprintf o "(/ %s %s)" (Z.to_string nn) (Z.to_string dn) + in + if Int.equal v 0 then if Q.zero =/ n then () else pp_num o n else if Q.one =/ n then pp_var o v else if Q.minus_one =/ n then Printf.fprintf o "(- %a)" pp_var v else if Q.zero =/ n then () - else Printf.fprintf o "(* %s %a)" (Q.to_string n) pp_var v + else Printf.fprintf o "(* %a %a)" pp_num n pp_var v let rec pp_gen pp_var o v = match v with diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 9db6c075f8..b4742430fa 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -56,8 +56,8 @@ val get_cst : t -> Q.t (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) val decomp_cst : t -> Q.t * t -(** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) -val decomp_at : int -> t -> Q.t * t +(** [decomp_at xi v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : var -> t -> Q.t * t val decomp_fst : t -> (var * Q.t) * t diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 917961fdcd..d1403558ad 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -1070,6 +1070,28 @@ let pp_trans_expr env evd e res = Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); res +let declared_term env evd hd args = + let match_operator (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp (hd, Array.sub args 0 (n - i)) in + if is_convertible env evd t' t then Some (t, Array.sub args (n - i) i) + else None + in + match t with + | OtherTerm t -> ( match d with InjTyp _ -> None | _ -> Some (t, args) ) + | Application t -> ( + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None ) + in + find_option match_operator (HConstr.find_all hd !table) + let rec trans_expr env evd e = let inj = e.inj in let e = e.constr in diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index 537e652fd0..555bb4c7fb 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -31,3 +31,10 @@ val iter_specs : unit Proofview.tactic val assert_inj : EConstr.constr -> unit Proofview.tactic val iter_let : Ltac_plugin.Tacinterp.Value.t -> unit Proofview.tactic val elim_let : unit Proofview.tactic + +val declared_term : + Environ.env + -> Evd.evar_map + -> EConstr.t + -> EConstr.t array + -> EConstr.constr * EConstr.t array diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 9c75175889..292fbefb84 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -71,7 +71,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - CErrors.user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") + CErrors.user_err ~hdr:"lookup_map" (str"Map "++qs map++str"not found") let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in @@ -135,15 +135,11 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" (****************************************************************************) -let ic c = - let env = Global.env() in - let sigma = Evd.from_env env in +let ic env sigma c = let c, uctx = Constrintern.interp_constr env sigma c in (Evd.from_ctx uctx, c) -let ic_unsafe c = (*FIXME remove *) - let env = Global.env() in - let sigma = Evd.from_env env in +let ic_unsafe env sigma c = (*FIXME remove *) fst (Constrintern.interp_constr env sigma c) let decl_constant name univs c = @@ -170,8 +166,8 @@ let dummy_goal env sigma = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp in {Evd.it = gl; Evd.sigma = sigma} -let constr_of evd v = match Value.to_constr v with - | Some c -> EConstr.to_constr evd c +let constr_of sigma v = match Value.to_constr v with + | Some c -> EConstr.to_constr sigma c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -189,7 +185,7 @@ let get_res = Tacenv.register_ml_tactic name [| tac |]; entry -let exec_tactic env evd n f args = +let exec_tactic env sigma n f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar CAst.(make id)) in @@ -203,11 +199,11 @@ let exec_tactic env evd n f args = let get_res = TacML (CAst.make (get_res, [TacGeneric (None, n)])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (* Evaluate the whole result *) - let gl = dummy_goal env evd in + let gl = dummy_goal env sigma in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in - let evd = Evd.minimize_universes gls.Evd.sigma in - let nf c = constr_of evd c in - Array.map nf !tactic_res, Evd.universe_context_set evd + let sigma = Evd.minimize_universes gls.Evd.sigma in + let nf c = constr_of sigma c in + Array.map nf !tactic_res, Evd.universe_context_set sigma let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) @@ -222,10 +218,9 @@ let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evdref f args = - let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in - evdref := evd; - mkApp(fc,args) +let plapp sigma f args = + let sigma, fc = Evarutil.new_global sigma (Lazy.force f) in + sigma, mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -351,14 +346,14 @@ let find_ring_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"ring" - (str"arguments of ring_simplify do not have all the same type") + (str"Arguments of ring_simplify do not have all the same type.") in List.iter check cl'; (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"ring" - (str"cannot find a declared ring structure over"++ - spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) + (str"Cannot find a declared ring structure over"++ + spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\".")) | [] -> assert false let add_entry e = @@ -411,16 +406,14 @@ let theory_to_obj : ring_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -let setoid_of_relation env evd a r = +let setoid_of_relation env sigma a r = try - let evm = !evd in - let evm, refl = Rewrite.get_reflexive_proof env evm a r in - let evm, sym = Rewrite.get_symmetric_proof env evm a r in - let evm, trans = Rewrite.get_transitive_proof env evm a r in - evd := evm; - lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] + let sigma, refl = Rewrite.get_reflexive_proof env sigma a r in + let sigma, sym = Rewrite.get_symmetric_proof env sigma a r in + let sigma, trans = Rewrite.get_transitive_proof env sigma a r in + sigma, lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> - error "cannot find setoid relation" + CErrors.user_err (str "Cannot find a setoid structure for relation " ++ pr_econstr_env env sigma r ++ str ".") let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] @@ -428,61 +421,59 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -let ring_equality env evd (r,add,mul,opp,req) = - match EConstr.kind !evd req with - | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let setoid = plapp evd coq_eq_setoid [|r|] in - let op_morph = +let ring_equality env sigma (r,add,mul,opp,req) = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> + let sigma, setoid = plapp sigma coq_eq_setoid [|r|] in + let sigma, op_morph = match opp with - Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] - | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let sigma = !evd in + Some opp -> plapp sigma coq_eq_morph [|r;add;mul;opp|] + | None -> plapp sigma coq_eq_smorph [|r;add;mul|] in let sigma, setoid = Typing.solve_evars env sigma setoid in let sigma, op_morph = Typing.solve_evars env sigma op_morph in - evd := sigma; (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) evd r req in + let sigma, setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> - error "ring addition should be declared as a morphism" in + CErrors.user_err (str "Ring addition " ++ pr_econstr_env env sigma add ++ str " should be declared as a morphism.") in let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> - error "ring multiplication should be declared as a morphism" in + CErrors.user_err (str "Ring multiplication " ++ pr_econstr_env env sigma mul ++ str " should be declared as a morphism.") in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> - error "ring opposite should be declared as a morphism" in + CErrors.user_err (str "Ring opposite " ++ pr_econstr_env env sigma opp ++ str " should be declared as a morphism.") in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ - str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ - str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ + (str"Using setoid \""++ pr_econstr_env env sigma req++str"\""++spc()++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ + str"\","++spc()++ str"\""++pr_econstr_env env sigma mul_m++ + str"\""++spc()++str"and \""++pr_econstr_env env sigma opp_m++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ + (str"Using setoid \""++pr_econstr_env env sigma req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ str"\""++spc()++str"and \""++ - pr_econstr_env env !evd mul_m_lem++str"\""); + pr_econstr_env env sigma mul_m++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) -let build_setoid_params env evd r add mul opp req eqth = +let build_setoid_params env sigma r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality env evd (r,add,mul,opp,req) + | None -> ring_equality env sigma (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in @@ -515,71 +506,69 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in TacArg(CAst.make (TacCall(CAst.make (t,[])))) -let make_hyp env evd c = - let t = Retyping.get_type_of env !evd c in - plapp evd coq_mkhypo [|t;c|] +let make_hyp env sigma c = + let t = Retyping.get_type_of env sigma c in + plapp sigma coq_mkhypo [|t;c|] -let make_hyp_list env evdref lH = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; - let l = +let make_hyp_list env sigma lH = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in + let sigma, l = List.fold_right - (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH - (plapp evdref coq_nil [|carrier|]) + (fun c (sigma,l) -> + let sigma, c = make_hyp env sigma c in + plapp sigma coq_cons [|carrier; c; l|]) lH + (plapp sigma coq_nil [|carrier|]) in - let sigma, l' = Typing.solve_evars env !evdref l in - evdref := sigma; + let sigma, l' = Typing.solve_evars env sigma l in let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evdref l' + sigma, Evarutil.nf_evars_universes sigma l' -let interp_power env evdref pow = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_power env sigma pow = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) + let sigma, c = plapp sigma coq_None [|carrier|] in + sigma, (TacArg(CAst.make (TacCall(CAst.make (t,[])))), c) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evdref (ic_unsafe spec) in - (tac, plapp evdref coq_Some [|carrier; spec|]) + let spec = ic_unsafe env sigma spec in + let sigma, spec = make_hyp env sigma spec in + let sigma, pow = plapp sigma coq_Some [|carrier; spec|] in + sigma, (tac, pow) -let interp_sign env evdref sign = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_sign env sigma sign = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match sign with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evdref div = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_div env sigma div = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match div with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = +let add_theory0 env sigma name rth eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); - let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let evd = ref sigma in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd div in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma div in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 5 (zltac "ring_lemmas") + exec_tactic env sigma 5 (zltac "ring_lemmas") [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -619,16 +608,16 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div ring_post_tac = posttac }) in () -let ic_coeff_spec = function - | Computational t -> Computational (ic_unsafe t) - | Morphism t -> Morphism (ic_unsafe t) +let ic_coeff_spec env sigma = function + | Computational t -> Computational (ic_unsafe env sigma t) + | Morphism t -> Morphism (ic_unsafe env sigma t) | Abstract -> Abstract let set_once s r v = if Option.is_empty !r then r := Some v else error (s^" cannot be set twice") -let process_ring_mods l = +let process_ring_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -638,11 +627,11 @@ let process_ring_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k) + Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec env sigma k) | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; @@ -650,9 +639,11 @@ let process_ring_mods l = (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) let add_theory id rth l = - let (sigma, rth) = ic rth in - let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory0 id (sigma, rth) set k cst (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, rth = ic env sigma rth in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods env sigma l in + add_theory0 env sigma id rth set k cst (pre,post) power sign div (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and @@ -663,13 +654,12 @@ let make_args_list sigma rl t = | [] -> let (_,t1,t2) = dest_rel0 sigma t in [t1;t2] | _ -> rl -let make_term_list env evd carrier rl = - let l = List.fold_right - (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl - (plapp evd coq_nil [|carrier|]) +let make_term_list env sigma carrier rl = + let sigma, l = List.fold_right + (fun x (sigma,l) -> plapp sigma coq_cons [|carrier;x;l|]) rl + (plapp sigma coq_nil [|carrier|]) in - let sigma, l = Typing.solve_evars env !evd l in - evd := sigma; l + Typing.solve_evars env sigma l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -695,12 +685,13 @@ let ring_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rl = make_args_list sigma rl t in - let evdref = ref sigma in let e = find_ring_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in + let sigma, l = make_term_list env sigma (EConstr.of_constr e.ring_carrier) rl in + let rl = Value.of_constr l in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (ring@[lH;rl])) end (***********************************************************************) @@ -758,23 +749,23 @@ let sfield_theory = my_reference "semi_field_theory" let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" -let dest_field env evd th_spec = - let th_typ = Retyping.get_type_of env !evd th_spec in - match EConstr.kind !evd th_typ with +let dest_field env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match EConstr.kind sigma th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force afield_theory) f -> - let rth = plapp evd af_ar + when isRefX sigma (Lazy.force afield_theory) f -> + let sigma, rth = plapp sigma af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force field_theory) f -> - let rth = - plapp evd f_r + when isRefX sigma (Lazy.force field_theory) f -> + let sigma, rth = + plapp sigma f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when isRefX !evd (Lazy.force sfield_theory) f -> - let rth = plapp evd sf_sr + when isRefX sigma (Lazy.force sfield_theory) f -> + let sigma, rth = plapp sigma sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" @@ -804,14 +795,14 @@ let find_field_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"field" - (str"arguments of field_simplify do not have all the same type") + (str"Arguments of field_simplify do not have all the same type.") in List.iter check cl'; (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"field" - (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) + (str"Cannot find a declared field structure over"++ + spc()++str"\""++pr_econstr_env env sigma ty++str"\".")) | [] -> assert false let add_field_entry e = @@ -860,14 +851,14 @@ let ftheory_to_obj : field_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -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 field_equality env sigma r inv req = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> let c = UnivGen.constr_of_monomorphic_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) evd r req in + let _setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -875,24 +866,22 @@ let field_equality evd r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory0 env sigma name fth eqth morphth cst_tac inj (pre,post) power sign odiv = let open Constr in check_required_library (cdir@["Field_tac"]); - let (sigma,fth) = ic fth in - let env = Global.env() in - let evd = ref sigma in + let (sigma,fth) = ic env sigma fth in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env evd fth in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + dest_field env sigma fth in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory0 name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd odiv in - let inv_m = field_equality evd r inv req in + let _ = add_theory0 env sigma name rth eqth morphth cst_tac (None,None) power sign odiv in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma odiv in + let inv_m = field_equality env sigma r inv req in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 9 (field_ltac"field_lemmas") + exec_tactic env sigma 9 (field_ltac"field_lemmas") [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -940,7 +929,7 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od field_pre_tac = pretac; field_post_tac = posttac }) in () -let process_field_mods l = +let process_field_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -951,22 +940,24 @@ let process_field_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k) + Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec env sigma k) | Ring_mod(Const_tac t) -> set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; + | Inject i -> set_once "infinite property" inj (ic_unsafe env sigma i)) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) + (env, sigma, k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) let add_field_theory id t mods = - let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods mods in - add_field_theory0 id t set k cst_tac inj (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let (env,sigma,k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods env sigma mods in + add_field_theory0 env sigma id t set k cst_tac inj (pre,post) power sign div let ltac_field_structure e = let req = carg e.field_req in @@ -987,10 +978,11 @@ let field_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let rl = make_args_list sigma rl t in - let evdref = ref sigma in let e = find_field_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in + let sigma, c = make_term_list env sigma (EConstr.of_constr e.field_carrier) rl in + let rl = Value.of_constr c in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (field@[lH;rl])) end diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index d464ec4c06..61f90608b1 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -100,7 +100,7 @@ let rec make_form env sigma atom_env term = | Cast(a,_,_) -> make_form env sigma atom_env a | Ind (ind, _) -> - if Names.eq_ind ind (fst (Lazy.force li_False)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_False)) then Bot else make_atom atom_env (normalize term) @@ -108,11 +108,11 @@ let rec make_form env sigma atom_env term = begin try let ind, _ = destInd sigma hd in - if Names.eq_ind ind (fst (Lazy.force li_and)) then + if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_and)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Conjunct (fa,fb) - else if Names.eq_ind ind (fst (Lazy.force li_or)) then + else if Names.Ind.CanOrd.equal ind (fst (Lazy.force li_or)) then let fa = make_form env sigma atom_env argv.(0) in let fb = make_form env sigma atom_env argv.(1) in Disjunct (fa,fb) diff --git a/plugins/ssr/ssrbwd.ml b/plugins/ssr/ssrbwd.ml index 42b9248979..61643c2aa3 100644 --- a/plugins/ssr/ssrbwd.ml +++ b/plugins/ssr/ssrbwd.ml @@ -50,7 +50,7 @@ let interp_agen ist gl ((goclr, _), (k, gc as c)) (clr, rcs) = SsrHyp (Loc.tag ?loc id) :: clr', rcs' | _ -> clr', rcs' -let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) +let pf_pr_glob_constr gl = pr_glob_constr_env (pf_env gl) (project gl) let interp_nbargs ist gl rc = try diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index cb58b9bcb8..cd219838d5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -895,7 +895,7 @@ open Constrexpr open Util (** Constructors for constr_expr *) -let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [GProp,0]) +let mkCProp loc = CAst.make ?loc @@ CSort (UNamed [CProp,0]) let mkCType loc = CAst.make ?loc @@ CSort (UAnonymous {rigid=true}) let mkCVar ?loc id = CAst.make ?loc @@ CRef (qualid_of_ident ?loc id, None) let rec mkCHoles ?loc n = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 38b26d06b9..fdfba48024 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) rt)); + ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -240,7 +240,7 @@ let strip_unfold_term _ ((sigma, t) as p) kt = match EConstr.kind sigma t with let same_proj sigma t1 t2 = match EConstr.kind sigma t1, EConstr.kind sigma t2 with - | Proj(c1,_), Proj(c2, _) -> Projection.equal c1 c2 + | Proj(c1,_), Proj(c2, _) -> Projection.CanOrd.equal c1 c2 | _ -> false let all_ok _ _ = true diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 7b584b5159..f06b460ee9 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -100,7 +100,7 @@ ARGUMENT EXTEND ssrtacarg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtacarg; - ssrtacarg: [[ tac = tactic_expr LEVEL "5" -> { tac } ]]; + ssrtacarg: [[ tac = ltac_expr LEVEL "5" -> { tac } ]]; END (* Copy of ssrtacarg with LEVEL "3", useful for: "under ... do ..." *) @@ -108,7 +108,7 @@ ARGUMENT EXTEND ssrtac3arg TYPED AS tactic PRINTED BY { pr_ssrtacarg env sigma } END GRAMMAR EXTEND Gram GLOBAL: ssrtac3arg; - ssrtac3arg: [[ tac = tactic_expr LEVEL "3" -> { tac } ]]; + ssrtac3arg: [[ tac = ltac_expr LEVEL "3" -> { tac } ]]; END { @@ -350,7 +350,7 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc (None, []) with - | Constrexpr.Numeral n, _ when NumTok.Signed.is_int n -> + | Constrexpr.Number n, _ when NumTok.Signed.is_int n -> int_of_string (NumTok.Signed.to_string n) | _ -> raise Not_found end @@ -1337,7 +1337,7 @@ ARGUMENT EXTEND ssrbinder TYPED AS (ssrfwdfmt * constr) PRINTED BY { pr_ssrbinde GRAMMAR EXTEND Gram GLOBAL: ssrbinder; ssrbinder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> { + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { (FwdPose, [BFvar]), CAst.make ~loc @@ CLambdaN ([CLocalAssum ([CAst.make ~loc Anonymous],Default Glob_term.Explicit,c)],mkCHole (Some loc)) } ] ]; @@ -1594,18 +1594,18 @@ GRAMMAR EXTEND Gram | n = Prim.natural -> { ArgArg (check_index ~loc n) } ] ]; ssrswap: [[ IDENT "first" -> { loc, true } | IDENT "last" -> { loc, false } ]]; - ssrorelse: [[ "||"; tac = tactic_expr LEVEL "2" -> { tac } ]]; + ssrorelse: [[ "||"; tac = ltac_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) } + | tac = ltac_expr LEVEL "3" -> { noindex, (mk_hint tac, None) } ] ]; END { -let tactic_expr = Pltac.tactic_expr +let ltac_expr = Pltac.ltac_expr } @@ -1688,9 +1688,9 @@ let tclintros_expr ?loc tac ipats = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "1" [ RIGHTA - [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + GLOBAL: ltac_expr; + ltac_expr: LEVEL "1" [ RIGHTA + [ tac = ltac_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } ] ]; END @@ -1704,9 +1704,9 @@ END (* (Removing user-specified parentheses is dubious anyway). *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - ssrparentacarg: [[ "("; tac = tactic_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; - tactic_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; + GLOBAL: ltac_expr; + ssrparentacarg: [[ "("; tac = ltac_expr; ")" -> { CAst.make ~loc (Tacexp tac) } ]]; + ltac_expr: LEVEL "0" [[ arg = ssrparentacarg -> { TacArg arg } ]]; END (** The internal "done" and "ssrautoprop" tactics. *) @@ -1741,7 +1741,7 @@ let tclBY tac = Tacticals.New.tclTHEN tac (donetac ~-1) (* The latter two are used in forward-chaining tactics (have, suffice, wlog) *) (* and subgoal reordering tacticals (; first & ; last), respectively. *) -(* Force use of the tactic_expr parsing entry, to rule out tick marks. *) +(* Force use of the ltac_expr parsing entry, to rule out tick marks. *) (** The "by" tactical. *) @@ -1782,17 +1782,17 @@ let ssrdotac_expr ?loc n m tac clauses = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssrdotac: [ - [ tac = tactic_expr LEVEL "3" -> { mk_hint tac } + [ tac = ltac_expr LEVEL "3" -> { mk_hint tac } | tacs = ssrortacarg -> { tacs } ] ]; - tactic_expr: LEVEL "3" [ RIGHTA + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "do"; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex m tac clauses } | IDENT "do"; tac = ssrortacarg; clauses = ssrclauses -> { ssrdotac_expr ~loc noindex Once tac clauses } - | IDENT "do"; n = int_or_var; m = ssrmmod; + | IDENT "do"; n = nat_or_var; m = ssrmmod; tac = ssrdotac; clauses = ssrclauses -> { ssrdotac_expr ~loc (mk_index ~loc n) m tac clauses } ] ]; @@ -1833,20 +1833,20 @@ let tclseq_expr ?loc tac dir arg = } GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; + GLOBAL: ltac_expr; ssr_first: [ [ tac = ssr_first; ipats = ssrintros_ne -> { tclintros_expr ~loc tac ipats } - | "["; tacl = LIST0 tactic_expr SEP "|"; "]" -> { TacFirst tacl } + | "["; tacl = LIST0 ltac_expr SEP "|"; "]" -> { TacFirst tacl } ] ]; ssr_first_else: [ [ 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 -> + ltac_expr: LEVEL "4" [ LEFTA + [ tac1 = ltac_expr; ";"; IDENT "first"; tac2 = ssr_first_else -> { TacThen (tac1, tac2) } - | tac = tactic_expr; ";"; IDENT "first"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "first"; arg = ssrseqarg -> { tclseq_expr ~loc tac L2R arg } - | tac = tactic_expr; ";"; IDENT "last"; arg = ssrseqarg -> + | tac = ltac_expr; ";"; IDENT "last"; arg = ssrseqarg -> { tclseq_expr ~loc tac R2L arg } ] ]; END @@ -1894,7 +1894,8 @@ let has_occ ((_, occ), _) = occ <> None let gens_sep = function [], [] -> mt | _ -> spc let pr_dgens pr_gen (gensl, clr) = - let prgens s gens = str s ++ pr_list spc pr_gen gens in + let prgens s gens = + if CList.is_empty gens then mt () else str s ++ pr_list spc pr_gen gens in let prdeps deps = prgens ": " deps ++ spc () ++ str "/" in match gensl with | [deps; []] -> prdeps deps ++ pr_clear pr_spc clr @@ -2194,7 +2195,7 @@ END let pr_ssrcongrarg _ _ _ ((n, f), dgens) = (if n <= 0 then mt () else str " " ++ int n) ++ - str " " ++ pr_term f ++ pr_dgens pr_gen dgens + pr_term f ++ pr_dgens pr_gen dgens } @@ -2447,8 +2448,8 @@ END (* The standard TACTIC EXTEND does not work for abstract *) GRAMMAR EXTEND Gram - GLOBAL: tactic_expr; - tactic_expr: LEVEL "3" + GLOBAL: ltac_expr; + ltac_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> { ssrtac_expr ~loc "abstract" [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index e231ab1f87..95c8024e89 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -57,17 +57,16 @@ let pr_guarded guard prc c = let s = Format.flush_str_formatter () ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c -let prl_constr_expr = +let with_global_env_evm f x = let env = Global.env () in let sigma = Evd.from_env env in - Ppconstr.pr_lconstr_expr env sigma -let pr_glob_constr c = Printer.pr_glob_constr_env (Global.env ()) c -let prl_glob_constr c = Printer.pr_lglob_constr_env (Global.env ()) c + f env sigma x + +let prl_constr_expr = with_global_env_evm Ppconstr.pr_lconstr_expr +let pr_glob_constr = with_global_env_evm Printer.pr_glob_constr_env +let prl_glob_constr = with_global_env_evm Printer.pr_lglob_constr_env let pr_glob_constr_and_expr = function - | _, Some c -> - let env = Global.env () in - let sigma = Evd.from_env env in - Ppconstr.pr_constr_expr env sigma c + | _, Some c -> with_global_env_evm Ppconstr.pr_constr_expr c | c, None -> pr_glob_constr c let pr_term (k, c) = pr_guarded (guard_term k) pr_glob_constr_and_expr c @@ -75,11 +74,14 @@ let pr_hyp (SsrHyp (_, id)) = Id.print id let pr_hyps = pr_list pr_spc pr_hyp let pr_occ = function - | Some (true, occ) -> str "{-" ++ pr_list pr_spc int occ ++ str "}" - | Some (false, occ) -> str "{+" ++ pr_list pr_spc int occ ++ str "}" + | Some (true, occ) -> + if CList.is_empty occ then mt () else str "{-" ++ pr_list pr_spc int occ ++ str "}" + | Some (false, occ) -> + if CList.is_empty occ then mt () else str "{+" ++ pr_list pr_spc int occ ++ str "}" | None -> str "{}" -let pr_clear_ne clr = str "{" ++ pr_hyps clr ++ str "}" +let pr_clear_ne clr = + if CList.is_empty clr then mt () else str "{" ++ pr_hyps clr ++ str "}" let pr_clear sep clr = sep () ++ pr_clear_ne clr let pr_dir = function L2R -> str "->" | R2L -> str "<-" diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 91cd5b251c..3e44bd4d3b 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -85,7 +85,7 @@ 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_rtype: [[ "return"; t = term 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 } @@ -96,9 +96,9 @@ GRAMMAR EXTEND Gram 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 -> + [ "if"; c = term LEVEL "200"; "is"; db1 = ssr_dthen; b2 = ssr_else -> { 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 -> + | "if"; c = term LEVEL "200";"isn't";db1 = ssr_dthen; b2 = ssr_else -> { 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 @@ -119,7 +119,7 @@ END GRAMMAR EXTEND Gram GLOBAL: closed_binder; closed_binder: [ - [ ["of" -> { () } | "&" -> { () } ]; c = operconstr LEVEL "99" -> + [ ["of" -> { () } | "&" -> { () } ]; c = term LEVEL "99" -> { [CLocalAssum ([CAst.make ~loc Anonymous], Default Explicit, c)] } ] ]; END @@ -203,8 +203,8 @@ let pr_raw_ssrhintref env sigma prc _ _ = let open CAst in function let pr_rawhintref env sigma c = match DAst.get c with | GApp (f, args) when isRHoles args -> - pr_glob_constr_env env f ++ str "|" ++ int (List.length args) - | _ -> pr_glob_constr_env env c + pr_glob_constr_env env sigma f ++ str "|" ++ int (List.length args) + | _ -> pr_glob_constr_env env sigma c let pr_glob_ssrhintref env sigma _ _ _ (c, _) = pr_rawhintref env sigma c @@ -304,21 +304,6 @@ END { - let warn_search_moved_enabled = ref true - let warn_search_moved = CWarnings.create ~name:"ssr-search-moved" - ~category:"deprecated" ~default:CWarnings.Enabled - (fun () -> - (Pp.strbrk - "In previous versions of Coq, loading SSReflect had the effect of \ - replacing the built-in 'Search' command with an SSReflect version \ - of that command. \ - Coq's own search feature was still available via 'SearchAbout' \ - (but that alias is deprecated). \ - This replacement no longer happens; now 'Search' calls Coq's own search \ - feature even when SSReflect is loaded. \ - If you want to use SSReflect's deprecated Search command \ - instead of the built-in one, please Require the ssrsearch module.")) - open G_vernac } @@ -328,7 +313,6 @@ GRAMMAR EXTEND Gram query_command: [ [ IDENT "Search"; s = search_query; l = search_queries; "." -> { let (sl,m) = l in - if !warn_search_moved_enabled then warn_search_moved (); fun g -> Vernacexpr.VernacSearch (Vernacexpr.Search (s::sl),g, m) } ] ] diff --git a/plugins/ssr/ssrvernac.mli b/plugins/ssr/ssrvernac.mli index 93339313f0..327a2d4660 100644 --- a/plugins/ssr/ssrvernac.mli +++ b/plugins/ssr/ssrvernac.mli @@ -9,5 +9,3 @@ (************************************************************************) (* This file is (C) Copyright 2006-2015 Microsoft Corporation and Inria. *) - -val warn_search_moved_enabled : bool ref diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index d99ead139d..97926753f5 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -195,7 +195,7 @@ let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in Ssrprinters.ppdebug (lazy - Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env glob)); + Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in Ssrprinters.ppdebug (lazy @@ -205,7 +205,7 @@ let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in Ssrprinters.ppdebug (lazy - Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env glob)); + Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index cdd15acb0d..ea014250ca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -88,8 +88,12 @@ let pr_guarded guard prc c = let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) -let prl_glob_constr c = pr_lglob_constr_env (Global.env ()) c -let pr_glob_constr c = pr_glob_constr_env (Global.env ()) c +let with_global_env_evm f x = + let env = Global.env () in + let sigma = Evd.from_env env in + f env sigma x +let prl_glob_constr = with_global_env_evm pr_lglob_constr_env +let pr_glob_constr = with_global_env_evm pr_glob_constr_env let prl_constr_expr = pr_lconstr_expr let pr_constr_expr = pr_constr_expr let prl_glob_constr_and_expr env sigma = function @@ -454,7 +458,7 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = - List.length (snd (lookup_canonical_conversion (GlobRef.ConstRef pc, k))).o_TCOMPS in + List.length (snd (lookup_canonical_conversion (Global.env()) (GlobRef.ConstRef pc, k))).o_TCOMPS in let nargs_of_proj t = match kind t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be @@ -463,8 +467,8 @@ let nb_cs_proj_args pc f u = try match kind f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (Sorts.family s)) - | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f - | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f + | Const (c',_) when Constant.CanOrd.equal c' pc -> nargs_of_proj u.up_f + | Proj (c',_) when Constant.CanOrd.equal (Projection.constant c') pc -> nargs_of_proj u.up_f | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 @@ -508,7 +512,7 @@ let filter_upat i0 f n u fpats = let () = if !i0 < np then i0 := n in (u, np) :: fpats let eq_prim_proj c t = match kind t with - | Proj(p,_) -> Constant.equal (Projection.constant p) c + | Proj(p,_) -> Constant.CanOrd.equal (Projection.constant p) c | _ -> false let filter_upat_FO i0 f n u fpats = diff --git a/plugins/ssrsearch/g_search.mlg b/plugins/ssrsearch/g_search.mlg index 5e002e09cc..74535a10d3 100644 --- a/plugins/ssrsearch/g_search.mlg +++ b/plugins/ssrsearch/g_search.mlg @@ -141,7 +141,7 @@ let interp_search_notation ?loc tag okey = let rec sub () = function | NVar x when List.mem_assoc x nvars -> DAst.make ?loc @@ GPatVar (FirstOrderPatVar x) | c -> - glob_constr_of_notation_constr_with_binders ?loc (fun _ x -> (), None, x) sub () c in + glob_constr_of_notation_constr_with_binders ?loc (fun _ x t -> (), None, x, Explicit, t) sub () c in let _, npat = Patternops.pattern_of_glob_constr (sub () body) in Search.GlobSearchSubPattern (Vernacexpr.Anywhere,false,npat) @@ -301,10 +301,6 @@ let ssrdisplaysearch gr env t = let pr_res = pr_global gr ++ str ":" ++ spc () ++ pr_lconstr_env env Evd.empty t in Feedback.msg_notice (hov 2 pr_res ++ fnl ()) -(* Remove the warning entirely when this plugin is loaded. *) -let _ = - Ssreflect_plugin.Ssrvernac.warn_search_moved_enabled := false - let deprecated_search = CWarnings.create ~name:"deprecated-ssr-search" diff --git a/plugins/syntax/dune b/plugins/syntax/dune index b395695c8a..f930fc265a 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -1,22 +1,8 @@ (library - (name numeral_notation_plugin) - (public_name coq.plugins.numeral_notation) - (synopsis "Coq numeral notation plugin") - (modules g_numeral numeral) - (libraries coq.vernac)) - -(library - (name string_notation_plugin) - (public_name coq.plugins.string_notation) - (synopsis "Coq string notation plugin") - (modules g_string string_notation) - (libraries coq.vernac)) - -(library - (name r_syntax_plugin) - (public_name coq.plugins.r_syntax) - (synopsis "Coq syntax plugin: reals") - (modules r_syntax) + (name number_string_notation_plugin) + (public_name coq.plugins.number_string_notation) + (synopsis "Coq number and string notation plugin") + (modules g_number_string string_notation number) (libraries coq.vernac)) (library @@ -33,4 +19,4 @@ (modules float_syntax) (libraries coq.vernac)) -(coq.pp (modules g_numeral g_string)) +(coq.pp (modules g_number_string)) diff --git a/plugins/syntax/g_number_string.mlg b/plugins/syntax/g_number_string.mlg new file mode 100644 index 0000000000..c8badd238d --- /dev/null +++ b/plugins/syntax/g_number_string.mlg @@ -0,0 +1,110 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +DECLARE PLUGIN "number_string_notation_plugin" + +{ + +open Notation +open Number +open String_notation +open Pp +open Names +open Stdarg +open Pcoq.Prim + +let pr_number_after = function + | Nop -> mt () + | Warning n -> str "warning after " ++ NumTok.UnsignedNat.print n + | Abstract n -> str "abstract after " ++ NumTok.UnsignedNat.print n + +let pr_deprecated_number_modifier m = str "(" ++ pr_number_after m ++ str ")" + +let warn_deprecated_numeral_notation = + CWarnings.create ~name:"numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Numeral Notation is deprecated, please use Number Notation instead.") + +let pr_number_string_mapping (b, n, n') = + if b then + str "[" ++ Libnames.pr_qualid n ++ str "]" ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + else + Libnames.pr_qualid n ++ spc () ++ str "=>" ++ spc () + ++ Libnames.pr_qualid n' + +let pr_number_string_via (n, l) = + str "via " ++ Libnames.pr_qualid n ++ str " mapping [" + ++ prlist_with_sep pr_comma pr_number_string_mapping l ++ str "]" + +let pr_number_modifier = function + | After a -> pr_number_after a + | Via nl -> pr_number_string_via nl + +let pr_number_options l = + str "(" ++ prlist_with_sep pr_comma pr_number_modifier l ++ str ")" + +let pr_string_option l = + str "(" ++ pr_number_string_via l ++ str ")" + +} + +VERNAC ARGUMENT EXTEND deprecated_number_modifier + PRINTED BY { pr_deprecated_number_modifier } +| [ ] -> { Nop } +| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } +| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } +END + +VERNAC ARGUMENT EXTEND number_string_mapping + PRINTED BY { pr_number_string_mapping } +| [ reference(n) "=>" reference(n') ] -> { false, n, n' } +| [ "[" reference(n) "]" "=>" reference(n') ] -> { true, n, n' } +END + +VERNAC ARGUMENT EXTEND number_string_via + PRINTED BY { pr_number_string_via } +| [ "via" reference(n) "mapping" "[" ne_number_string_mapping_list_sep(l, ",") "]" ] -> { n, l } +END + +VERNAC ARGUMENT EXTEND number_modifier + PRINTED BY { pr_number_modifier } +| [ "warning" "after" bignat(waft) ] -> { After (Warning (NumTok.UnsignedNat.of_string waft)) } +| [ "abstract" "after" bignat(n) ] -> { After (Abstract (NumTok.UnsignedNat.of_string n)) } +| [ number_string_via(v) ] -> { Via v } +END + +VERNAC ARGUMENT EXTEND number_options + PRINTED BY { pr_number_options } +| [ "(" ne_number_modifier_list_sep(l, ",") ")" ] -> { l } +END + +VERNAC ARGUMENT EXTEND string_option + PRINTED BY { pr_string_option } +| [ "(" number_string_via(v) ")" ] -> { v } +END + +VERNAC COMMAND EXTEND NumberNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) number_options_opt(nl) ":" + ident(sc) ] -> + + { vernac_number_notation (Locality.make_module_locality locality) ty f g (Option.default [] nl) (Id.to_string sc) } + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) deprecated_number_modifier(o) ] -> + + { warn_deprecated_numeral_notation (); + vernac_number_notation (Locality.make_module_locality locality) ty f g [After o] (Id.to_string sc) } +END + +VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF + | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) string_option_opt(o) ":" + ident(sc) ] -> + { vernac_string_notation (Locality.make_module_locality locality) ty f g o (Id.to_string sc) } +END diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg deleted file mode 100644 index c030925ea9..0000000000 --- a/plugins/syntax/g_numeral.mlg +++ /dev/null @@ -1,51 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "numeral_notation_plugin" - -{ - -open Notation -open Numeral -open Pp -open Names -open Stdarg -open Pcoq.Prim - -let pr_numnot_option = function - | Nop -> mt () - | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" - | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" - -let warn_deprecated_numeral_notation = - CWarnings.create ~name:"numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Numeral Notation is deprecated, please use Number Notation instead.") - -} - -VERNAC ARGUMENT EXTEND numnotoption - PRINTED BY { pr_numnot_option } -| [ ] -> { Nop } -| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } -| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } -END - -VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> - - { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) numnotoption(o) ] -> - - { warn_deprecated_numeral_notation (); - vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } -END diff --git a/plugins/syntax/g_string.mlg b/plugins/syntax/g_string.mlg deleted file mode 100644 index 788f9e011d..0000000000 --- a/plugins/syntax/g_string.mlg +++ /dev/null @@ -1,25 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -DECLARE PLUGIN "string_notation_plugin" - -{ - -open String_notation -open Names -open Stdarg - -} - -VERNAC COMMAND EXTEND StringNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "String" "Notation" reference(ty) reference(f) reference(g) ":" - ident(sc) ] -> - { vernac_string_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) } -END diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml index 494500ca25..110b26581f 100644 --- a/plugins/syntax/int63_syntax.ml +++ b/plugins/syntax/int63_syntax.ml @@ -43,6 +43,7 @@ let _ = let id_int63 = Nametab.locate q_id_int63 in let o = { to_kind = Int63, Direct; to_ty = id_int63; + to_post = [||]; of_kind = Int63, Direct; of_ty = id_int63; ty_name = q_int63; @@ -50,7 +51,7 @@ let _ = enable_prim_token_interpretation { pt_local = false; pt_scope = int63_scope; - pt_interp_info = NumeralNotation o; + pt_interp_info = NumberNotation o; pt_required = (int63_path, int63_module); pt_refs = []; pt_in_match = false }) diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml new file mode 100644 index 0000000000..89d757a72a --- /dev/null +++ b/plugins/syntax/number.ml @@ -0,0 +1,505 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp +open Util +open Names +open Libnames +open Constrexpr +open Constrexpr_ops +open Notation + +module CSet = CSet.Make (Constr) +module CMap = CMap.Make (Constr) + +(** * Number notation *) + +type number_string_via = qualid * (bool * qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + +let warn_abstract_large_num_no_op = + CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" + (fun f -> + strbrk "The 'abstract after' directive has no effect when " ++ + strbrk "the parsing function (" ++ + Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ + strbrk "option type.") + +let get_constructors ind = + let mib,oib = Global.lookup_inductive ind in + let mc = oib.Declarations.mind_consnames in + Array.to_list + (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) + +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_option () = qualid_of_ref "core.option.type" + +let unsafe_locate_ind q = + match Nametab.locate q with + | GlobRef.IndRef i -> i + | _ -> raise Not_found + +let locate_z () = + let zn = "num.Z.type" in + let pn = "num.pos.type" in + if Coqlib.has_ref zn && Coqlib.has_ref pn + then + let q_z = qualid_of_ref zn in + let q_pos = qualid_of_ref pn in + Some ({ + z_ty = unsafe_locate_ind q_z; + pos_ty = unsafe_locate_ind q_pos; + }, mkRefC q_z) + else None + +let locate_number () = + let dint = "num.int.type" in + let duint = "num.uint.type" in + let dec = "num.decimal.type" in + let hint = "num.hexadecimal_int.type" in + let huint = "num.hexadecimal_uint.type" in + let hex = "num.hexadecimal.type" in + let int = "num.num_int.type" in + let uint = "num.num_uint.type" in + let num = "num.number.type" in + if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec + && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex + && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num + then + let q_dint = qualid_of_ref dint in + let q_duint = qualid_of_ref duint in + let q_dec = qualid_of_ref dec in + let q_hint = qualid_of_ref hint in + let q_huint = qualid_of_ref huint in + let q_hex = qualid_of_ref hex in + let q_int = qualid_of_ref int in + let q_uint = qualid_of_ref uint in + let q_num = qualid_of_ref num in + let int_ty = { + dec_int = unsafe_locate_ind q_dint; + dec_uint = unsafe_locate_ind q_duint; + hex_int = unsafe_locate_ind q_hint; + hex_uint = unsafe_locate_ind q_huint; + int = unsafe_locate_ind q_int; + uint = unsafe_locate_ind q_uint; + } in + let num_ty = { + int = int_ty; + decimal = unsafe_locate_ind q_dec; + hexadecimal = unsafe_locate_ind q_hex; + number = unsafe_locate_ind q_num; + } in + Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, + num_ty, mkRefC q_num, mkRefC q_dec) + else None + +let locate_int63 () = + let int63n = "num.int63.type" in + if Coqlib.has_ref int63n + then + let q_int63 = qualid_of_ref int63n in + Some (mkRefC q_int63) + else None + +let has_type env sigma f ty = + let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in + try let _ = Constrintern.interp_constr env sigma c in true + with Pretype_errors.PretypeError _ -> false + +let type_error_to f ty = + CErrors.user_err + (pr_qualid f ++ str " should go from Number.int to " ++ + pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let type_error_of g ty = + CErrors.user_err + (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ + str " to Number.int or (option Number.int)." ++ fnl () ++ + str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + +let warn_deprecated_decimal = + CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Deprecated Number Notation for Decimal.uint, \ + Decimal.int or Decimal.decimal. Use Number.uint, \ + Number.int or Number.number respectively.") + +let error_params ind = + CErrors.user_err + (str "Wrong number of parameters for inductive" ++ spc () + ++ Printer.pr_global (GlobRef.IndRef ind) ++ str ".") + +let remapping_error ?loc ty ty' ty'' = + CErrors.user_err ?loc + (Printer.pr_global ty + ++ str " was already mapped to" ++ spc () ++ Printer.pr_global ty' + ++ str " and cannot be remapped to" ++ spc () ++ Printer.pr_global ty'' + ++ str ".") + +let error_missing c = + CErrors.user_err + (str "Missing mapping for constructor " ++ Printer.pr_global c ++ str ".") + +let pr_constr env sigma c = + let c = Constrextern.extern_constr env sigma (EConstr.of_constr c) in + Ppconstr.pr_constr_expr env sigma c + +let warn_via_remapping = + CWarnings.create ~name:"via-type-remapping" ~category:"numbers" + (fun (env, sigma, ty, ty', ty'') -> + let constr = pr_constr env sigma in + constr ty ++ str " was already mapped to" ++ spc () ++ constr ty' + ++ str ", mapping it also to" ++ spc () ++ constr ty'' + ++ str " might yield ill typed terms when using the notation.") + +let warn_via_type_mismatch = + CWarnings.create ~name:"via-type-mismatch" ~category:"numbers" + (fun (env, sigma, g, g', exp, actual) -> + let constr = pr_constr env sigma in + str "Type of" ++ spc() ++ Printer.pr_global g + ++ str " seems incompatible with the type of" ++ spc () + ++ Printer.pr_global g' ++ str "." ++ spc () + ++ str "Expected type is: " ++ constr exp ++ spc () + ++ str "instead of " ++ constr actual ++ str "." ++ spc () + ++ str "This might yield ill typed terms when using the notation.") + +let multiple_via_error () = + CErrors.user_err (Pp.str "Multiple 'via' options.") + +let multiple_after_error () = + CErrors.user_err (Pp.str "Multiple 'warning after' or 'abstract after' options.") + +let via_abstract_error () = + CErrors.user_err (Pp.str "'via' and 'abstract' cannot be used together.") + +let locate_global_sort_inductive_or_constant sigma qid = + let locate_sort qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.NSort r -> + let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family r) in + sigma,Constr.mkSort c + | _ -> raise Not_found in + try locate_sort qid + with Not_found -> + match Smartlocate.global_with_alias qid with + | GlobRef.IndRef i -> sigma, Constr.mkInd i + | _ -> sigma, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +let locate_global_constructor_inductive_or_constant qid = + let g = Smartlocate.global_with_alias qid in + match g with + | GlobRef.ConstructRef c -> g, Constr.mkConstruct c + | GlobRef.IndRef i -> g, Constr.mkInd i + | _ -> g, Constr.mkConst (Smartlocate.global_constant_with_alias qid) + +(* [get_type env sigma c] retrieves the type of [c] and returns a pair + [l, t] such that [c : l_0 -> ... -> l_n -> t]. *) +let get_type env sigma c = + (* inspired from [compute_implicit_names] in "interp/impargs.ml" *) + let rec aux env acc t = + let t = Reductionops.whd_all env sigma t in + match EConstr.kind sigma t with + | Constr.Prod (na, a, b) -> + let a = Reductionops.whd_all env sigma a in + let rel = Context.Rel.Declaration.LocalAssum (na, a) in + aux (EConstr.push_rel rel env) ((na, a) :: acc) b + | _ -> List.rev acc, t in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let l, t = aux env [] t in + List.map (fun (na, a) -> na, EConstr.Unsafe.to_constr a) l, + EConstr.Unsafe.to_constr t + +(* [elaborate_to_post_params env sigma ty_ind params] builds the + [to_post] translation (c.f., interp/notation.mli) for the numeral + notation to parse/print type [ty_ind]. This translation is the + identity ([ToPostCopy]) except that it checks ([ToPostCheck]) that + the parameters of the inductive type [ty_ind] match the ones given + in [params]. *) +let elaborate_to_post_params env sigma ty_ind params = + let to_post_for_constructor indc = + let sigma, c = match indc with + | GlobRef.ConstructRef c -> + let sigma,c = Evd.fresh_constructor_instance env sigma c in + sigma, Constr.mkConstructU c + | _ -> assert false in (* c.f. get_constructors *) + let args, t = get_type env sigma c in + let params_indc = match Constr.kind t with + | Constr.App (_, a) -> Array.to_list a | _ -> [] in + let sz = List.length args in + let a = Array.make sz ToPostCopy in + if List.length params <> List.length params_indc then error_params ty_ind; + List.iter2 (fun param param_indc -> + match param, Constr.kind param_indc with + | Some p, Constr.Rel i when i <= sz -> a.(sz - i) <- ToPostCheck p + | _ -> ()) + params params_indc; + indc, indc, Array.to_list a in + let pt_refs = get_constructors ty_ind in + let to_post_0 = List.map to_post_for_constructor pt_refs in + let to_post = + let only_copy (_, _, args) = List.for_all ((=) ToPostCopy) args in + if (List.for_all only_copy to_post_0) then [||] else [|to_post_0|] in + to_post, pt_refs + +(* [elaborate_to_post_via env sigma ty_name ty_ind l] builds the [to_post] + translation (c.f., interp/notation.mli) for the number notation to + parse/print type [ty_name] through the inductive [ty_ind] according + to the pairs [constant, constructor] in the list [l]. *) +let elaborate_to_post_via env sigma ty_name ty_ind l = + let sigma, ty_name = + locate_global_sort_inductive_or_constant sigma ty_name in + let ty_ind = Constr.mkInd ty_ind in + (* Retrieve constants and constructors mappings and their type. + For each constant [cnst] and inductive constructor [indc] in [l], retrieve: + * its location: [lcnst] and [lindc] + * its GlobRef: [cnst] and [indc] + * its type: [tcnst] and [tindc] (decomposed in product by [get_type] above) + * [impls] are the implicit arguments of [cnst] *) + let l = + let read (consider_implicits, cnst, indc) = + let lcnst, lindc = cnst.CAst.loc, indc.CAst.loc in + let cnst, ccnst = locate_global_constructor_inductive_or_constant cnst in + let indc, cindc = + let indc = Smartlocate.global_constructor_with_alias indc in + GlobRef.ConstructRef indc, Constr.mkConstruct indc in + let get_type_wo_params c = + (* ignore parameters of inductive types *) + let rm_params c = match Constr.kind c with + | Constr.App (c, _) when Constr.isInd c -> c + | _ -> c in + let lc, tc = get_type env sigma c in + List.map (fun (n, c) -> n, rm_params c) lc, rm_params tc in + let tcnst, tindc = get_type_wo_params ccnst, get_type_wo_params cindc in + let impls = + if not consider_implicits then [] else + Impargs.(select_stronger_impargs (implicits_of_global cnst)) in + lcnst, cnst, tcnst, lindc, indc, tindc, impls in + List.map read l in + let eq_indc indc (_, _, _, _, indc', _, _) = GlobRef.equal indc indc' in + (* Collect all inductive types involved. + That is [ty_ind] and all final codomains of [tindc] above. *) + let inds = + List.fold_left (fun s (_, _, _, _, _, tindc, _) -> CSet.add (snd tindc) s) + (CSet.singleton ty_ind) l in + (* And for each inductive, retrieve its constructors. *) + let constructors = + CSet.fold (fun ind m -> + let inductive, _ = Constr.destInd ind in + CMap.add ind (get_constructors inductive) m) + inds CMap.empty in + (* Error if one [constructor] in some inductive in [inds] + doesn't appear exactly once in [l] *) + let _ = (* check_for duplicate constructor and error *) + List.fold_left (fun already_seen (_, cnst, _, loc, indc, _, _) -> + try + let cnst' = List.assoc_f GlobRef.equal indc already_seen in + remapping_error ?loc indc cnst' cnst + with Not_found -> (indc, cnst) :: already_seen) + [] l in + let () = (* check for missing constructor and error *) + CMap.iter (fun _ -> + List.iter (fun cstr -> + if not (List.exists (eq_indc cstr) l) then error_missing cstr)) + constructors in + (* Perform some checks on types and warn if they look strange. + These checks are neither sound nor complete, so we only warn. *) + let () = + (* associate inductives to types, and check that this mapping is one to one + and maps [ty_ind] to [ty_name] *) + let ind2ty, ty2ind = + let add loc ckey cval m = + match CMap.find_opt ckey m with + | None -> CMap.add ckey cval m + | Some old_cval -> + if not (Constr.equal old_cval cval) then + warn_via_remapping ?loc (env, sigma, ckey, old_cval, cval); + m in + List.fold_left + (fun (ind2ty, ty2ind) (lcnst, _, (_, tcnst), lindc, _, (_, tindc), _) -> + add lcnst tindc tcnst ind2ty, add lindc tcnst tindc ty2ind) + CMap.(singleton ty_ind ty_name, singleton ty_name ty_ind) l in + (* check that type of constants and constructors mapped in [l] + match modulo [ind2ty] *) + let rm_impls impls (l, t) = + let rec aux impls l = match impls, l with + | Some _ :: impls, _ :: b -> aux impls b + | None :: impls, (n, a) :: b -> (n, a) :: aux impls b + | _ -> l in + aux impls l, t in + let replace m (l, t) = + let apply_m c = try CMap.find c m with Not_found -> c in + List.fold_right (fun (na, a) b -> Constr.mkProd (na, (apply_m a), b)) + l (apply_m t) in + List.iter (fun (_, cnst, tcnst, loc, indc, tindc, impls) -> + let tcnst = rm_impls impls tcnst in + let tcnst' = replace CMap.empty tcnst in + if not (Constr.equal tcnst' (replace ind2ty tindc)) then + let actual = replace CMap.empty tindc in + let expected = replace ty2ind tcnst in + warn_via_type_mismatch ?loc (env, sigma, indc, cnst, expected, actual)) + l in + (* Associate an index to each inductive, starting from 0 for [ty_ind]. *) + let ind2num, num2ind, nb_ind = + CMap.fold (fun ind _ (ind2num, num2ind, i) -> + CMap.add ind i ind2num, Int.Map.add i ind num2ind, i + 1) + (CMap.remove ty_ind constructors) + (CMap.singleton ty_ind 0, Int.Map.singleton 0 ty_ind, 1) in + (* Finally elaborate [to_post] *) + let to_post = + let rec map_prod impls tindc = match impls with + | Some _ :: impls -> ToPostHole :: map_prod impls tindc + | _ -> + match tindc with + | [] -> [] + | (_, a) :: b -> + let t = match CMap.find_opt a ind2num with + | Some i -> ToPostAs i + | None -> ToPostCopy in + let impls = match impls with [] -> [] | _ :: t -> t in + t :: map_prod impls b in + Array.init nb_ind (fun i -> + List.map (fun indc -> + let _, cnst, _, _, _, tindc, impls = List.find (eq_indc indc) l in + indc, cnst, map_prod impls (fst tindc)) + (CMap.find (Int.Map.find i num2ind) constructors)) in + (* and use constants mapped to constructors of [ty_ind] as triggers. *) + let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in + to_post, pt_refs + +let locate_global_inductive allow_params qid = + let locate_param_inductive qid = + match Nametab.locate_extended qid with + | Globnames.TrueGlobal _ -> raise Not_found + | Globnames.SynDef kn -> + match Syntax_def.search_syntactic_definition kn with + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i), l)) when allow_params -> + i, + List.map (function + | Notation_term.NRef r -> Some r + | Notation_term.NHole _ -> None + | _ -> raise Not_found) l + | _ -> raise Not_found in + try locate_param_inductive qid + with Not_found -> Smartlocate.global_inductive_with_alias qid, [] + +let vernac_number_notation local ty f g opts scope = + let rec parse_opts = function + | [] -> None, Nop + | h :: opts -> + let via, opts = parse_opts opts in + let via = match h, via with + | Via _, Some _ -> multiple_via_error () + | Via v, None -> Some v + | _ -> via in + let opts = match h, opts with + | After _, (Warning _ | Abstract _) -> multiple_after_error () + | After a, Nop -> a + | _ -> opts in + via, opts in + let via, opts = parse_opts opts in + (match via, opts with Some _, Abstract _ -> via_abstract_error () | _ -> ()); + let env = Global.env () in + let sigma = Evd.from_env env in + let num_ty = locate_number () in + let z_pos_ty = locate_z () in + let int63_ty = locate_int63 () in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in + let to_ty = Smartlocate.global_with_alias f in + let of_ty = Smartlocate.global_with_alias g in + let cty = mkRefC ty in + let app x y = mkAppC (x,[y]) in + let arrow x y = + mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) + in + let opt r = app (mkRefC (q_option ())) r in + (* Check the type of f *) + let to_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct + | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option + | _ -> type_error_to f ty + in + (* Check the type of g *) + let of_kind = + match num_ty with + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct + | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct + | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct + | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct + | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct + | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct + | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option + | _ -> + match z_pos_ty with + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct + | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option + | _ -> + match int63_ty with + | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct + | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option + | _ -> type_error_of g ty + in + (match to_kind, of_kind with + | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ + | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> + warn_deprecated_decimal () + | _ -> ()); + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; + warning = opts } + in + (match opts, to_kind with + | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty + | _ -> ()); + let i = + { pt_local = local; + pt_scope = scope; + pt_interp_info = NumberNotation o; + pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; + pt_refs; + pt_in_match = true } + in + enable_prim_token_interpretation i diff --git a/plugins/syntax/number.mli b/plugins/syntax/number.mli new file mode 100644 index 0000000000..d7d28b29ed --- /dev/null +++ b/plugins/syntax/number.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Libnames +open Vernacexpr +open Notation + +(** * Number notation *) + +type number_string_via = qualid * (bool * qualid * qualid) list +type number_option = + | After of numnot_option + | Via of number_string_via + +val vernac_number_notation : locality_flag -> + qualid -> + qualid -> qualid -> + number_option list -> + Notation_term.scope_name -> unit + +(** These are also used in string notations *) +val locate_global_inductive : bool -> Libnames.qualid -> Names.inductive * Names.GlobRef.t option list +val elaborate_to_post_params : Environ.env -> Evd.evar_map -> Names.inductive -> Names.GlobRef.t option list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list +val elaborate_to_post_via : Environ.env -> Evd.evar_map -> Libnames.qualid -> Names.inductive -> (bool * Libnames.qualid * Libnames.qualid) list -> (Names.GlobRef.t * Names.GlobRef.t * Notation.to_post_arg list) list array * Names.GlobRef.t list diff --git a/plugins/syntax/number_string_notation_plugin.mlpack b/plugins/syntax/number_string_notation_plugin.mlpack new file mode 100644 index 0000000000..74c32d3a53 --- /dev/null +++ b/plugins/syntax/number_string_notation_plugin.mlpack @@ -0,0 +1,3 @@ +Number +String_notation +G_number_string diff --git a/plugins/syntax/numeral.ml b/plugins/syntax/numeral.ml deleted file mode 100644 index 2db76719b8..0000000000 --- a/plugins/syntax/numeral.ml +++ /dev/null @@ -1,217 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Pp -open Util -open Names -open Libnames -open Constrexpr -open Constrexpr_ops -open Notation - -(** * Numeral notation *) - -let warn_abstract_large_num_no_op = - CWarnings.create ~name:"abstract-large-number-no-op" ~category:"numbers" - (fun f -> - strbrk "The 'abstract after' directive has no effect when " ++ - strbrk "the parsing function (" ++ - Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ") targets an " ++ - strbrk "option type.") - -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - -let qualid_of_ref n = - n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty - -let q_option () = qualid_of_ref "core.option.type" - -let unsafe_locate_ind q = - match Nametab.locate q with - | GlobRef.IndRef i -> i - | _ -> raise Not_found - -let locate_z () = - let zn = "num.Z.type" in - let pn = "num.pos.type" in - if Coqlib.has_ref zn && Coqlib.has_ref pn - then - let q_z = qualid_of_ref zn in - let q_pos = qualid_of_ref pn in - Some ({ - z_ty = unsafe_locate_ind q_z; - pos_ty = unsafe_locate_ind q_pos; - }, mkRefC q_z) - else None - -let locate_numeral () = - let dint = "num.int.type" in - let duint = "num.uint.type" in - let dec = "num.decimal.type" in - let hint = "num.hexadecimal_int.type" in - let huint = "num.hexadecimal_uint.type" in - let hex = "num.hexadecimal.type" in - let int = "num.num_int.type" in - let uint = "num.num_uint.type" in - let num = "num.numeral.type" in - if Coqlib.has_ref dint && Coqlib.has_ref duint && Coqlib.has_ref dec - && Coqlib.has_ref hint && Coqlib.has_ref huint && Coqlib.has_ref hex - && Coqlib.has_ref int && Coqlib.has_ref uint && Coqlib.has_ref num - then - let q_dint = qualid_of_ref dint in - let q_duint = qualid_of_ref duint in - let q_dec = qualid_of_ref dec in - let q_hint = qualid_of_ref hint in - let q_huint = qualid_of_ref huint in - let q_hex = qualid_of_ref hex in - let q_int = qualid_of_ref int in - let q_uint = qualid_of_ref uint in - let q_num = qualid_of_ref num in - let int_ty = { - dec_int = unsafe_locate_ind q_dint; - dec_uint = unsafe_locate_ind q_duint; - hex_int = unsafe_locate_ind q_hint; - hex_uint = unsafe_locate_ind q_huint; - int = unsafe_locate_ind q_int; - uint = unsafe_locate_ind q_uint; - } in - let num_ty = { - int = int_ty; - decimal = unsafe_locate_ind q_dec; - hexadecimal = unsafe_locate_ind q_hex; - numeral = unsafe_locate_ind q_num; - } in - Some (int_ty, mkRefC q_int, mkRefC q_uint, mkRefC q_dint, mkRefC q_duint, - num_ty, mkRefC q_num, mkRefC q_dec) - else None - -let locate_int63 () = - let int63n = "num.int63.type" in - if Coqlib.has_ref int63n - then - let q_int63 = qualid_of_ref int63n in - Some (mkRefC q_int63) - else None - -let has_type env sigma f ty = - let c = mkCastC (mkRefC f, Glob_term.CastConv ty) in - try let _ = Constrintern.interp_constr env sigma c in true - with Pretype_errors.PretypeError _ -> false - -let type_error_to f ty = - CErrors.user_err - (pr_qualid f ++ str " should go from Numeral.int to " ++ - pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") - -let type_error_of g ty = - CErrors.user_err - (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ - str " to Numeral.int or (option Numeral.int)." ++ fnl () ++ - str "Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first).") - -let warn_deprecated_decimal = - CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Deprecated Numeral Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Numeral.uint, \ - Numeral.int or Numeral.numeral respectively.") - -let vernac_numeral_notation local ty f g scope opts = - let env = Global.env () in - let sigma = Evd.from_env env in - let num_ty = locate_numeral () in - let z_pos_ty = locate_z () in - let int63_ty = locate_int63 () in - let tyc = Smartlocate.global_inductive_with_alias ty in - let to_ty = Smartlocate.global_with_alias f in - let of_ty = Smartlocate.global_with_alias g in - let cty = mkRefC ty in - let app x y = mkAppC (x,[y]) in - let arrow x y = - mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) - in - let opt r = app (mkRefC (q_option ())) r in - let constructors = get_constructors tyc in - (* Check the type of f *) - let to_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint cty) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint cty) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Numeral num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option - | _ -> type_error_to f ty - in - (* Check the type of g *) - let of_kind = - match num_ty with - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct - | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> Int int_ty, Option - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty cuint) -> UInt int_ty, Direct - | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Numeral num_ty, Direct - | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Numeral num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option - | _ -> - match z_pos_ty with - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct - | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option - | _ -> - match int63_ty with - | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option - | _ -> type_error_of g ty - in - (match to_kind, of_kind with - | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ - | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> - warn_deprecated_decimal () - | _ -> ()); - let o = { to_kind; to_ty; of_kind; of_ty; - ty_name = ty; - warning = opts } - in - (match opts, to_kind with - | Abstract _, (_, Option) -> warn_abstract_large_num_no_op o.to_ty - | _ -> ()); - let i = - { pt_local = local; - pt_scope = scope; - pt_interp_info = NumeralNotation o; - pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; - pt_in_match = true } - in - enable_prim_token_interpretation i diff --git a/plugins/syntax/numeral.mli b/plugins/syntax/numeral.mli deleted file mode 100644 index 99252484b4..0000000000 --- a/plugins/syntax/numeral.mli +++ /dev/null @@ -1,19 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Libnames -open Vernacexpr -open Notation - -(** * Numeral notation *) - -val vernac_numeral_notation : locality_flag -> - qualid -> qualid -> qualid -> - Notation_term.scope_name -> numnot_option -> unit diff --git a/plugins/syntax/numeral_notation_plugin.mlpack b/plugins/syntax/numeral_notation_plugin.mlpack deleted file mode 100644 index f4d9cae3ff..0000000000 --- a/plugins/syntax/numeral_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Numeral -G_numeral diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml deleted file mode 100644 index d66b9537b4..0000000000 --- a/plugins/syntax/r_syntax.ml +++ /dev/null @@ -1,214 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -open Util -open Names -open Glob_term - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "r_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -exception Non_closed_number - -(**********************************************************************) -(* Parsing positive via scopes *) -(**********************************************************************) - -let binnums = ["Coq";"Numbers";"BinNums"] - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let is_gr c gr = match DAst.get c with -| GRef (r, _) -> GlobRef.equal r gr -| _ -> false - -let positive_modpath = MPfile (make_dir binnums) - -let positive_kn = MutInd.make2 positive_modpath (Label.make "positive") -let path_of_xI = ((positive_kn,0),1) -let path_of_xO = ((positive_kn,0),2) -let path_of_xH = ((positive_kn,0),3) -let glob_xI = GlobRef.ConstructRef path_of_xI -let glob_xO = GlobRef.ConstructRef path_of_xO -let glob_xH = GlobRef.ConstructRef path_of_xH - -let pos_of_bignat ?loc x = - let ref_xI = DAst.make @@ GRef (glob_xI, None) in - let ref_xH = DAst.make @@ GRef (glob_xH, None) in - let ref_xO = DAst.make @@ GRef (glob_xO, None) in - let rec pos_of x = - match Z.(div_rem x (of_int 2)) with - | (q,rem) when rem = Z.zero -> DAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,_) when not Z.(equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) - | (q,_) -> ref_xH - in - pos_of x - -(**********************************************************************) -(* Printing positive via scopes *) -(**********************************************************************) - -let rec bignat_of_pos c = match DAst.get c with - | GApp (r, [a]) when is_gr r glob_xO -> Z.mul Z.(of_int 2) (bignat_of_pos a) - | GApp (r, [a]) when is_gr r glob_xI -> Z.add Z.one Z.(mul (of_int 2) (bignat_of_pos a)) - | GRef (a, _) when GlobRef.equal a glob_xH -> Z.one - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing Z via scopes *) -(**********************************************************************) - -let z_kn = MutInd.make2 positive_modpath (Label.make "Z") -let path_of_ZERO = ((z_kn,0),1) -let path_of_POS = ((z_kn,0),2) -let path_of_NEG = ((z_kn,0),3) -let glob_ZERO = GlobRef.ConstructRef path_of_ZERO -let glob_POS = GlobRef.ConstructRef path_of_POS -let glob_NEG = GlobRef.ConstructRef path_of_NEG - -let z_of_int ?loc n = - if not Z.(equal n zero) then - let sgn, n = - if Z.(leq zero n) then glob_POS, n else glob_NEG, Z.neg n in - DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) - else - DAst.make @@ GRef (glob_ZERO, None) - -(**********************************************************************) -(* Printing Z via scopes *) -(**********************************************************************) - -let bigint_of_z c = match DAst.get c with - | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r,[a]) when is_gr r glob_NEG -> Z.neg (bignat_of_pos a) - | GRef (a, _) when GlobRef.equal a glob_ZERO -> Z.zero - | _ -> raise Non_closed_number - -(**********************************************************************) -(* Parsing R via scopes *) -(**********************************************************************) - -let rdefinitions = ["Coq";"Reals";"Rdefinitions"] -let r_modpath = MPfile (make_dir rdefinitions) -let r_base_modpath = MPdot (r_modpath, Label.make "RbaseSymbolsImpl") -let r_path = make_path ["Coq";"Reals";"Rdefinitions";"RbaseSymbolsImpl"] "R" - -let glob_IZR = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "IZR") -let glob_Rmult = GlobRef.ConstRef (Constant.make2 r_base_modpath @@ Label.make "Rmult") -let glob_Rdiv = GlobRef.ConstRef (Constant.make2 r_modpath @@ Label.make "Rdiv") - -let binintdef = ["Coq";"ZArith";"BinIntDef"] -let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") - -let glob_pow_pos = GlobRef.ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") - -let r_of_rawnum ?loc n = - let n,e = NumTok.Signed.to_bigint_and_exponent n in - let e,p = NumTok.(match e with EDec e -> e, 10 | EBin e -> e, 2) in - let izr z = - DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in - let rmult r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rmult,None), [r; r']) in - let rdiv r r' = - DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in - let pow p e = - let p = z_of_int ?loc (Z.of_int p) in - let e = pos_of_bignat e in - DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [p; e]) in - let n = - izr (z_of_int ?loc n) in - if Int.equal (Z.sign e) 1 then rmult n (izr (pow p e)) - else if Int.equal (Z.sign e) (-1) then rdiv n (izr (pow p (Z.neg e))) - else n (* e = 0 *) - -(**********************************************************************) -(* Printing R via scopes *) -(**********************************************************************) - -let rawnum_of_r c = - (* print i * 10^e, precondition: e <> 0 *) - let numTok_of_int_exp i e = - (* choose between 123e-2 and 1.23, this is purely heuristic - and doesn't play any soundness role *) - let choose_exponent = - if Int.equal (Z.sign e) 1 then - true (* don't print 12 * 10^2 as 1200 to distinguish them *) - else - let i = Z.to_string i in - let li = if i.[0] = '-' then String.length i - 1 else String.length i in - let e = Z.neg e in - let le = String.length (Z.to_string e) in - Z.(lt (add (of_int li) (of_int le)) e) in - (* print 123 * 10^-2 as 123e-2 *) - let numTok_exponent () = - NumTok.Signed.of_bigint_and_exponent i (NumTok.EDec e) in - (* print 123 * 10^-2 as 1.23, precondition e < 0 *) - let numTok_dot () = - let s, i = - if Z.sign i >= 0 then NumTok.SPlus, Z.to_string i - else NumTok.SMinus, Z.(to_string (neg i)) in - let ni = String.length i in - let e = - (Z.to_int e) in - assert (e > 0); - let i, f = - if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e - else "0", String.make (e - ni) '0' ^ i in - let i = s, NumTok.UnsignedNat.of_string i in - let f = NumTok.UnsignedNat.of_string f in - NumTok.Signed.of_int_frac_and_exponent i (Some f) None in - if choose_exponent then numTok_exponent () else numTok_dot () in - match DAst.get c with - | GApp (r, [a]) when is_gr r glob_IZR -> - let n = bigint_of_z a in - NumTok.(Signed.of_bigint CDec n) - | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> - begin match DAst.get l, DAst.get r with - | GApp (i, [l]), GApp (i', [r]) - when is_gr i glob_IZR && is_gr i' glob_IZR -> - begin match DAst.get r with - | GApp (p, [t; e]) when is_gr p glob_pow_pos -> - let t = bigint_of_z t in - if not (Z.(equal t (of_int 10))) then - raise Non_closed_number - else - let i = bigint_of_z l in - let e = bignat_of_pos e in - let e = if is_gr md glob_Rdiv then Z.neg e else e in - numTok_of_int_exp i e - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - end - | _ -> raise Non_closed_number - -let uninterp_r (AnyGlobConstr p) = - try - Some (rawnum_of_r p) - with Non_closed_number -> - None - -open Notation - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -let r_scope = "R_scope" - -let _ = - register_rawnumeral_interpretation r_scope (r_of_rawnum,uninterp_r); - at_declare_ml_module enable_prim_token_interpretation - { pt_local = false; - pt_scope = r_scope; - pt_interp_info = Uid r_scope; - pt_required = (r_path,["Coq";"Reals";"Rdefinitions"]); - pt_refs = [glob_IZR; glob_Rmult; glob_Rdiv]; - pt_in_match = false } diff --git a/plugins/syntax/r_syntax.mli b/plugins/syntax/r_syntax.mli deleted file mode 100644 index b72d544151..0000000000 --- a/plugins/syntax/r_syntax.mli +++ /dev/null @@ -1,9 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack deleted file mode 100644 index d4ee75ea48..0000000000 --- a/plugins/syntax/r_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -R_syntax diff --git a/plugins/syntax/string_notation.ml b/plugins/syntax/string_notation.ml index e7ed0d8061..774d59dda3 100644 --- a/plugins/syntax/string_notation.ml +++ b/plugins/syntax/string_notation.ml @@ -9,21 +9,15 @@ (************************************************************************) open Pp -open Util open Names open Libnames open Constrexpr open Constrexpr_ops open Notation +open Number (** * String notation *) -let get_constructors ind = - let mib,oib = Global.lookup_inductive ind in - let mc = oib.Declarations.mind_consnames in - Array.to_list - (Array.mapi (fun j c -> GlobRef.ConstructRef (ind, j + 1)) mc) - let qualid_of_ref n = n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty @@ -46,7 +40,7 @@ let type_error_of g ty = (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Byte.byte or (option Byte.byte) or (list Byte.byte) or (option (list Byte.byte)).") -let vernac_string_notation local ty f g scope = +let vernac_string_notation local ty f g via scope = let env = Global.env () in let sigma = Evd.from_env env in let app x y = mkAppC (x,[y]) in @@ -56,14 +50,16 @@ let vernac_string_notation local ty f g scope = let coption = cref (q_option ()) in let opt r = app coption r in let clist_byte = app clist cbyte in - let tyc = Smartlocate.global_inductive_with_alias ty in + let ty_name = ty in + let ty, via = + match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in + let tyc, params = locate_global_inductive (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = cref ty in let arrow x y = mkProdC ([CAst.make Anonymous],Default Glob_term.Explicit, x, y) in - let constructors = get_constructors tyc in (* Check the type of f *) let to_kind = if has_type env sigma f (arrow clist_byte cty) then ListByte, Direct @@ -80,11 +76,10 @@ let vernac_string_notation local ty f g scope = else if has_type env sigma g (arrow cty (opt cbyte)) then Byte, Option else type_error_of g ty in - let o = { to_kind = to_kind; - to_ty = to_ty; - of_kind = of_kind; - of_ty = of_ty; - ty_name = ty; + let to_post, pt_refs = match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = () } in let i = @@ -92,7 +87,7 @@ let vernac_string_notation local ty f g scope = pt_scope = scope; pt_interp_info = StringNotation o; pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; - pt_refs = constructors; + pt_refs; pt_in_match = true } in enable_prim_token_interpretation i diff --git a/plugins/syntax/string_notation.mli b/plugins/syntax/string_notation.mli index 0d99f98d26..f3c7c969c6 100644 --- a/plugins/syntax/string_notation.mli +++ b/plugins/syntax/string_notation.mli @@ -14,5 +14,7 @@ open Vernacexpr (** * String notation *) val vernac_string_notation : locality_flag -> - qualid -> qualid -> qualid -> + qualid -> + qualid -> qualid -> + Number.number_string_via option -> Notation_term.scope_name -> unit diff --git a/plugins/syntax/string_notation_plugin.mlpack b/plugins/syntax/string_notation_plugin.mlpack deleted file mode 100644 index 6aa081dab4..0000000000 --- a/plugins/syntax/string_notation_plugin.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -String_notation -G_string |