diff options
Diffstat (limited to 'plugins')
69 files changed, 1405 insertions, 3898 deletions
diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index aee0bd8564..6e8b2eb0fb 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -212,7 +212,7 @@ module Btauto = struct let assign = List.map map_msg assign in let l = str "[" ++ (concat (str ";" ++ spc ()) assign) ++ str "]" in str "Not a tautology:" ++ spc () ++ l - with e when Errors.noncritical e -> (str "Not a tautology") + with e when CErrors.noncritical e -> (str "Not a tautology") in Tacticals.tclFAIL 0 msg gl diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 76db2f3c2f..bc53b113df 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -10,7 +10,7 @@ (* Downey,Sethi and Tarjan. *) (* Plus some e-matching and constructor handling by P. Corbineau *) -open Errors +open CErrors open Util open Pp open Goptions @@ -484,7 +484,7 @@ let build_subst uf subst = Array.map (fun i -> try term uf i - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> anomaly (Pp.str "incomplete matching")) subst diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index d2bbaf6a7d..f58847cafb 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -9,7 +9,7 @@ (* This file uses the (non-compressed) union-find structure to generate *) (* proof-trees that will be transformed into proof-terms in cctac.ml4 *) -open Errors +open CErrors open Term open Ccalgo open Pp diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index bd788a425a..fd46d80695 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -20,7 +20,7 @@ open Typing open Ccalgo open Ccproof open Pp -open Errors +open CErrors open Util open Proofview.Notations open Context.Rel.Declaration @@ -38,12 +38,12 @@ let _True = reference ["Init";"Logic"] "True" let _I = reference ["Init";"Logic"] "I" let whd env= - let infos=Closure.create_clos_infos Closure.betaiotazeta env in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.betaiotazeta env in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) let whd_delta env= - let infos=Closure.create_clos_infos Closure.betadeltaiota env in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.all env in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) (* decompose member of equality in an applicative format *) @@ -82,8 +82,10 @@ let rec decompose_term env sigma t= | Proj (p, c) -> let canon_const kn = constant_of_kn (canonical_con kn) in let p' = Projection.map canon_const p in - (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) - | _ ->if closed0 t then (Symb t) else raise Not_found + (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) + | _ -> + let t = strip_outer_cast t in + if closed0 t then Symb t else raise Not_found (* decompose equality in members and type *) open Globnames @@ -233,10 +235,10 @@ let build_projection intype (cstr:pconstructor) special default gls= let _M =mkMeta -let app_global f args k = +let app_global f args k = Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) -let new_app_global f args k = +let new_app_global f args k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_refine c = Proofview.V82.tactic (refine c) @@ -246,7 +248,19 @@ let assert_before n c = let evm, _ = Tacmach.New.pf_apply type_of gl c in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) end } - + +let refresh_type env evm ty = + Evarsolve.refresh_universes ~status:Evd.univ_flexible ~refreshset:true + (Some false) env evm ty + +let refresh_universes ty k = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let evm = Tacmach.New.project gl in + let evm, ty = refresh_type env evm ty in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty) + end } + let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in @@ -256,35 +270,31 @@ let rec proof_tac p : unit Proofview.tactic = | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - let typ = (* Termops.refresh_universes *) type_of l in - new_app_global _sym_eq [|typ;r;l;c|] exact_check + refresh_universes (type_of l) (fun typ -> + new_app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> let lr = constr_of_term t in - let typ = (* Termops.refresh_universes *) type_of lr in - new_app_global _refl_equal [|typ;constr_of_term t|] exact_check + refresh_universes (type_of lr) (fun typ -> + new_app_global _refl_equal [|typ;constr_of_term t|] exact_check) | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in - let typ = (* Termops.refresh_universes *) (type_of t2) in + refresh_universes (type_of t2) (fun typ -> let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in - Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)] + Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs and tf2=constr_of_term p1.p_rhs and tx2=constr_of_term p2.p_rhs in - let typf = (* Termops.refresh_universes *)(type_of tf1) in - let typx = (* Termops.refresh_universes *) (type_of tx1) in - let typfx = (* Termops.refresh_universes *) (type_of (mkApp (tf1,[|tx1|]))) in + refresh_universes (type_of tf1) (fun typf -> + refresh_universes (type_of tx1) (fun typx -> + refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in - let lemma1 = - app_global _f_equal - [|typf;typfx;appx1;tf1;tf2;_M 1|] in - let lemma2= - app_global _f_equal - [|typx;typfx;tf2;tx1;tx2;_M 1|] in + let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in + let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in let prf = app_global _trans_eq [|typfx; @@ -298,34 +308,33 @@ let rec proof_tac p : unit Proofview.tactic = reflexivity; Tacticals.New.tclZEROMSG (Pp.str - "I don't know how to handle dependent equality")]] + "I don't know how to handle dependent equality")]]))) | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in - let intype = (* Termops.refresh_universes *) (type_of ti) in - let outtype = (* Termops.refresh_universes *) (type_of default) in let special=mkRel (1+nargs-argind) in + refresh_universes (type_of ti) (fun intype -> + refresh_universes (type_of default) (fun outtype -> let proj = Tacmach.New.of_old (build_projection intype cstr special default) gl in let injt= app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in - Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf) + Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } let refute_tac c t1 t2 p = Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let intype = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt1)) gl - in - let neweq= new_app_global _eq [|intype;tt1;tt2|] in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in + let k intype = + let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k end } let refine_exact_check c gl = @@ -335,16 +344,15 @@ let refine_exact_check c gl = let convert_to_goal_tac c t1 t2 p = Proofview.Goal.nf_enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let sort = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt2)) gl - in - let neweq= new_app_global _eq [|sort;tt1;tt2|] in - let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in - let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in - let identity=mkLambda (Name x,sort,mkRel 1) in - let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in + let k sort = + let neweq= new_app_global _eq [|sort;tt1;tt2|] in + let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in + let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + let identity=mkLambda (Name x,sort,mkRel 1) in + let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) - [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -360,33 +368,28 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = let discriminate_tac (cstr,u as cstru) p = Proofview.Goal.nf_enter { enter = begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in - let intype = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls t1)) gl - in + let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *) - (* let outsort = mkSort outsort in *) let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in - (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) - (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) let identity = Universes.constr_of_global (Lazy.force _I) in - (* let trivial=pf_unsafe_type_of gls identity in *) let trivial = Universes.constr_of_global (Lazy.force _True) in - let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Tacmach.New.project gl) in + let evm = Tacmach.New.project gl in + let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in + let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in - let pred=mkLambda(Name xid,outtype,mkRel 1) in + let pred = mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in let injt=app_global _f_equal - [|intype;outtype;proj;t1;t2;mkVar hid|] in + [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> - app_global _eq_rect - [|outtype;trivial;pred;identity;concl;injt|] k) in + app_global _eq_rect + [|outtype;trivial;pred;identity;concl;injt|] k) in let neweq=new_app_global _eq [|intype;t1;t2|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) - (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) - [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) + (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) + [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) end } (* wrap everything *) @@ -470,7 +473,7 @@ let congruence_tac depth l = This isn't particularly related with congruence, apart from the fact that congruence is called internally. *) - + let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> Proofview.Goal.enter { enter = begin fun gl -> @@ -482,7 +485,7 @@ let mk_eq f c1 c2 k = Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k term) end }) - + let f_equal = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 34307a358f..a862423e99 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Names open Constrexpr @@ -153,8 +153,8 @@ let interp_constr check_sort env sigma c = fst (understand env sigma (fst c)) let special_whd env = - let infos=Closure.create_clos_infos Closure.betadeltaiota env in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.all env in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml index f9399d6824..92d4089015 100644 --- a/plugins/decl_mode/decl_mode.ml +++ b/plugins/decl_mode/decl_mode.ml @@ -9,7 +9,7 @@ open Names open Term open Evd -open Errors +open CErrors open Util let daimon_flag = ref false diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 836f1982db..d30fcf6033 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Pp open Evd @@ -60,7 +60,7 @@ let _ = declare_bool_option { optsync = true; optdepr = false; - optname = "strict mode"; + optname = "strict proofs"; optkey = ["Strict";"Proofs"]; optread = get_strictness; optwrite = set_strictness } @@ -84,12 +84,12 @@ let tcl_erase_info gls = tcl_change_info_gen info_gen gls let special_whd gl= - let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) let special_nf gl= - let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in + (fun t -> CClosure.norm_val infos (CClosure.inject t)) let is_good_inductive env ind = let mib,oib = Inductive.lookup_mind_specif env ind in @@ -277,7 +277,7 @@ let prepare_goal items gls = filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls let my_automation_tac = ref - (Proofview.tclZERO (Errors.make_anomaly (Pp.str"No automation registered"))) + (Proofview.tclZERO (CErrors.make_anomaly (Pp.str"No automation registered"))) let register_automation_tac tac = my_automation_tac:= tac @@ -415,7 +415,7 @@ let find_subsubgoal c ctyp skip submetas gls = se.se_meta submetas se.se_meta_list} else dfs (pred n) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> begin enstack_subsubgoals env se stack gls; dfs n diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 73d3d1bab8..6c17dcc4f1 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -58,7 +58,7 @@ let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= let vernac_decl_proof () = let pf = Proof_global.give_me_the_proof () in if Proof.is_done pf then - Errors.error "Nothing left to prove here." + CErrors.error "Nothing left to prove here." else begin Decl_proof_instr.go_to_proof_mode () ; diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 4c71f04107..59a0bb5a2d 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Pp open Decl_expr open Names diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 5d1551106f..e39d17b52d 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -51,9 +51,9 @@ let start_deriving f suchthat lemma = [suchthat], respectively. *) let (opaque,f_def,lemma_def) = match com with - | Admitted _ -> Errors.error"Admitted isn't supported in Derive." + | Admitted _ -> CErrors.error"Admitted isn't supported in Derive." | Proved (_,Some _,_) -> - Errors.error"Cannot save a proof of Derive with an explicit name." + CErrors.error"Cannot save a proof of Derive with an explicit name." | Proved (opaque, None, obj) -> match Proof_global.(obj.entries) with | [_;f_def;lemma_def] -> diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 94981d0e1f..52f22ee603 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -13,7 +13,7 @@ open Names open Libnames open Globnames open Pp -open Errors +open CErrors open Util open Table open Extraction diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0153348de9..312c2eab3d 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -74,7 +74,7 @@ type flag = info * scheme Really important function. *) let rec flag_of_type env t : flag = - let t = whd_betadeltaiota env none t in + let t = whd_all env none t in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) @@ -102,14 +102,14 @@ let is_info_scheme env t = match flag_of_type env t with (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = - match kind_of_term (whd_betadeltaiota env none c) with + match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = - match kind_of_term (whd_betadeltaiota env none c) with + match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n @@ -135,7 +135,7 @@ let make_typvar n vl = next_ident_away id' vl let rec type_sign_vl env c = - match kind_of_term (whd_betadeltaiota env none c) with + match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kprop::s, vl @@ -143,7 +143,7 @@ let rec type_sign_vl env c = | _ -> [],[] let rec nb_default_params env c = - match kind_of_term (whd_betadeltaiota env none c) with + match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n @@ -489,7 +489,7 @@ and extract_really_ind env kn mib = *) and extract_type_cons env db dbmap c i = - match kind_of_term (whd_betadeltaiota env none c) with + match kind_of_term (whd_all env none c) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in @@ -684,7 +684,7 @@ and extract_cst_app env mle mlt kn u args = let l,l' = List.chop (projection_arity (ConstRef kn)) mla in if not (List.is_empty l') then (List.map (fun _ -> MLexn "Proj Args") l) @ l' else mla - with e when Errors.noncritical e -> mla + with e when CErrors.noncritical e -> mla in (* For strict languages, purely logical signatures lead to a dummy lam (except when [Kill Ktype] everywhere). So a [MLdummy] is left diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index 764223621e..0692c88cd1 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -9,7 +9,7 @@ (*s Production of Haskell syntax. *) open Pp -open Errors +open CErrors open Util open Names open Nameops diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index bd48311308..60fe8e7620 100644 --- a/plugins/extraction/modutil.ml +++ b/plugins/extraction/modutil.ml @@ -8,7 +8,7 @@ open Names open Globnames -open Errors +open CErrors open Util open Miniml open Table @@ -310,7 +310,7 @@ let base_r = function let reset_needed, add_needed, add_needed_mp, found_needed, is_needed = let needed = ref Refset'.empty and needed_mps = ref MPset.empty in - ((fun l -> needed := Refset'.empty; needed_mps := MPset.empty), + ((fun () -> needed := Refset'.empty; needed_mps := MPset.empty), (fun r -> needed := Refset'.add (base_r r) !needed), (fun mp -> needed_mps := MPset.add mp !needed_mps), (fun r -> needed := Refset'.remove (base_r r) !needed), diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 3cb3810cbc..1c29a9bc24 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -9,7 +9,7 @@ (*s Production of Ocaml syntax. *) open Pp -open Errors +open CErrors open Util open Names open Nameops @@ -203,7 +203,7 @@ let rec pp_expr par env args = let args = List.skipn (projection_arity r) args in let record = List.hd args in pp_apply (record ++ str "." ++ pp_global Term r) par (List.tl args) - with e when Errors.noncritical e -> apply (pp_global Term r)) + with e when CErrors.noncritical e -> apply (pp_global Term r)) | MLfix (i,ids,defs) -> let ids',env' = push_vars (List.rev (Array.to_list ids)) env in pp_fix par env' i (Array.of_list (List.rev ids'),defs) args diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index 7b0f14dff7..a6309e61f9 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -9,7 +9,7 @@ (*s Production of Scheme syntax. *) open Pp -open Errors +open CErrors open Util open Names open Miniml diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 81dfa603dd..ff66d915f5 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -15,7 +15,7 @@ open Libobject open Goptions open Libnames open Globnames -open Errors +open CErrors open Util open Pp open Miniml @@ -441,7 +441,7 @@ let error_MPfile_as_mod mp b = let argnames_of_global r = let typ = Global.type_of_global_unsafe r in let rels,_ = - decompose_prod (Reduction.whd_betadeltaiota (Global.env ()) typ) in + decompose_prod (Reduction.whd_all (Global.env ()) typ) in List.rev_map fst rels let msg_of_implicit = function @@ -880,7 +880,7 @@ let extract_constant_inline inline r ids s = | ConstRef kn -> let env = Global.env () in let typ = Global.type_of_global_unsafe (ConstRef kn) in - let typ = Reduction.whd_betadeltaiota env typ in + let typ = Reduction.whd_all env typ in if Reduction.is_arity env typ then begin let nargs = Hook.get use_type_scheme_nb_args env typ in diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 2ed436c6bf..58744b5754 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -19,7 +19,7 @@ open Context.Rel.Declaration let qflag=ref true -let red_flags=ref Closure.betaiotazeta +let red_flags=ref CClosure.betaiotazeta let (=?) f g i1 i2 j1 j2= let c=f i1 i2 in @@ -59,12 +59,12 @@ let ind_hyps nevar ind largs gls= Array.map myhyps types let special_nf gl= - let infos=Closure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> CClosure.norm_val infos (CClosure.inject t)) let special_whd gl= - let infos=Closure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) type kind_of_formula= Arrow of constr*constr diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 0f70d3ea05..5db8ff59ad 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -11,7 +11,7 @@ open Globnames val qflag : bool ref -val red_flags: Closure.RedFlags.reds ref +val red_flags: CClosure.RedFlags.reds ref val (=?) : ('a -> 'a -> int) -> ('b -> 'b -> int) -> 'a -> 'a -> 'b -> 'b -> int diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index d7da85b4f4..628af4e719 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -24,8 +24,8 @@ let update_flags ()= in List.iter f (Classops.coercions ()); red_flags:= - Closure.RedFlags.red_add_transparent - Closure.betaiotazeta + CClosure.RedFlags.red_add_transparent + CClosure.betaiotazeta (Names.Id.Pred.full,Names.Cpred.complement !predref) let ground_tac solver startseq gl= diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 5eff2f2774..eebd974ea8 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -8,7 +8,7 @@ open Unify open Rules -open Errors +open CErrors open Util open Term open Vars @@ -107,7 +107,7 @@ let mk_open_instance id idc gl m t= let typ=pf_unsafe_type_of gl idc in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in + let (nam,_,_)=destProd (whd_all env evmap typ) in match nam with Name id -> id | Anonymous -> dummy_bvid in @@ -156,7 +156,7 @@ let left_instance_tac (inst,id) continue seq= (mkApp(idc,[|ot|])) rc in let evmap, _ = try Typing.type_of (pf_env gl) evmap gt - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) else diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 92b6e828e8..ffb63af072 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Names open Term diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 3e8033da07..1248b60a76 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -7,7 +7,7 @@ (************************************************************************) open Term -open Errors +open CErrors open Util open Formula open Unify diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index dc5dd45ab0..51bd3009ae 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -501,11 +501,11 @@ let rec fourier () = with NoIneq -> ()) hyps; (* lineq = les inéquations découlant des hypothèses *) - if !lineq=[] then Errors.error "No inequalities"; + if !lineq=[] then CErrors.error "No inequalities"; let res=fourier_lineq (!lineq) in let tac=ref (Proofview.tclUNIT ()) in if res=[] - then Errors.error "fourier failed" + then CErrors.error "fourier failed" (* l'algorithme de Fourier a réussi: on va en tirer une preuve Coq *) else (match res with [(cres,sres,lc)]-> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 52094cf085..b0ffc775b5 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,5 +1,5 @@ open Printer -open Errors +open CErrors open Util open Term open Vars @@ -27,7 +27,7 @@ let observe strm = let do_observe_tac s tac g = try let v = tac g in (* msgnl (goal ++ fnl () ++ (str s)++(str " ")++(str "finished")); *) v with e -> - let e = Cerrors.process_vernac_interp_error e in + let e = ExplainErr.process_vernac_interp_error e in let goal = begin try (Printer.pr_goal g) with _ -> assert false end in msg_debug (str "observation "++ s++str " raised exception " ++ Errors.print e ++ str " on goal " ++ goal ); @@ -52,7 +52,7 @@ let rec print_debug_queue e = let _ = match e with | Some e -> - Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) + Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) | None -> begin Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); @@ -74,9 +74,9 @@ let do_observe_tac s tac g = ignore(Stack.pop debug_queue); v with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) - then print_debug_queue (Some (fst (Cerrors.process_vernac_interp_error reraise))); + then print_debug_queue (Some (fst (ExplainErr.process_vernac_interp_error reraise))); iraise reraise let observe_tac_stream s tac g = @@ -141,7 +141,7 @@ let is_trivial_eq t = eq_constr t1 t2 && eq_constr a1 a2 | _ -> false end - with e when Errors.noncritical e -> false + with e when CErrors.noncritical e -> false in (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res @@ -167,7 +167,7 @@ let is_incompatible_eq t = (eq_constr u1 u2 && incompatible_constructor_terms t1 t2) | _ -> false - with e when Errors.noncritical e -> false + with e when CErrors.noncritical e -> false in if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); res @@ -223,8 +223,8 @@ let isAppConstruct ?(env=Global.env ()) t = let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty @@ -254,7 +254,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = then (jmeq_refl (),(args.(1),args.(0)),(args.(3),args.(2)),args.(0)) else nochange "not an equality" - with e when Errors.noncritical e -> nochange "not an equality" + with e when CErrors.noncritical e -> nochange "not an equality" in if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = @@ -281,7 +281,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = List.fold_left2 compute_substitution sub args1 args2 end else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_betadeltaiota env t1) t2) "cannot solve (diff)" + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in @@ -625,8 +625,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let my_orelse tac1 tac2 g = try tac1 g - with e when Errors.noncritical e -> -(* observe (str "using snd tac since : " ++ Errors.print e); *) + with e when CErrors.noncritical e -> +(* observe (str "using snd tac since : " ++ CErrors.print e); *) tac2 g let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = @@ -1025,7 +1025,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with ConstRef c -> c - | _ -> Errors.anomaly (Pp.str "Not a constant") + | _ -> CErrors.anomaly (Pp.str "Not a constant") ) } | _ -> () @@ -1085,7 +1085,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam match Global.body_of_constant const with | Some body -> Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) body diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 5b4fb25955..5e72b8672a 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -1,5 +1,5 @@ open Printer -open Errors +open CErrors open Util open Term open Vars @@ -358,7 +358,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) save false new_princ_name entry g_kind hook - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> begin begin try @@ -370,7 +370,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) then Pfedit.delete_current_proof () else () else () - with e when Errors.noncritical e -> () + with e when CErrors.noncritical e -> () end; raise (Defining_principle e) end @@ -400,7 +400,7 @@ let get_funs_constant mp dp = match Global.body_of_constant const with | Some body -> let body = Tacred.cbv_norm_flags - (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.from_env (Global.env ())) body @@ -510,7 +510,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con 0 (prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ _ -> ()) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> begin begin try @@ -522,7 +522,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con then Pfedit.delete_current_proof () else () else () - with e when Errors.noncritical e -> () + with e when CErrors.noncritical e -> () end; raise (Defining_principle e) end diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 93a89330e3..42e4903155 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -90,7 +90,7 @@ let pr_intro_as_pat _prc _ _ pat = let out_disjunctive = function | loc, IntroAction (IntroOrAndPattern l) -> (loc,l) - | _ -> Errors.error "Disjunctive or conjunctive intro pattern expected." + | _ -> CErrors.error "Disjunctive or conjunctive intro pattern expected." ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [ "as" simple_intropattern(ipat) ] -> [ Some ipat ] @@ -195,15 +195,15 @@ END let warning_error names e = - let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in + let (e, _) = ExplainErr.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> let names = pr_enum Libnames.pr_reference names in - let error = if do_observe () then (spc () ++ Errors.print e) else mt () in + let error = if do_observe () then (spc () ++ CErrors.print e) else mt () in warn_cannot_define_graph (names,error) | Defining_principle e -> let names = pr_enum Libnames.pr_reference names in - let error = if do_observe () then Errors.print e else mt () in + let error = if do_observe () then CErrors.print e else mt () in warn_cannot_define_principle (names,error) | _ -> raise e @@ -227,15 +227,15 @@ VERNAC COMMAND EXTEND NewFunctionalScheme ; try Functional_principles_types.build_scheme fas with Functional_principles_types.No_graph_found -> - Errors.error ("Cannot generate induction principle(s)") - | e when Errors.noncritical e -> + CErrors.error ("Cannot generate induction principle(s)") + | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end | _ -> assert false (* we can only have non empty list *) end - | e when Errors.noncritical e -> + | e when CErrors.noncritical e -> let names = List.map (fun (_,na,_) -> na) fas in warning_error names e end diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index c424fe1226..52179ae508 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -7,7 +7,7 @@ open Glob_term open Glob_ops open Globnames open Indfun_common -open Errors +open CErrors open Util open Glob_termops open Misctypes @@ -921,7 +921,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) - with e when Errors.noncritical e -> raise Continue + with e when CErrors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in let _keep_eq = @@ -1223,7 +1223,7 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) l := param::!l ) rels_params.(0) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> () in List.rev !l @@ -1460,7 +1460,7 @@ let do_build_inductive str "while trying to define"++ spc () ++ Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ - Errors.print reraise + CErrors.print reraise in observe msg; raise reraise @@ -1476,7 +1476,7 @@ let build_inductive evd funconstants funsargs returned_types rtl = do_build_inductive evd funconstants funsargs returned_types rtl; Detyping.print_universes := pu; Constrextern.print_universes := cu - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> Detyping.print_universes := pu; Constrextern.print_universes := cu; raise (Building_graph e) diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 291f835ee7..01e5ef7fba 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -1,6 +1,6 @@ open Pp open Glob_term -open Errors +open CErrors open Util open Names open Decl_kinds diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 2ebbb34e4c..18817f504c 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -1,5 +1,5 @@ open Context.Rel.Declaration -open Errors +open CErrors open Util open Names open Term @@ -225,12 +225,12 @@ let prepare_body ((name,_,args,types,_),_) rt = (fun_args,rt') let process_vernac_interp_error e = - fst (Cerrors.process_vernac_interp_error (e, Exninfo.null)) + fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null)) let warn_funind_cannot_build_inversion = CWarnings.create ~name:"funind-cannot-build-inversion" ~category:"funind" (fun e' -> strbrk "Cannot build inversion information" ++ - if do_observe () then (fnl() ++ Errors.print e') else mt ()) + if do_observe () then (fnl() ++ CErrors.print e') else mt ()) let derive_inversion fix_names = try @@ -272,10 +272,10 @@ let derive_inversion fix_names = functional_induction fix_names_as_constant lind; - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> let e' = process_vernac_interp_error e in warn_funind_cannot_build_inversion e' - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> let e' = process_vernac_interp_error e in warn_funind_cannot_build_inversion e' @@ -295,12 +295,12 @@ let warning_error names e = match e with | ToShow e -> let e = process_vernac_interp_error e in - spc () ++ Errors.print e + spc () ++ CErrors.print e | _ -> if do_observe () then let e = process_vernac_interp_error e in - (spc () ++ Errors.print e) + (spc () ++ CErrors.print e) else mt () in match e with @@ -316,8 +316,8 @@ let error_error names e = let e = process_vernac_interp_error e in let e_explain e = match e with - | ToShow e -> spc () ++ Errors.print e - | _ -> if do_observe () then (spc () ++ Errors.print e) else mt () + | ToShow e -> spc () ++ CErrors.print e + | _ -> if do_observe () then (spc () ++ CErrors.print e) else mt () in match e with | Building_graph e -> @@ -385,7 +385,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error Array.iter (add_Function is_general) funs_kn; () end - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> on_error names e let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = @@ -475,7 +475,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation ); derive_inversion [fname] - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> (* No proof done *) () in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 2449678a13..f56e92414e 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -49,7 +49,7 @@ let locate_constant ref = let locate_with_msg msg f x = try f x - with Not_found -> raise (Errors.UserError("", msg)) + with Not_found -> raise (CErrors.UserError("", msg)) let filter_map filter f = @@ -73,7 +73,7 @@ let chop_rlambda_n = | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b | _ -> - raise (Errors.UserError("chop_rlambda_n", + raise (CErrors.UserError("chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) in chop_lambda_n [] @@ -85,7 +85,7 @@ let chop_rprod_n = else match rt with | Glob_term.GProd(_,name,k,t,b) -> chop_prod_n ((name,t)::acc) (n-1) b - | _ -> raise (Errors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) + | _ -> raise (CErrors.UserError("chop_rprod_n",str "chop_rprod_n: Not enough products")) in chop_prod_n [] @@ -110,7 +110,7 @@ let const_of_id id = in try Constrintern.locate_reference princ_ref with Not_found -> - Errors.errorlabstrm "IndFun.const_of_id" + CErrors.errorlabstrm "IndFun.const_of_id" (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = @@ -344,7 +344,7 @@ let pr_info f_info = (try Printer.pr_lconstr (Global.type_of_global_unsafe (ConstRef f_info.function_constant)) - with e when Errors.noncritical e -> mt ()) ++ fnl () ++ + with e when CErrors.noncritical e -> mt ()) ++ fnl () ++ str "equation_lemma := " ++ pr_ocst f_info.equation_lemma ++ fnl () ++ str "completeness_lemma :=" ++ pr_ocst f_info.completeness_lemma ++ fnl () ++ str "correctness_lemma := " ++ pr_ocst f_info.correctness_lemma ++ fnl () ++ @@ -371,7 +371,7 @@ let in_Function : function_info -> Libobject.obj = let find_or_none id = try Some - (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> Errors.anomaly (Pp.str "Not a constant") + (match Nametab.locate (qualid_of_ident id) with ConstRef c -> c | _ -> CErrors.anomaly (Pp.str "Not a constant") ) with Not_found -> None @@ -399,7 +399,7 @@ let add_Function is_general f = and prop_lemma = find_or_none (Nameops.add_suffix f_id "_ind") and graph_ind = match Nametab.locate (qualid_of_ident (mk_rel_id f_id)) - with | IndRef ind -> ind | _ -> Errors.anomaly (Pp.str "Not an inductive") + with | IndRef ind -> ind | _ -> CErrors.anomaly (Pp.str "Not an inductive") in let finfos = { function_constant = f; @@ -476,13 +476,13 @@ let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" - with e when Errors.noncritical e -> raise (ToShow e) + with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" - with e when Errors.noncritical e -> raise (ToShow e) + with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = tclMAP (fun x -> Proofview.V82.of_tactic (Tactics.Simple.intro x)) l diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 1ff254f6ca..26fc88a604 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -8,7 +8,7 @@ open Tacexpr open Declarations -open Errors +open CErrors open Util open Names open Term @@ -65,16 +65,16 @@ let observe strm = let do_observe_tac s tac g = let goal = try Printer.pr_goal g - with e when Errors.noncritical e -> assert false + with e when CErrors.noncritical e -> assert false in try let v = tac g in msgnl (goal ++ fnl () ++ s ++(str " ")++(str "finished")); v with reraise -> - let reraise = Errors.push reraise in - let e = Cerrors.process_vernac_interp_error reraise in + let reraise = CErrors.push reraise in + let e = ExplainErr.process_vernac_interp_error reraise in observe (hov 0 (str "observation "++ s++str " raised exception " ++ - Errors.iprint e ++ str " on goal" ++ fnl() ++ goal )); + CErrors.iprint e ++ str " on goal" ++ fnl() ++ goal )); iraise reraise;; @@ -90,7 +90,7 @@ let observe_tac s tac g = (* [nf_zeta] $\zeta$-normalization of a term *) let nf_zeta = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) Environ.empty_env Evd.empty @@ -585,7 +585,7 @@ let rec reflexivity_with_destruct_cases g = observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] | _ -> Proofview.V82.of_tactic reflexivity - with e when Errors.noncritical e -> Proofview.V82.of_tactic reflexivity + with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity in let eq_ind = make_eq () in let discr_inject = @@ -998,7 +998,7 @@ let invfun qhyp f = let f = match f with | ConstRef f -> f - | _ -> raise (Errors.UserError("",str "Not a function")) + | _ -> raise (CErrors.UserError("",str "Not a function")) in try let finfos = find_Function_infos f in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 99a165044c..de4210af5f 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -11,7 +11,7 @@ open Globnames open Tactics open Indfun_common -open Errors +open CErrors open Util open Constrexpr open Vernacexpr @@ -73,7 +73,7 @@ let ident_global_exist id = let ans = CRef (Libnames.Ident (Loc.ghost,id), None) in let _ = ignore (Constrintern.intern_constr (Global.env()) ans) in true - with e when Errors.noncritical e -> false + with e when CErrors.noncritical e -> false (** [next_ident_fresh id] returns a fresh identifier (ie not linked in global env) with base [id]. *) @@ -785,10 +785,10 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let params1 = try fst (glob_decompose_prod_n shift.nrecprms1 (List.hd lcstr1)) - with e when Errors.noncritical e -> [] in + with e when CErrors.noncritical e -> [] in let params2 = try fst (glob_decompose_prod_n shift.nrecprms2 (List.hd lcstr2)) - with e when Errors.noncritical e -> [] in + with e when CErrors.noncritical e -> [] in let lcstr1 = List.combine (Array.to_list oib1.mind_consnames) lcstr1 in let lcstr2 = List.combine (Array.to_list oib2.mind_consnames) lcstr2 in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index e742f7b80d..62f3071151 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -16,7 +16,7 @@ open Names open Libnames open Globnames open Nameops -open Errors +open CErrors open Util open Tacticals open Tacmach @@ -92,15 +92,15 @@ let const_of_ref = function let nf_zeta env = - Reductionops.clos_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) + Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) env Evd.empty let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) let clos_norm_flags flgs env sigma t = - Closure.norm_val (Closure.create_clos_infos flgs env) (Closure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags Closure.betaiotazeta Environ.empty_env Evd.empty + CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in + clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty @@ -161,7 +161,7 @@ let rec n_x_id ids n = let simpl_iter clause = reduce (Lazy - {rBeta=true;rIota=true;rZeta= true; rDelta=false; + {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=true;rDelta=false; rConst = [ EvalConstRef (const_of_ref (delayed_force iter_ref))]}) clause @@ -214,7 +214,7 @@ let print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ CErrors.print e) ++ str " on goal" ++ fnl() ++ goal)) else begin Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); @@ -238,9 +238,9 @@ let do_observe_tac s tac g = ignore(Stack.pop debug_queue); v with reraise -> - let reraise = Errors.push reraise in + let reraise = CErrors.push reraise in if not (Stack.is_empty debug_queue) - then print_debug_queue true (fst (Cerrors.process_vernac_interp_error reraise)); + then print_debug_queue true (fst (ExplainErr.process_vernac_interp_error reraise)); iraise reraise let observe_tac s tac g = @@ -441,7 +441,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> @@ -449,7 +449,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; jinfo.otherS () expr_info continuation_tac expr_info - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> errorlabstrm "Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> @@ -645,7 +645,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; true - with e when Errors.noncritical e -> false + with e when CErrors.noncritical e -> false in if forbid then @@ -704,7 +704,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = try check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; false - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> true in let a' = infos.info in @@ -1281,12 +1281,12 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | Some s -> s | None -> try add_suffix current_proof_name "_subproof" - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> anomaly (Pp.str "open_new_goal with an unamed theorem") in let na = next_global_ident_away name [] in if Termops.occur_existential gls_type then - Errors.error "\"abstract\" cannot handle existentials"; + CErrors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = let na_ref = Libnames.Ident (Loc.ghost,na) in @@ -1534,10 +1534,10 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); false - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> begin if do_observe () - then Feedback.msg_debug (str "Cannot create equation Lemma " ++ Errors.print e) + then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) else anomaly (Pp.str "Cannot create equation Lemma") ; true diff --git a/plugins/micromega/Env.v b/plugins/micromega/Env.v index a19e9df904..7e3ef89293 100644 --- a/plugins/micromega/Env.v +++ b/plugins/micromega/Env.v @@ -93,7 +93,7 @@ End S. Ltac jump_simpl := repeat match goal with - | |- appcontext [jump xH] => rewrite (jump_simpl xH) - | |- appcontext [jump (xO ?p)] => rewrite (jump_simpl (xO p)) - | |- appcontext [jump (xI ?p)] => rewrite (jump_simpl (xI p)) + | |- context [jump xH] => rewrite (jump_simpl xH) + | |- context [jump (xO ?p)] => rewrite (jump_simpl (xO p)) + | |- context [jump (xI ?p)] => rewrite (jump_simpl (xI p)) end. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 52bf5ed3df..47b6f7c7f9 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2013 *) +(* Frédéric Besson (Irisa/Inria) 2013-2016 *) (* *) (************************************************************************) @@ -19,24 +19,24 @@ Require Import VarMap. Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". + Ltac preprocess := zify ; unfold Z.succ in * ; unfold Z.pred in *. -Ltac lia := - preprocess; - xlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). - -Ltac nia := - preprocess; - xnlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac zchange := + intros __wit __varmap __ff ; + change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; + apply (ZTautoChecker_sound __ff __wit). + +Ltac zchecker_no_abstract := zchange ; vm_compute ; reflexivity. + +Ltac zchecker_abstract := zchange ; vm_cast_no_check (eq_refl true). + +Ltac zchecker := zchecker_no_abstract. + +Ltac lia := preprocess; xlia zchecker. + +Ltac nia := preprocess; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/Lqa.v b/plugins/micromega/Lqa.v new file mode 100644 index 0000000000..acd2751a04 --- /dev/null +++ b/plugins/micromega/Lqa.v @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2016 *) +(* *) +(************************************************************************) + +Require Import QMicromega. +Require Import QArith. +Require Import RingMicromega. +Require Import VarMap. +Require Coq.micromega.Tauto. +Declare ML Module "micromega_plugin". + +Ltac rchange := + intros __wit __varmap __ff ; + change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; + apply (QTautoChecker_sound __ff __wit). + +Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. +Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true). + +Ltac rchecker := rchecker_no_abstract. + +(** Here, lra stands for linear rational arithmetic *) +Ltac lra := lra_Q rchecker. + +(** Here, nra stands for non-linear rational arithmetic *) +Ltac nra := xnqa rchecker. + +Ltac xpsatz dom d := + let tac := lazymatch dom with + | Q => + ((sos_Q rchecker) || (psatz_Q d rchecker)) + | _ => fail "Unsupported domain" + end in tac. + +Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/Lra.v b/plugins/micromega/Lra.v new file mode 100644 index 0000000000..5b97d8ed36 --- /dev/null +++ b/plugins/micromega/Lra.v @@ -0,0 +1,52 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(* *) +(* Micromega: A reflexive tactic using the Positivstellensatz *) +(* *) +(* Frédéric Besson (Irisa/Inria) 2016 *) +(* *) +(************************************************************************) + +Require Import RMicromega. +Require Import QMicromega. +Require Import Rdefinitions. +Require Import RingMicromega. +Require Import VarMap. +Require Coq.micromega.Tauto. +Declare ML Module "micromega_plugin". + +Ltac rchange := + intros __wit __varmap __ff ; + change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; + apply (RTautoChecker_sound __ff __wit). + +Ltac rchecker_no_abstract := rchange ; vm_compute ; reflexivity. +Ltac rchecker_abstract := rchange ; vm_cast_no_check (eq_refl true). + +Ltac rchecker := rchecker_no_abstract. + +(** Here, lra stands for linear real arithmetic *) +Ltac lra := unfold Rdiv in * ; lra_R rchecker. + +(** Here, nra stands for non-linear real arithmetic *) +Ltac nra := unfold Rdiv in * ; xnra rchecker. + +Ltac xpsatz dom d := + let tac := lazymatch dom with + | R => + (sos_R rchecker) || (psatz_R d rchecker) + | _ => fail "Unsupported domain" + end in tac. + +Tactic Notation "psatz" constr(dom) int_or_var(n) := xpsatz dom n. +Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). + + +(* Local Variables: *) +(* coding: utf-8 *) +(* End: *) diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 0a41af4543..d28bb82863 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -50,7 +50,7 @@ Extract Constant Rinv => "fun x -> 1 / x". Extraction "micromega.ml" List.map simpl_cone (*map_cone indexes*) - denorm Qpower + denorm Qpower vm_add n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index fafd8a5f21..8acf0ff882 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -8,7 +8,7 @@ (* *) (* Micromega: A reflexive tactic using the Positivstellensatz *) (* *) -(* Frédéric Besson (Irisa/Inria) 2006-2008 *) +(* Frédéric Besson (Irisa/Inria) 2006-2016 *) (* *) (************************************************************************) @@ -21,50 +21,24 @@ Require Import Rdefinitions. Require Import RingMicromega. Require Import VarMap. Require Coq.micromega.Tauto. -Declare ML Module "micromega_plugin". +Require Lia. +Require Lra. +Require Lqa. -Ltac preprocess := - zify ; unfold Z.succ in * ; unfold Z.pred in *. +Declare ML Module "micromega_plugin". -Ltac lia := - preprocess; - xlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac lia := Lia.lia. -Ltac nia := - preprocess; - xnlia ; - abstract ( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)). +Ltac nia := Lia.nia. Ltac xpsatz dom d := let tac := lazymatch dom with | Z => - (sos_Z || psatz_Z d) ; - abstract( - intros __wit __varmap __ff ; - change (Tauto.eval_f (Zeval_formula (@find Z Z0 __varmap)) __ff) ; - apply (ZTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true)) + (sos_Z Lia.zchecker) || (psatz_Z d Lia.zchecker) | R => - (sos_R || psatz_R d) ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) - | Q => - (sos_Q || psatz_Q d) ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) + (sos_R Lra.rchecker) || (psatz_R d Lra.rchecker) + | Q => (sos_Q Lqa.rchecker) || (psatz_Q d Lqa.rchecker) | _ => fail "Unsupported domain" end in tac. @@ -73,22 +47,9 @@ Tactic Notation "psatz" constr(dom) := xpsatz dom ltac:(-1). Ltac psatzl dom := let tac := lazymatch dom with - | Z => lia - | Q => - psatzl_Q ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try (abstract(intros __wit __varmap __ff ; - change (Tauto.eval_f (Qeval_formula (@find Q 0%Q __varmap)) __ff) ; - apply (QTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) - | R => - unfold Rdiv in * ; - psatzl_R ; - (* If csdp is not installed, the previous step might not produce any - progress: the rest of the tactical will then fail. Hence the 'try'. *) - try abstract((intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_cast_no_check (eq_refl true))) + | Z => Lia.lia + | Q => Lqa.lra + | R => Lra.lra | _ => fail "Unsupported domain" end in tac. @@ -97,13 +58,7 @@ Ltac lra := first [ psatzl R | psatzl Q ]. Ltac nra := - unfold Rdiv in * ; - xnra ; - abstract - (intros __wit __varmap __ff ; - change (Tauto.eval_f (Reval_formula (@find R 0%R __varmap)) __ff) ; - apply (RTautoChecker_sound __ff __wit); vm_compute ; reflexivity). - + first [ Lra.nra | Lqa.nra ]. (* Local Variables: *) diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index 4981ddb302..2d2c0bc77a 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -1,7 +1,7 @@ (* -*- coding: utf-8 -*- *) (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) (* \VV/ **************************************************************) (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) @@ -26,6 +26,7 @@ Set Implicit Arguments. *) Section MakeVarMap. + Variable A : Type. Variable default : A. @@ -46,5 +47,29 @@ Section MakeVarMap. end. -End MakeVarMap. + Fixpoint singleton (x:positive) (v : A) : t := + match x with + | xH => Leaf v + | xO p => Node (singleton p v) default Empty + | xI p => Node Empty default (singleton p v) + end. + + Fixpoint vm_add (x: positive) (v : A) (m : t) {struct m} : t := + match m with + | Empty => singleton x v + | Leaf vl => + match x with + | xH => Leaf v + | xO p => Node (singleton p v) vl Empty + | xI p => Node Empty vl (singleton p v) + end + | Node l o r => + match x with + | xH => Node l v r + | xI p => Node l o (vm_add p v r) + | xO p => Node (vm_add p v l) o r + end + end. + +End MakeVarMap. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 1561c811cd..459c72f9f6 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -331,7 +331,7 @@ let dual_raw_certificate (l: (Poly.t * Mc.op1) list) = | Inr _ -> None | Inl cert -> Some (rats_to_ints (Vect.to_list cert)) (* should not use rats_to_ints *) - with x when Errors.noncritical x -> + with x when CErrors.noncritical x -> if debug then (Printf.printf "raw certificate %s" (Printexc.to_string x); flush stdout) ; @@ -378,7 +378,7 @@ let linear_prover n_spec l = let linear_prover n_spec l = try linear_prover n_spec l - with x when Errors.noncritical x -> + with x when CErrors.noncritical x -> (print_string (Printexc.to_string x); None) let compute_max_nb_cstr l d = diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e4aa1448eb..a063cbbfe3 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -147,6 +147,17 @@ let rec map_atoms fct f = | N f -> N(map_atoms fct f) | I(f1,o,f2) -> I(map_atoms fct f1, o , map_atoms fct f2) +let rec map_prop fct f = + match f with + | TT -> TT + | FF -> FF + | X x -> X (fct x) + | A (at,tg,cstr) -> A(at,tg,cstr) + | C (f1,f2) -> C(map_prop fct f1, map_prop fct f2) + | D (f1,f2) -> D(map_prop fct f1, map_prop fct f2) + | N f -> N(map_prop fct f) + | I(f1,o,f2) -> I(map_prop fct f1, o , map_prop fct f2) + (** * Collect the identifiers of a (string of) implications. Implication labels * are inherited from Coq/CoC's higher order dependent type constructor (Pi). @@ -292,7 +303,8 @@ let rec add_term t0 = function *) module ISet = Set.Make(Int) - +module IMap = Map.Make(Int) + (** * Given a set of integers s=\{i0,...,iN\} and a list m, return the list of * elements of m that are at position i0,...,iN. @@ -371,6 +383,8 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") + let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) + let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") let coq_False = lazy (init_constant "False") @@ -947,8 +961,20 @@ struct let (env,n) = _add l ( n+1) v in (e::env,n) in let (env, n) = _add env 1 v in - (env, CamlToCoq.idx n) + (env, CamlToCoq.positive n) + + let get_rank env v = + + let rec _get_rank env n = + match env with + | [] -> raise (Invalid_argument "get_rank") + | e::l -> + if eq_constr e v + then n + else _get_rank l (n+1) in + _get_rank env 1 + let empty = [] let elements env = env @@ -998,7 +1024,7 @@ struct let (expr,env) = parse_expr env args.(0) in let power = (parse_exp expr args.(1)) in (power , env) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> (* if the exponent is a variable *) let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) end @@ -1170,36 +1196,35 @@ struct try let (at,env) = parse_atom env t gl in (A(at,tg,t), env,Tag.next tg) - with e when Errors.noncritical e -> (X(t),env,tg) in + with e when CErrors.noncritical e -> (X(t),env,tg) in let is_prop term = - let ty = Typing.unsafe_type_of (Tacmach.pf_env gl) (Tacmach.project gl) term in - let sort = Typing.e_sort_of (Tacmach.pf_env gl) (ref (Tacmach.project gl)) ty in + let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in Term.is_prop_sort sort in let rec xparse_formula env tg term = - match kind_of_term term with + match kind_of_term term with | App(l,rst) -> - (match rst with - | [|a;b|] when eq_constr l (Lazy.force coq_and) -> - let f,env,tg = xparse_formula env tg a in - let g,env, tg = xparse_formula env tg b in - mkformula_binary mkC term f g,env,tg - | [|a;b|] when eq_constr l (Lazy.force coq_or) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkD term f g,env,tg - | [|a|] when eq_constr l (Lazy.force coq_not) -> - let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> - let f,env,tg = xparse_formula env tg a in - let g,env,tg = xparse_formula env tg b in - mkformula_binary mkIff term f g,env,tg - | _ -> parse_atom env tg term) - | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> + (match rst with + | [|a;b|] when eq_constr l (Lazy.force coq_and) -> + let f,env,tg = xparse_formula env tg a in + let g,env, tg = xparse_formula env tg b in + mkformula_binary mkC term f g,env,tg + | [|a;b|] when eq_constr l (Lazy.force coq_or) -> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkD term f g,env,tg + | [|a|] when eq_constr l (Lazy.force coq_not) -> + let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) + | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in - mkformula_binary mkI term f g,env,tg + mkformula_binary mkIff term f g,env,tg + | _ -> parse_atom env tg term) + | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> + let f,env,tg = xparse_formula env tg a in + let g,env,tg = xparse_formula env tg b in + mkformula_binary mkI term f g,env,tg | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) | _ when is_prop term -> X(term),env,tg @@ -1220,12 +1245,214 @@ struct | X(t) -> mkApp(Lazy.force coq_X,[|typ ; t|]) in xdump f - (** - * Given a conclusion and a list of affectations, rebuild a term prefixed by - * the appropriate letins. - * TODO: reverse the list of bindings! - *) + let prop_env_of_formula form = + let rec doit env = function + | TT | FF | A(_,_,_) -> env + | X t -> fst (Env.compute_rank_add env t) + | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> + doit (doit env f1) f2 + | N f -> doit env f in + + doit [] form + + let var_env_of_formula form = + + let rec vars_of_expr = function + | Mc.PEX n -> ISet.singleton (CoqToCaml.positive n) + | Mc.PEc z -> ISet.empty + | Mc.PEadd(e1,e2) | Mc.PEmul(e1,e2) | Mc.PEsub(e1,e2) -> + ISet.union (vars_of_expr e1) (vars_of_expr e2) + | Mc.PEopp e | Mc.PEpow(e,_)-> vars_of_expr e + in + + let vars_of_atom {Mc.flhs ; Mc.fop; Mc.frhs} = + ISet.union (vars_of_expr flhs) (vars_of_expr frhs) in + + let rec doit = function + | TT | FF | X _ -> ISet.empty + | A (a,t,c) -> vars_of_atom a + | C(f1,f2) | D(f1,f2) |I (f1,_,f2) -> ISet.union (doit f1) (doit f2) + | N f -> doit f in + + doit form + + + + + type 'cst dump_expr = (* 'cst is the type of the syntactic constants *) + { + interp_typ : constr; + dump_cst : 'cst -> constr; + dump_add : constr; + dump_sub : constr; + dump_opp : constr; + dump_mul : constr; + dump_pow : constr; + dump_pow_arg : Mc.n -> constr; + dump_op : (Mc.op2 * Term.constr) list + } + +let dump_zexpr = lazy + { + interp_typ = Lazy.force coq_Z; + dump_cst = dump_z; + dump_add = Lazy.force coq_Zplus; + dump_sub = Lazy.force coq_Zminus; + dump_opp = Lazy.force coq_Zopp; + dump_mul = Lazy.force coq_Zmult; + dump_pow = Lazy.force coq_Zpower; + dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) zop_table + } + +let dump_qexpr = lazy + { + interp_typ = Lazy.force coq_Q; + dump_cst = dump_q; + dump_add = Lazy.force coq_Qplus; + dump_sub = Lazy.force coq_Qminus; + dump_opp = Lazy.force coq_Qopp; + dump_mul = Lazy.force coq_Qmult; + dump_pow = Lazy.force coq_Qpower; + dump_pow_arg = (fun n -> dump_z (CamlToCoq.z (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) qop_table + } + + let dump_positive_as_R p = + let mult = Lazy.force coq_Rmult in + let add = Lazy.force coq_Rplus in + + let one = Lazy.force coq_R1 in + let mk_add x y = mkApp(add,[|x;y|]) in + let mk_mult x y = mkApp(mult,[|x;y|]) in + + let two = mk_add one one in + + let rec dump_positive p = + match p with + | Mc.XH -> one + | Mc.XO p -> mk_mult two (dump_positive p) + | Mc.XI p -> mk_add one (mk_mult two (dump_positive p)) in + + dump_positive p + +let dump_n_as_R n = + let z = CoqToCaml.n n in + if z = 0 + then Lazy.force coq_R0 + else dump_positive_as_R (CamlToCoq.positive z) + + +let rec dump_Rcst_as_R cst = + match cst with + | Mc.C0 -> Lazy.force coq_R0 + | Mc.C1 -> Lazy.force coq_R1 + | Mc.CQ q -> Term.mkApp(Lazy.force coq_IQR, [| dump_q q |]) + | Mc.CZ z -> Term.mkApp(Lazy.force coq_IZR, [| dump_z z |]) + | Mc.CPlus(x,y) -> Term.mkApp(Lazy.force coq_Rplus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CMinus(x,y) -> Term.mkApp(Lazy.force coq_Rminus, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CMult(x,y) -> Term.mkApp(Lazy.force coq_Rmult, [| dump_Rcst_as_R x ; dump_Rcst_as_R y |]) + | Mc.CInv t -> Term.mkApp(Lazy.force coq_Rinv, [| dump_Rcst_as_R t |]) + | Mc.COpp t -> Term.mkApp(Lazy.force coq_Ropp, [| dump_Rcst_as_R t |]) + + +let dump_rexpr = lazy + { + interp_typ = Lazy.force coq_R; + dump_cst = dump_Rcst_as_R; + dump_add = Lazy.force coq_Rplus; + dump_sub = Lazy.force coq_Rminus; + dump_opp = Lazy.force coq_Ropp; + dump_mul = Lazy.force coq_Rmult; + dump_pow = Lazy.force coq_Rpower; + dump_pow_arg = (fun n -> dump_nat (CamlToCoq.nat (CoqToCaml.n n))); + dump_op = List.map (fun (x,y) -> (y,Lazy.force x)) rop_table + } + + + + +(** [make_goal_of_formula depxr vars props form] where + - vars is an environment for the arithmetic variables occuring in form + - props is an environment for the propositions occuring in form + @return a goal where all the variables and propositions of the formula are quantified + +*) + +let rec make_goal_of_formula dexpr form = + + let vars_idx = + List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in + + (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) + + let props = prop_env_of_formula form in + + let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in + let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in + + let var_name_pos = List.map2 (fun (idx,_) (id,_) -> id,idx) vars_idx vars_n in + + let dump_expr i e = + let rec dump_expr = function + | Mc.PEX n -> mkRel (i+(List.assoc (CoqToCaml.positive n) vars_idx)) + | Mc.PEc z -> dexpr.dump_cst z + | Mc.PEadd(e1,e2) -> mkApp(dexpr.dump_add, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEsub(e1,e2) -> mkApp(dexpr.dump_sub, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEopp e -> mkApp(dexpr.dump_opp, + [| dump_expr e|]) + | Mc.PEmul(e1,e2) -> mkApp(dexpr.dump_mul, + [| dump_expr e1;dump_expr e2|]) + | Mc.PEpow(e,n) -> mkApp(dexpr.dump_pow, + [| dump_expr e; dexpr.dump_pow_arg n|]) + in dump_expr e in + + let mkop op e1 e2 = + try + Term.mkApp(List.assoc op dexpr.dump_op, [| e1; e2|]) + with Not_found -> + Term.mkApp(Lazy.force coq_Eq,[|dexpr.interp_typ ; e1 ;e2|]) in + + let dump_cstr i { Mc.flhs ; Mc.fop ; Mc.frhs } = + mkop fop (dump_expr i flhs) (dump_expr i frhs) in + + let rec xdump pi xi f = + match f with + | TT -> Lazy.force coq_True + | FF -> Lazy.force coq_False + | C(x,y) -> mkApp(Lazy.force coq_and,[|xdump pi xi x ; xdump pi xi y|]) + | D(x,y) -> mkApp(Lazy.force coq_or,[| xdump pi xi x ; xdump pi xi y|]) + | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) + | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False) + | A(x,_,_) -> dump_cstr xi x + | X(t) -> let idx = Env.get_rank props t in + mkRel (pi+idx) in + + let nb_vars = List.length vars_n in + let nb_props = List.length props_n in + + (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) + + let subst_prop p = + let idx = Env.get_rank props p in + mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in + + let form' = map_prop subst_prop form in + + (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) + (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) + (xdump (List.length vars_n) 0 form)), + List.rev props_n, List.rev var_name_pos,form') + + (** + * Given a conclusion and a list of affectations, rebuild a term prefixed by + * the appropriate letins. + * TODO: reverse the list of bindings! + *) + let set l concl = let rec xset acc = function | [] -> acc @@ -1290,39 +1517,35 @@ let rec apply_ids t ids = | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids -let coq_Node = lazy +let coq_Node = (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = lazy +let coq_Leaf = (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = lazy +let coq_Empty = (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") -let btree_of_array typ a = - let size_of_a = Array.length a in - let semi_size_of_a = size_of_a lsr 1 in - let node = Lazy.force coq_Node - and leaf = Lazy.force coq_Leaf - and empty = Term.mkApp (Lazy.force coq_Empty, [| typ |]) in - let rec aux n = - if n > size_of_a - then empty - else if n > semi_size_of_a - then Term.mkApp (leaf, [| typ; a.(n-1) |]) - else Term.mkApp (node, [| typ; aux (2*n); a.(n-1); aux (2*n+1) |]) - in - aux 1 - -let btree_of_array typ a = - try - btree_of_array typ a - with x when Errors.noncritical x -> - failwith (Printf.sprintf "btree of array : %s" (Printexc.to_string x)) - -let dump_varmap typ env = - btree_of_array typ (Array.of_list env) +let coq_VarMap = + (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") + + +let rec dump_varmap typ m = + match m with + | Mc.Empty -> Term.mkApp(coq_Empty,[| typ |]) + | Mc.Leaf v -> Term.mkApp(coq_Leaf,[| typ; v|]) + | Mc.Node(l,o,r) -> + Term.mkApp (coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + + +let vm_of_list env = + match env with + | [] -> Mc.Empty + | (d,_)::_ -> + List.fold_left (fun vm (c,i) -> + Mc.vm_add d (CamlToCoq.positive i) c vm) Mc.Empty env let rec pp_varmap o vm = @@ -1387,7 +1610,7 @@ let rec parse_hyps gl parse_arith env tg hyps = try let (c,env,tg) = parse_formula gl parse_arith env tg t in ((i,c)::lhyps, env,tg) - with e when Errors.noncritical e -> (lhyps,env,tg) + with e when CErrors.noncritical e -> (lhyps,env,tg) (*(if debug then Printf.printf "parse_arith : %s\n" x);*) @@ -1437,17 +1660,46 @@ let rcst_domain_spec = lazy { open Proofview.Notations - +(** Naive topological sort of constr according to the subterm-ordering *) + +(* An element is minimal x is minimal w.r.t y if + x <= y or (x and y are incomparable) *) + +let is_min le x y = + if le x y then true + else if le y x then false else true + +let is_minimal le l c = List.for_all (is_min le c) l + +let find_rem p l = + let rec xfind_rem acc l = + match l with + | [] -> (None, acc) + | x :: l -> if p x then (Some x, acc @ l) + else xfind_rem (x::acc) l in + xfind_rem [] l + +let find_minimal le l = find_rem (is_minimal le l) l + +let rec mk_topo_order le l = + match find_minimal le l with + | (None , _) -> [] + | (Some v,l') -> v :: (mk_topo_order le l') + + +let topo_sort_constr l = mk_topo_order Termops.dependent l + + (** * Instanciate the current Coq goal with a Micromega formula, a varmap, and a * witness. *) let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic*) = - let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in + (* let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.coeff spec.dump_coeff) ff in - let vm = dump_varmap (spec.typ) env in + let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in @@ -1457,15 +1709,10 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|spec.typ|])); + ("__varmap", vm, Term.mkApp( coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl)) - ; - Tactics.generalize env ; - Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) ] end } @@ -1547,7 +1794,7 @@ let compact_proofs (cnf_ff: 'cst cnf) res (cnf_ff': 'cst cnf) = (pp_ml_list prover.pp_f) (List.map fst new_cl) ; flush stdout end ; *) - let res = try prover.compact prf remap with x when Errors.noncritical x -> + let res = try prover.compact prf remap with x when CErrors.noncritical x -> if debug then Printf.fprintf stdout "Proof compaction %s" (Printexc.to_string x) ; (* This should not happen -- this is the recovery plan... *) match prover.prover (prover.get_option () ,List.map fst new_cl) with @@ -1627,6 +1874,7 @@ let rec abstract_wrt_formula f1 f2 = exception CsdpNotFound + (** * This is the core of Micromega: apply the prover, analyze the result and * prune unused fomulas, and finally modify the proof state. @@ -1711,7 +1959,7 @@ let micromega_gen (negate:'cst atom -> 'cst mc_cnf) (normalise:'cst atom -> 'cst mc_cnf) unsat deduce - spec prover = + spec dumpexpr prover tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in @@ -1720,16 +1968,45 @@ let micromega_gen let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in + let dumpexpr = Lazy.force dumpexpr in match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> - (Tacticals.New.tclTHENLIST - [ - Tactics.generalize (List.map Term.mkVar ids) ; - micromega_order_change spec res' - (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env ff' - ]) + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in + let intro (id,_) = Tactics.introduction id in + + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + micromega_order_change spec res' + (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in + + let goal_props = List.rev (prop_env_of_formula ff') in + + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + + let arith_args = goal_props @ goal_vars in + + let kill_arith = + Tacticals.New.tclTHEN + (Tactics.keep []) + ((*Tactics.tclABSTRACT None*) + (Tacticals.New.tclTHEN tac_arith tac)) in + + Tacticals.New.tclTHENS + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + [ + kill_arith; + (Tacticals.New.tclTHENLIST + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + ] ) + ] with | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") @@ -1751,16 +2028,16 @@ let micromega_gen parse_arith let micromega_order_changer cert env ff = - let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__z"^(string_of_int i)))) 0 env in - let coeff = Lazy.force coq_Rcst in - let dump_coeff = dump_Rcst in - let typ = Lazy.force coq_R in - let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in + (*let ids = Util.List.map_i (fun i _ -> (Names.Id.of_string ("__v"^(string_of_int i)))) 0 env in *) + let coeff = Lazy.force coq_Rcst in + let dump_coeff = dump_Rcst in + let typ = Lazy.force coq_R in + let cert_typ = (Term.mkApp(Lazy.force coq_list, [|Lazy.force coq_QWitness |])) in - let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in - let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in - let vm = dump_varmap (typ) env in - Proofview.Goal.nf_enter { enter = begin fun gl -> + let formula_typ = (Term.mkApp (Lazy.force coq_Cstr,[| coeff|])) in + let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in + let vm = dump_varmap (typ) (vm_of_list env) in + Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ @@ -1774,13 +2051,11 @@ let micromega_order_changer cert env ff = ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl))); - Tactics.generalize env ; - Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids) + (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] end } - -let micromega_genr prover = +let micromega_genr prover tac = let parse_arith = parse_rarith in let negate = Mc.rnegate in let normalise = Mc.rnormalise in @@ -1797,6 +2072,7 @@ let micromega_genr prover = let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in let hyps = Tacmach.pf_hyps_types gl in + try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in let env = Env.elements env in @@ -1808,23 +2084,56 @@ let micromega_genr prover = match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> - let (ff,ids') = formula_hyps_concl + let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in + let ff' = abstract_wrt_formula ff' ff in + + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in + let intro (id,_) = Tactics.introduction id in + + let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in + let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in + let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in + let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in + + let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; + micromega_order_changer res' env' ff_arith ] in + + let goal_props = List.rev (prop_env_of_formula ff') in + + let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in + + let arith_args = goal_props @ goal_vars in + + let kill_arith = + Tacticals.New.tclTHEN + (Tactics.keep []) + ((*Tactics.tclABSTRACT None*) + (Tacticals.New.tclTHEN tac_arith tac)) in + + Tacticals.New.tclTHENS + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + [ + kill_arith; (Tacticals.New.tclTHENLIST - [ - Tactics.generalize (List.map Term.mkVar ids) ; - micromega_order_changer res' env (abstract_wrt_formula ff' ff) - ]) - with - | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "TimeOut") - | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | CsdpNotFound -> - Tacticals.New.tclFAIL 0 (Pp.str - (" Skipping what remains of this tactic: the complexity of the goal requires " - ^ "the use of a specialized external tool called csdp. \n\n" - ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" - ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) - end } + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + ] ) + ] + + with + | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") + | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") + | CsdpNotFound -> flush stdout ; + Tacticals.New.tclFAIL 0 (Pp.str + (" Skipping what remains of this tactic: the complexity of the goal requires " + ^ "the use of a specialized external tool called csdp. \n\n" + ^ "Unfortunately Coq isn't aware of the presence of any \"csdp\" executable in the path. \n\n" + ^ "Csdp packages are provided by some OS distributions; binaries and source code can be downloaded from https://projects.coin-or.org/Csdp")) + end } + + let micromega_genr prover = (micromega_genr prover) @@ -1851,7 +2160,7 @@ module Cache = PHashtable(struct let hash = Hashtbl.hash end) -let csdp_cache = "csdp.cache" +let csdp_cache = ".csdp.cache" (** * Build the command to call csdpcert, and launch it. This in turn will call @@ -1997,9 +2306,9 @@ module CacheQ = PHashtable(struct let hash = Hashtbl.hash end) -let memo_zlinear_prover = CacheZ.memo "lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) -let memo_nlia = CacheZ.memo "nlia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) -let memo_nra = CacheQ.memo "nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) +let memo_zlinear_prover = CacheZ.memo ".lia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.lia ce b) s) +let memo_nlia = CacheZ.memo ".nia.cache" (fun ((ce,b),s) -> lift_pexpr_prover (Certificate.nlia ce b) s) +let memo_nra = CacheQ.memo ".nra.cache" (fun (o,s) -> lift_pexpr_prover (Certificate.nlinear_prover o) s) @@ -2064,7 +2373,6 @@ let non_linear_prover_Z str o = { pp_f = fun o x -> pp_pol pp_z o (fst x) } - let linear_Z = { name = "lia"; get_option = get_lia_option; @@ -2100,19 +2408,15 @@ let tauto_lia ff = * solvers *) -let psatzl_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec - [ linear_Z ] - -let psatzl_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec +let lra_Q = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ linear_prover_Q ] let psatz_Q i = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ non_linear_prover_Q "real_nonlinear_prover" (Some i) ] -let psatzl_R = +let lra_R = micromega_genr [ linear_prover_R ] let psatz_R i = @@ -2120,15 +2424,15 @@ let psatz_R i = let psatz_Z i = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ non_linear_prover_Z "real_nonlinear_prover" (Some i) ] let sos_Z = - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ non_linear_prover_Z "pure_sos" None ] let sos_Q = - micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr [ non_linear_prover_Q "pure_sos" None ] @@ -2136,21 +2440,21 @@ let sos_R = micromega_genr [ non_linear_prover_R "pure_sos" None ] -let xlia = - try - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec +let xlia = micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ linear_Z ] - with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise let xnlia = - try - micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec + micromega_gen parse_zarith Mc.negate Mc.normalise Mc.zunsat Mc.zdeduce zz_domain_spec dump_zexpr [ nlinear_Z ] - with reraise -> (*Printexc.print_backtrace stdout ;*) raise reraise let nra = micromega_genr [ nlinear_prover_R ] +let nqa = + micromega_gen parse_qarith Mc.qnegate Mc.qnormalise Mc.qunsat Mc.qdeduce qq_domain_spec dump_qexpr + [ nlinear_prover_R ] + + (* Local Variables: *) (* coding: utf-8 *) diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index e6b5cc60d4..027f690fca 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -20,50 +20,64 @@ open Constrarg DECLARE PLUGIN "micromega_plugin" +TACTIC EXTEND RED +| [ "myred" ] -> [ Tactics.red_in_concl ] +END + + + TACTIC EXTEND PsatzZ -| [ "psatz_Z" int_or_var(i) ] -> [ (Coq_micromega.psatz_Z i) ] -| [ "psatz_Z" ] -> [ (Coq_micromega.psatz_Z (-1)) ] +| [ "psatz_Z" int_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) ] END TACTIC EXTEND Lia -[ "xlia" ] -> [ (Coq_micromega.xlia) ] +[ "xlia" tactic(t) ] -> [ (Coq_micromega.xlia (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Nia -[ "xnlia" ] -> [ (Coq_micromega.xnlia) ] +[ "xnlia" tactic(t) ] -> [ (Coq_micromega.xnlia (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND NRA -[ "xnra" ] -> [ (Coq_micromega.nra)] +[ "xnra" tactic(t) ] -> [ (Coq_micromega.nra (Tacinterp.tactic_of_value ist t))] END +TACTIC EXTEND NQA +[ "xnqa" tactic(t) ] -> [ (Coq_micromega.nqa (Tacinterp.tactic_of_value ist t))] +END + + + TACTIC EXTEND Sos_Z -| [ "sos_Z" ] -> [ (Coq_micromega.sos_Z) ] +| [ "sos_Z" tactic(t) ] -> [ (Coq_micromega.sos_Z (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_Q -| [ "sos_Q" ] -> [ (Coq_micromega.sos_Q) ] +| [ "sos_Q" tactic(t) ] -> [ (Coq_micromega.sos_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND Sos_R -| [ "sos_R" ] -> [ (Coq_micromega.sos_R) ] +| [ "sos_R" tactic(t) ] -> [ (Coq_micromega.sos_R (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND LRA_Q -[ "psatzl_Q" ] -> [ (Coq_micromega.psatzl_Q) ] +[ "lra_Q" tactic(t) ] -> [ (Coq_micromega.lra_Q (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND LRA_R -[ "psatzl_R" ] -> [ (Coq_micromega.psatzl_R) ] +[ "lra_R" tactic(t) ] -> [ (Coq_micromega.lra_R (Tacinterp.tactic_of_value ist t)) ] END TACTIC EXTEND PsatzR -| [ "psatz_R" int_or_var(i) ] -> [ (Coq_micromega.psatz_R i) ] -| [ "psatz_R" ] -> [ (Coq_micromega.psatz_R (-1)) ] +| [ "psatz_R" int_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) ] -> [ (Coq_micromega.psatz_Q i) ] -| [ "psatz_Q" ] -> [ (Coq_micromega.psatz_Q (-1)) ] +| [ "psatz_Q" int_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/mfourier.ml b/plugins/micromega/mfourier.ml index e22fe58434..f4f9b3c2f1 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -734,7 +734,7 @@ struct | Inl (s,_) -> try Some (bound_of_variable IMap.empty fresh s.sys) - with x when Errors.noncritical x -> + with x when CErrors.noncritical x -> Printf.printf "optimise Exception : %s" (Printexc.to_string x); None diff --git a/plugins/micromega/micromega.ml b/plugins/micromega/micromega.ml index 0537cdbe8b..5cf1da8ea8 100644 --- a/plugins/micromega/micromega.ml +++ b/plugins/micromega/micromega.ml @@ -1,6 +1,3 @@ -type __ = Obj.t -let __ = let rec f _ = Obj.repr f in Obj.repr f - (** val negb : bool -> bool **) let negb = function @@ -11,16 +8,6 @@ type nat = | O | S of nat -(** val fst : ('a1 * 'a2) -> 'a1 **) - -let fst = function -| x,y -> x - -(** val snd : ('a1 * 'a2) -> 'a2 **) - -let snd = function -| x,y -> y - (** val app : 'a1 list -> 'a1 list -> 'a1 list **) let rec app l m = @@ -40,42 +27,15 @@ let compOpp = function | Lt -> Gt | Gt -> Lt -type compareSpecT = -| CompEqT -| CompLtT -| CompGtT - -(** val compareSpec2Type : comparison -> compareSpecT **) - -let compareSpec2Type = function -| Eq -> CompEqT -| Lt -> CompLtT -| Gt -> CompGtT - -type 'a compSpecT = compareSpecT - -(** val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT **) - -let compSpec2Type x y c = - compareSpec2Type c - -type 'a sig0 = - 'a - (* singleton inductive, whose constructor was exist *) - -(** val plus : nat -> nat -> nat **) - -let rec plus n0 m = - match n0 with - | O -> m - | S p -> S (plus p m) - -(** val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) +module Coq__1 = struct + (** val add : nat -> nat -> nat **) + let rec add n0 m = + match n0 with + | O -> m + | S p -> S (add p m) +end +let add = Coq__1.add -let rec nat_iter n0 f x = - match n0 with - | O -> x - | S n' -> f (nat_iter n' f x) type positive = | XI of positive @@ -91,592 +51,25 @@ type z = | Zpos of positive | Zneg of positive -module type TotalOrder' = - sig - type t - end - -module MakeOrderTac = - functor (O:TotalOrder') -> - struct - - end - -module MaxLogicalProperties = - functor (O:TotalOrder') -> - functor (M:sig - val max : O.t -> O.t -> O.t - end) -> - struct - module T = MakeOrderTac(O) - end - -module Pos = - struct - type t = positive - - (** val succ : positive -> positive **) - - let rec succ = function - | XI p -> XO (succ p) - | XO p -> XI p - | XH -> XO XH - - (** val add : positive -> positive -> positive **) - - let rec add x y = - match x with - | XI p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XO p -> - (match y with - | XI q0 -> XI (add p q0) - | XO q0 -> XO (add p q0) - | XH -> XI p) - | XH -> - (match y with - | XI q0 -> XO (succ q0) - | XO q0 -> XI q0 - | XH -> XO XH) - - (** val add_carry : positive -> positive -> positive **) - - and add_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> XI (add_carry p q0) - | XO q0 -> XO (add_carry p q0) - | XH -> XI (succ p)) - | XO p -> - (match y with - | XI q0 -> XO (add_carry p q0) - | XO q0 -> XI (add p q0) - | XH -> XO (succ p)) - | XH -> - (match y with - | XI q0 -> XI (succ q0) - | XO q0 -> XO (succ q0) - | XH -> XI XH) - - (** val pred_double : positive -> positive **) - - let rec pred_double = function - | XI p -> XI (XO p) - | XO p -> XI (pred_double p) - | XH -> XH - - (** val pred : positive -> positive **) - - let pred = function - | XI p -> XO p - | XO p -> pred_double p - | XH -> XH - - (** val pred_N : positive -> n **) - - let pred_N = function - | XI p -> Npos (XO p) - | XO p -> Npos (pred_double p) - | XH -> N0 - +module Pos = + struct type mask = | IsNul | IsPos of positive | IsNeg - - (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rect f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rec f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val succ_double_mask : mask -> mask **) - - let succ_double_mask = function - | IsNul -> IsPos XH - | IsPos p -> IsPos (XI p) - | IsNeg -> IsNeg - - (** val double_mask : mask -> mask **) - - let double_mask = function - | IsPos p -> IsPos (XO p) - | x0 -> x0 - - (** val double_pred_mask : positive -> mask **) - - let double_pred_mask = function - | XI p -> IsPos (XO (XO p)) - | XO p -> IsPos (XO (pred_double p)) - | XH -> IsNul - - (** val pred_mask : mask -> mask **) - - let pred_mask = function - | IsPos q0 -> - (match q0 with - | XH -> IsNul - | _ -> IsPos (pred q0)) - | _ -> IsNeg - - (** val sub_mask : positive -> positive -> mask **) - - let rec sub_mask x y = - match x with - | XI p -> - (match y with - | XI q0 -> double_mask (sub_mask p q0) - | XO q0 -> succ_double_mask (sub_mask p q0) - | XH -> IsPos (XO p)) - | XO p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XH -> - (match y with - | XH -> IsNul - | _ -> IsNeg) - - (** val sub_mask_carry : positive -> positive -> mask **) - - and sub_mask_carry x y = - match x with - | XI p -> - (match y with - | XI q0 -> succ_double_mask (sub_mask_carry p q0) - | XO q0 -> double_mask (sub_mask p q0) - | XH -> IsPos (pred_double p)) - | XO p -> - (match y with - | XI q0 -> double_mask (sub_mask_carry p q0) - | XO q0 -> succ_double_mask (sub_mask_carry p q0) - | XH -> double_pred_mask p) - | XH -> IsNeg - - (** val sub : positive -> positive -> positive **) - - let sub x y = - match sub_mask x y with - | IsPos z0 -> z0 - | _ -> XH - - (** val mul : positive -> positive -> positive **) - - let rec mul x y = - match x with - | XI p -> add y (XO (mul p y)) - | XO p -> XO (mul p y) - | XH -> y - - (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let rec iter n0 f x = - match n0 with - | XI n' -> f (iter n' f (iter n' f x)) - | XO n' -> iter n' f (iter n' f x) - | XH -> f x - - (** val pow : positive -> positive -> positive **) - - let pow x y = - iter y (mul x) XH - - (** val div2 : positive -> positive **) - - let div2 = function - | XI p2 -> p2 - | XO p2 -> p2 - | XH -> XH - - (** val div2_up : positive -> positive **) - - let div2_up = function - | XI p2 -> succ p2 - | XO p2 -> p2 - | XH -> XH - - (** val size_nat : positive -> nat **) - - let rec size_nat = function - | XI p2 -> S (size_nat p2) - | XO p2 -> S (size_nat p2) - | XH -> S O - - (** val size : positive -> positive **) - - let rec size = function - | XI p2 -> succ (size p2) - | XO p2 -> succ (size p2) - | XH -> XH - - (** val compare_cont : positive -> positive -> comparison -> comparison **) - - let rec compare_cont x y r = - match x with - | XI p -> - (match y with - | XI q0 -> compare_cont p q0 r - | XO q0 -> compare_cont p q0 Gt - | XH -> Gt) - | XO p -> - (match y with - | XI q0 -> compare_cont p q0 Lt - | XO q0 -> compare_cont p q0 r - | XH -> Gt) - | XH -> - (match y with - | XH -> r - | _ -> Lt) - - (** val compare : positive -> positive -> comparison **) - - let compare x y = - compare_cont x y Eq - - (** val min : positive -> positive -> positive **) - - let min p p' = - match compare p p' with - | Gt -> p' - | _ -> p - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> - (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> - (match q0 with - | XH -> true - | _ -> false) - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : positive -> positive -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) - -> positive * mask **) - - let sqrtrem_step f g = function - | s,y -> - (match y with - | IsPos r -> - let s' = XI (XO s) in - let r' = g (f r) in - if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') - | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) - - (** val sqrtrem : positive -> positive * mask **) - - let rec sqrtrem = function - | XI p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) - | XH -> XH,(IsPos (XO XH))) - | XO p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) - | XH -> XH,(IsPos XH)) - | XH -> XH,IsNul - - (** val sqrt : positive -> positive **) - - let sqrt p = - fst (sqrtrem p) - - (** val gcdn : nat -> positive -> positive -> positive **) - - let rec gcdn n0 a b = - match n0 with - | O -> XH - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a - | Lt -> gcdn n1 (sub b' a') a - | Gt -> gcdn n1 (sub a' b') b) - | XO b0 -> gcdn n1 a b0 - | XH -> XH) - | XO a0 -> - (match b with - | XI p -> gcdn n1 a0 b - | XO b0 -> XO (gcdn n1 a0 b0) - | XH -> XH) - | XH -> XH) - - (** val gcd : positive -> positive -> positive **) - - let gcd a b = - gcdn (plus (size_nat a) (size_nat b)) a b - - (** val ggcdn : - nat -> positive -> positive -> positive * (positive * positive) **) - - let rec ggcdn n0 a b = - match n0 with - | O -> XH,(a,b) - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a,(XH,XH) - | Lt -> - let g,p = ggcdn n1 (sub b' a') a in - let ba,aa = p in g,(aa,(add aa (XO ba))) - | Gt -> - let g,p = ggcdn n1 (sub a' b') b in - let ab,bb = p in g,((add bb (XO ab)),bb)) - | XO b0 -> - let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) - | XH -> XH,(a,XH)) - | XO a0 -> - (match b with - | XI p -> - let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) - | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p - | XH -> XH,(a,XH)) - | XH -> XH,(XH,b)) - - (** val ggcd : positive -> positive -> positive * (positive * positive) **) - - let ggcd a b = - ggcdn (plus (size_nat a) (size_nat b)) a b - - (** val coq_Nsucc_double : n -> n **) - - let coq_Nsucc_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val coq_Ndouble : n -> n **) - - let coq_Ndouble = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val coq_lor : positive -> positive -> positive **) - - let rec coq_lor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XI (coq_lor p2 q1) - | XH -> p) - | XO p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XO (coq_lor p2 q1) - | XH -> XI p2) - | XH -> - (match q0 with - | XO q1 -> XI q1 - | _ -> q0) - - (** val coq_land : positive -> positive -> n **) - - let rec coq_land p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> Npos XH) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> N0) - | XH -> - (match q0 with - | XO q1 -> N0 - | _ -> Npos XH) - - (** val ldiff : positive -> positive -> n **) - - let rec ldiff p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Nsucc_double (ldiff p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Ndouble (ldiff p2 q1) - | XH -> Npos p) - | XH -> - (match q0 with - | XO q1 -> Npos XH - | _ -> N0) - - (** val coq_lxor : positive -> positive -> n **) - - let rec coq_lxor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_lxor p2 q1) - | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XO q1 -> coq_Ndouble (coq_lxor p2 q1) - | XH -> Npos (XI p2)) - | XH -> - (match q0 with - | XI q1 -> Npos (XO q1) - | XO q1 -> Npos (XI q1) - | XH -> N0) - - (** val shiftl_nat : positive -> nat -> positive **) - - let shiftl_nat p n0 = - nat_iter n0 (fun x -> XO x) p - - (** val shiftr_nat : positive -> nat -> positive **) - - let shiftr_nat p n0 = - nat_iter n0 div2 p - - (** val shiftl : positive -> n -> positive **) - - let shiftl p = function - | N0 -> p - | Npos n1 -> iter n1 (fun x -> XO x) p - - (** val shiftr : positive -> n -> positive **) - - let shiftr p = function - | N0 -> p - | Npos n1 -> iter n1 div2 p - - (** val testbit_nat : positive -> nat -> bool **) - - let rec testbit_nat p n0 = - match p with - | XI p2 -> - (match n0 with - | O -> true - | S n' -> testbit_nat p2 n') - | XO p2 -> - (match n0 with - | O -> false - | S n' -> testbit_nat p2 n') - | XH -> - (match n0 with - | O -> true - | S n1 -> false) - - (** val testbit : positive -> n -> bool **) - - let rec testbit p n0 = - match p with - | XI p2 -> - (match n0 with - | N0 -> true - | Npos n1 -> testbit p2 (pred_N n1)) - | XO p2 -> - (match n0 with - | N0 -> false - | Npos n1 -> testbit p2 (pred_N n1)) - | XH -> - (match n0 with - | N0 -> true - | Npos p2 -> false) - - (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) - - let rec iter_op op p a = - match p with - | XI p2 -> op a (iter_op op p2 (op a a)) - | XO p2 -> iter_op op p2 (op a a) - | XH -> a - - (** val to_nat : positive -> nat **) - - let to_nat x = - iter_op plus x (S O) - - (** val of_nat : nat -> positive **) - - let rec of_nat = function - | O -> XH - | S x -> - (match x with - | O -> XH - | S n1 -> succ (of_nat x)) - - (** val of_succ_nat : nat -> positive **) - - let rec of_succ_nat = function - | O -> XH - | S x -> succ (of_succ_nat x) end -module Coq_Pos = - struct - module Coq__1 = struct - type t = positive - end - type t = Coq__1.t - +module Coq_Pos = + struct (** val succ : positive -> positive **) - + let rec succ = function | XI p -> XO (succ p) | XO p -> XI p | XH -> XO XH - + (** val add : positive -> positive -> positive **) - + let rec add x y = match x with | XI p -> @@ -694,9 +87,9 @@ module Coq_Pos = | XI q0 -> XO (succ q0) | XO q0 -> XI q0 | XH -> XO XH) - + (** val add_carry : positive -> positive -> positive **) - + and add_carry x y = match x with | XI p -> @@ -714,78 +107,41 @@ module Coq_Pos = | XI q0 -> XI (succ q0) | XO q0 -> XO (succ q0) | XH -> XI XH) - + (** val pred_double : positive -> positive **) - + let rec pred_double = function | XI p -> XI (XO p) | XO p -> XI (pred_double p) | XH -> XH - - (** val pred : positive -> positive **) - - let pred = function - | XI p -> XO p - | XO p -> pred_double p - | XH -> XH - - (** val pred_N : positive -> n **) - - let pred_N = function - | XI p -> Npos (XO p) - | XO p -> Npos (pred_double p) - | XH -> N0 - + type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg - - (** val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rect f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - - (** val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 **) - - let mask_rec f f0 f1 = function - | IsNul -> f - | IsPos x -> f0 x - | IsNeg -> f1 - + (** val succ_double_mask : mask -> mask **) - + let succ_double_mask = function | IsNul -> IsPos XH | IsPos p -> IsPos (XI p) | IsNeg -> IsNeg - + (** val double_mask : mask -> mask **) - + let double_mask = function | IsPos p -> IsPos (XO p) | x0 -> x0 - + (** val double_pred_mask : positive -> mask **) - + let double_pred_mask = function | XI p -> IsPos (XO (XO p)) | XO p -> IsPos (XO (pred_double p)) | XH -> IsNul - - (** val pred_mask : mask -> mask **) - - let pred_mask = function - | IsPos q0 -> - (match q0 with - | XH -> IsNul - | _ -> IsPos (pred q0)) - | _ -> IsNeg - + (** val sub_mask : positive -> positive -> mask **) - + let rec sub_mask x y = match x with | XI p -> @@ -802,9 +158,9 @@ module Coq_Pos = (match y with | XH -> IsNul | _ -> IsNeg) - + (** val sub_mask_carry : positive -> positive -> mask **) - + and sub_mask_carry x y = match x with | XI p -> @@ -818,167 +174,56 @@ module Coq_Pos = | XO q0 -> succ_double_mask (sub_mask_carry p q0) | XH -> double_pred_mask p) | XH -> IsNeg - + (** val sub : positive -> positive -> positive **) - + let sub x y = match sub_mask x y with | IsPos z0 -> z0 | _ -> XH - + (** val mul : positive -> positive -> positive **) - + let rec mul x y = match x with | XI p -> add y (XO (mul p y)) | XO p -> XO (mul p y) | XH -> y - - (** val iter : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let rec iter n0 f x = - match n0 with - | XI n' -> f (iter n' f (iter n' f x)) - | XO n' -> iter n' f (iter n' f x) - | XH -> f x - - (** val pow : positive -> positive -> positive **) - - let pow x y = - iter y (mul x) XH - - (** val div2 : positive -> positive **) - - let div2 = function - | XI p2 -> p2 - | XO p2 -> p2 - | XH -> XH - - (** val div2_up : positive -> positive **) - - let div2_up = function - | XI p2 -> succ p2 - | XO p2 -> p2 - | XH -> XH - + (** val size_nat : positive -> nat **) - + let rec size_nat = function | XI p2 -> S (size_nat p2) | XO p2 -> S (size_nat p2) | XH -> S O - - (** val size : positive -> positive **) - - let rec size = function - | XI p2 -> succ (size p2) - | XO p2 -> succ (size p2) - | XH -> XH - - (** val compare_cont : positive -> positive -> comparison -> comparison **) - - let rec compare_cont x y r = + + (** val compare_cont : + comparison -> positive -> positive -> comparison **) + + let rec compare_cont r x y = match x with | XI p -> (match y with - | XI q0 -> compare_cont p q0 r - | XO q0 -> compare_cont p q0 Gt + | XI q0 -> compare_cont r p q0 + | XO q0 -> compare_cont Gt p q0 | XH -> Gt) | XO p -> (match y with - | XI q0 -> compare_cont p q0 Lt - | XO q0 -> compare_cont p q0 r + | XI q0 -> compare_cont Lt p q0 + | XO q0 -> compare_cont r p q0 | XH -> Gt) | XH -> (match y with | XH -> r | _ -> Lt) - + (** val compare : positive -> positive -> comparison **) - - let compare x y = - compare_cont x y Eq - - (** val min : positive -> positive -> positive **) - - let min p p' = - match compare p p' with - | Gt -> p' - | _ -> p - - (** val max : positive -> positive -> positive **) - - let max p p' = - match compare p p' with - | Gt -> p - | _ -> p' - - (** val eqb : positive -> positive -> bool **) - - let rec eqb p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> eqb p2 q1 - | _ -> false) - | XO p2 -> - (match q0 with - | XO q1 -> eqb p2 q1 - | _ -> false) - | XH -> - (match q0 with - | XH -> true - | _ -> false) - - (** val leb : positive -> positive -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : positive -> positive -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) - -> positive * mask **) - - let sqrtrem_step f g = function - | s,y -> - (match y with - | IsPos r -> - let s' = XI (XO s) in - let r' = g (f r) in - if leb s' r' then (XI s),(sub_mask r' s') else (XO s),(IsPos r') - | _ -> (XO s),(sub_mask (g (f XH)) (XO (XO XH)))) - - (** val sqrtrem : positive -> positive * mask **) - - let rec sqrtrem = function - | XI p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XI x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XI x) (sqrtrem p3) - | XH -> XH,(IsPos (XO XH))) - | XO p2 -> - (match p2 with - | XI p3 -> sqrtrem_step (fun x -> XI x) (fun x -> XO x) (sqrtrem p3) - | XO p3 -> sqrtrem_step (fun x -> XO x) (fun x -> XO x) (sqrtrem p3) - | XH -> XH,(IsPos XH)) - | XH -> XH,IsNul - - (** val sqrt : positive -> positive **) - - let sqrt p = - fst (sqrtrem p) - + + let compare = + compare_cont Eq + (** val gcdn : nat -> positive -> positive -> positive **) - + let rec gcdn n0 a b = match n0 with | O -> XH @@ -995,1001 +240,30 @@ module Coq_Pos = | XH -> XH) | XO a0 -> (match b with - | XI p -> gcdn n1 a0 b + | XI _ -> gcdn n1 a0 b | XO b0 -> XO (gcdn n1 a0 b0) | XH -> XH) | XH -> XH) - + (** val gcd : positive -> positive -> positive **) - + let gcd a b = - gcdn (plus (size_nat a) (size_nat b)) a b - - (** val ggcdn : - nat -> positive -> positive -> positive * (positive * positive) **) - - let rec ggcdn n0 a b = - match n0 with - | O -> XH,(a,b) - | S n1 -> - (match a with - | XI a' -> - (match b with - | XI b' -> - (match compare a' b' with - | Eq -> a,(XH,XH) - | Lt -> - let g,p = ggcdn n1 (sub b' a') a in - let ba,aa = p in g,(aa,(add aa (XO ba))) - | Gt -> - let g,p = ggcdn n1 (sub a' b') b in - let ab,bb = p in g,((add bb (XO ab)),bb)) - | XO b0 -> - let g,p = ggcdn n1 a b0 in let aa,bb = p in g,(aa,(XO bb)) - | XH -> XH,(a,XH)) - | XO a0 -> - (match b with - | XI p -> - let g,p2 = ggcdn n1 a0 b in let aa,bb = p2 in g,((XO aa),bb) - | XO b0 -> let g,p = ggcdn n1 a0 b0 in (XO g),p - | XH -> XH,(a,XH)) - | XH -> XH,(XH,b)) - - (** val ggcd : positive -> positive -> positive * (positive * positive) **) - - let ggcd a b = - ggcdn (plus (size_nat a) (size_nat b)) a b - - (** val coq_Nsucc_double : n -> n **) - - let coq_Nsucc_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val coq_Ndouble : n -> n **) - - let coq_Ndouble = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val coq_lor : positive -> positive -> positive **) - - let rec coq_lor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XI (coq_lor p2 q1) - | XH -> p) - | XO p2 -> - (match q0 with - | XI q1 -> XI (coq_lor p2 q1) - | XO q1 -> XO (coq_lor p2 q1) - | XH -> XI p2) - | XH -> - (match q0 with - | XO q1 -> XI q1 - | _ -> q0) - - (** val coq_land : positive -> positive -> n **) - - let rec coq_land p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> Npos XH) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_land p2 q1) - | XO q1 -> coq_Ndouble (coq_land p2 q1) - | XH -> N0) - | XH -> - (match q0 with - | XO q1 -> N0 - | _ -> Npos XH) - - (** val ldiff : positive -> positive -> n **) - - let rec ldiff p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Nsucc_double (ldiff p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (ldiff p2 q1) - | XO q1 -> coq_Ndouble (ldiff p2 q1) - | XH -> Npos p) - | XH -> - (match q0 with - | XO q1 -> Npos XH - | _ -> N0) - - (** val coq_lxor : positive -> positive -> n **) - - let rec coq_lxor p q0 = - match p with - | XI p2 -> - (match q0 with - | XI q1 -> coq_Ndouble (coq_lxor p2 q1) - | XO q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XH -> Npos (XO p2)) - | XO p2 -> - (match q0 with - | XI q1 -> coq_Nsucc_double (coq_lxor p2 q1) - | XO q1 -> coq_Ndouble (coq_lxor p2 q1) - | XH -> Npos (XI p2)) - | XH -> - (match q0 with - | XI q1 -> Npos (XO q1) - | XO q1 -> Npos (XI q1) - | XH -> N0) - - (** val shiftl_nat : positive -> nat -> positive **) - - let shiftl_nat p n0 = - nat_iter n0 (fun x -> XO x) p - - (** val shiftr_nat : positive -> nat -> positive **) - - let shiftr_nat p n0 = - nat_iter n0 div2 p - - (** val shiftl : positive -> n -> positive **) - - let shiftl p = function - | N0 -> p - | Npos n1 -> iter n1 (fun x -> XO x) p - - (** val shiftr : positive -> n -> positive **) - - let shiftr p = function - | N0 -> p - | Npos n1 -> iter n1 div2 p - - (** val testbit_nat : positive -> nat -> bool **) - - let rec testbit_nat p n0 = - match p with - | XI p2 -> - (match n0 with - | O -> true - | S n' -> testbit_nat p2 n') - | XO p2 -> - (match n0 with - | O -> false - | S n' -> testbit_nat p2 n') - | XH -> - (match n0 with - | O -> true - | S n1 -> false) - - (** val testbit : positive -> n -> bool **) - - let rec testbit p n0 = - match p with - | XI p2 -> - (match n0 with - | N0 -> true - | Npos n1 -> testbit p2 (pred_N n1)) - | XO p2 -> - (match n0 with - | N0 -> false - | Npos n1 -> testbit p2 (pred_N n1)) - | XH -> - (match n0 with - | N0 -> true - | Npos p2 -> false) - - (** val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 **) - - let rec iter_op op p a = - match p with - | XI p2 -> op a (iter_op op p2 (op a a)) - | XO p2 -> iter_op op p2 (op a a) - | XH -> a - - (** val to_nat : positive -> nat **) - - let to_nat x = - iter_op plus x (S O) - - (** val of_nat : nat -> positive **) - - let rec of_nat = function - | O -> XH - | S x -> - (match x with - | O -> XH - | S n1 -> succ (of_nat x)) - + gcdn (Coq__1.add (size_nat a) (size_nat b)) a b + (** val of_succ_nat : nat -> positive **) - + let rec of_succ_nat = function | O -> XH | S x -> succ (of_succ_nat x) - - (** val eq_dec : positive -> positive -> bool **) - - let rec eq_dec p y0 = - match p with - | XI p2 -> - (match y0 with - | XI p3 -> eq_dec p2 p3 - | _ -> false) - | XO p2 -> - (match y0 with - | XO p3 -> eq_dec p2 p3 - | _ -> false) - | XH -> - (match y0 with - | XH -> true - | _ -> false) - - (** val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) - - let rec peano_rect a f p = - let f2 = peano_rect (f XH a) (fun p2 x -> f (succ (XO p2)) (f (XO p2) x)) - in - (match p with - | XI q0 -> f (XO q0) (f2 q0) - | XO q0 -> f2 q0 - | XH -> a) - - (** val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 **) - - let peano_rec = - peano_rect - - type coq_PeanoView = - | PeanoOne - | PeanoSucc of positive * coq_PeanoView - - (** val coq_PeanoView_rect : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_rect f f0 p = function - | PeanoOne -> f - | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rect f f0 p3 p4) - - (** val coq_PeanoView_rec : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_rec f f0 p = function - | PeanoOne -> f - | PeanoSucc (p3, p4) -> f0 p3 p4 (coq_PeanoView_rec f f0 p3 p4) - - (** val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView **) - - let rec peanoView_xO p = function - | PeanoOne -> PeanoSucc (XH, PeanoOne) - | PeanoSucc (p2, q1) -> - PeanoSucc ((succ (XO p2)), (PeanoSucc ((XO p2), (peanoView_xO p2 q1)))) - - (** val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView **) - - let rec peanoView_xI p = function - | PeanoOne -> PeanoSucc ((succ XH), (PeanoSucc (XH, PeanoOne))) - | PeanoSucc (p2, q1) -> - PeanoSucc ((succ (XI p2)), (PeanoSucc ((XI p2), (peanoView_xI p2 q1)))) - - (** val peanoView : positive -> coq_PeanoView **) - - let rec peanoView = function - | XI p2 -> peanoView_xI p2 (peanoView p2) - | XO p2 -> peanoView_xO p2 (peanoView p2) - | XH -> PeanoOne - - (** val coq_PeanoView_iter : - 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 **) - - let rec coq_PeanoView_iter a f p = function - | PeanoOne -> a - | PeanoSucc (p2, q1) -> f p2 (coq_PeanoView_iter a f p2 q1) - - (** val switch_Eq : comparison -> comparison -> comparison **) - - let switch_Eq c = function - | Eq -> c - | x -> x - - (** val mask2cmp : mask -> comparison **) - - let mask2cmp = function - | IsNul -> Eq - | IsPos p2 -> Gt - | IsNeg -> Lt - - module T = - struct - - end - - module ORev = - struct - type t = Coq__1.t - end - - module MRev = - struct - (** val max : t -> t -> t **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : t -> t -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : t -> t -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : t -> t -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : t -> t -> bool **) - - let min_dec = - P.min_dec end -module N = - struct - type t = n - - (** val zero : n **) - - let zero = - N0 - - (** val one : n **) - - let one = - Npos XH - - (** val two : n **) - - let two = - Npos (XO XH) - - (** val succ_double : n -> n **) - - let succ_double = function - | N0 -> Npos XH - | Npos p -> Npos (XI p) - - (** val double : n -> n **) - - let double = function - | N0 -> N0 - | Npos p -> Npos (XO p) - - (** val succ : n -> n **) - - let succ = function - | N0 -> Npos XH - | Npos p -> Npos (Coq_Pos.succ p) - - (** val pred : n -> n **) - - let pred = function - | N0 -> N0 - | Npos p -> Coq_Pos.pred_N p - - (** val succ_pos : n -> positive **) - - let succ_pos = function - | N0 -> XH - | Npos p -> Coq_Pos.succ p - - (** val add : n -> n -> n **) - - let add n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Npos (Coq_Pos.add p q0)) - - (** val sub : n -> n -> n **) - - let sub n0 m = - match n0 with - | N0 -> N0 - | Npos n' -> - (match m with - | N0 -> n0 - | Npos m' -> - (match Coq_Pos.sub_mask n' m' with - | Coq_Pos.IsPos p -> Npos p - | _ -> N0)) - - (** val mul : n -> n -> n **) - - let mul n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> N0 - | Npos q0 -> Npos (Coq_Pos.mul p q0)) - - (** val compare : n -> n -> comparison **) - - let compare n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> Eq - | Npos m' -> Lt) - | Npos n' -> - (match m with - | N0 -> Gt - | Npos m' -> Coq_Pos.compare n' m') - - (** val eqb : n -> n -> bool **) - - let eqb n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> true - | Npos p -> false) - | Npos p -> - (match m with - | N0 -> false - | Npos q0 -> Coq_Pos.eqb p q0) - - (** val leb : n -> n -> bool **) - - let leb x y = - match compare x y with - | Gt -> false - | _ -> true - - (** val ltb : n -> n -> bool **) - - let ltb x y = - match compare x y with - | Lt -> true - | _ -> false - - (** val min : n -> n -> n **) - - let min n0 n' = - match compare n0 n' with - | Gt -> n' - | _ -> n0 - - (** val max : n -> n -> n **) - - let max n0 n' = - match compare n0 n' with - | Gt -> n0 - | _ -> n' - - (** val div2 : n -> n **) - - let div2 = function - | N0 -> N0 - | Npos p2 -> - (match p2 with - | XI p -> Npos p - | XO p -> Npos p - | XH -> N0) - - (** val even : n -> bool **) - - let even = function - | N0 -> true - | Npos p -> - (match p with - | XO p2 -> true - | _ -> false) - - (** val odd : n -> bool **) - - let odd n0 = - negb (even n0) - - (** val pow : n -> n -> n **) - - let pow n0 = function - | N0 -> Npos XH - | Npos p2 -> - (match n0 with - | N0 -> N0 - | Npos q0 -> Npos (Coq_Pos.pow q0 p2)) - - (** val log2 : n -> n **) - - let log2 = function - | N0 -> N0 - | Npos p2 -> - (match p2 with - | XI p -> Npos (Coq_Pos.size p) - | XO p -> Npos (Coq_Pos.size p) - | XH -> N0) - - (** val size : n -> n **) - - let size = function - | N0 -> N0 - | Npos p -> Npos (Coq_Pos.size p) - - (** val size_nat : n -> nat **) - - let size_nat = function - | N0 -> O - | Npos p -> Coq_Pos.size_nat p - - (** val pos_div_eucl : positive -> n -> n * n **) - - let rec pos_div_eucl a b = - match a with - | XI a' -> - let q0,r = pos_div_eucl a' b in - let r' = succ_double r in - if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' - | XO a' -> - let q0,r = pos_div_eucl a' b in - let r' = double r in - if leb b r' then (succ_double q0),(sub r' b) else (double q0),r' - | XH -> - (match b with - | N0 -> N0,(Npos XH) - | Npos p -> - (match p with - | XH -> (Npos XH),N0 - | _ -> N0,(Npos XH))) - - (** val div_eucl : n -> n -> n * n **) - - let div_eucl a b = - match a with - | N0 -> N0,N0 - | Npos na -> - (match b with - | N0 -> N0,a - | Npos p -> pos_div_eucl na b) - - (** val div : n -> n -> n **) - - let div a b = - fst (div_eucl a b) - - (** val modulo : n -> n -> n **) - - let modulo a b = - snd (div_eucl a b) - - (** val gcd : n -> n -> n **) - - let gcd a b = - match a with - | N0 -> b - | Npos p -> - (match b with - | N0 -> a - | Npos q0 -> Npos (Coq_Pos.gcd p q0)) - - (** val ggcd : n -> n -> n * (n * n) **) - - let ggcd a b = - match a with - | N0 -> b,(N0,(Npos XH)) - | Npos p -> - (match b with - | N0 -> a,((Npos XH),N0) - | Npos q0 -> - let g,p2 = Coq_Pos.ggcd p q0 in - let aa,bb = p2 in (Npos g),((Npos aa),(Npos bb))) - - (** val sqrtrem : n -> n * n **) - - let sqrtrem = function - | N0 -> N0,N0 - | Npos p -> - let s,m = Coq_Pos.sqrtrem p in - (match m with - | Coq_Pos.IsPos r -> (Npos s),(Npos r) - | _ -> (Npos s),N0) - - (** val sqrt : n -> n **) - - let sqrt = function - | N0 -> N0 - | Npos p -> Npos (Coq_Pos.sqrt p) - - (** val coq_lor : n -> n -> n **) - - let coq_lor n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Npos (Coq_Pos.coq_lor p q0)) - - (** val coq_land : n -> n -> n **) - - let coq_land n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> N0 - | Npos q0 -> Coq_Pos.coq_land p q0) - - (** val ldiff : n -> n -> n **) - - let ldiff n0 m = - match n0 with - | N0 -> N0 - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Coq_Pos.ldiff p q0) - - (** val coq_lxor : n -> n -> n **) - - let coq_lxor n0 m = - match n0 with - | N0 -> m - | Npos p -> - (match m with - | N0 -> n0 - | Npos q0 -> Coq_Pos.coq_lxor p q0) - - (** val shiftl_nat : n -> nat -> n **) - - let shiftl_nat a n0 = - nat_iter n0 double a - - (** val shiftr_nat : n -> nat -> n **) - - let shiftr_nat a n0 = - nat_iter n0 div2 a - - (** val shiftl : n -> n -> n **) - - let shiftl a n0 = - match a with - | N0 -> N0 - | Npos a0 -> Npos (Coq_Pos.shiftl a0 n0) - - (** val shiftr : n -> n -> n **) - - let shiftr a = function - | N0 -> a - | Npos p -> Coq_Pos.iter p div2 a - - (** val testbit_nat : n -> nat -> bool **) - - let testbit_nat = function - | N0 -> (fun x -> false) - | Npos p -> Coq_Pos.testbit_nat p - - (** val testbit : n -> n -> bool **) - - let testbit a n0 = - match a with - | N0 -> false - | Npos p -> Coq_Pos.testbit p n0 - - (** val to_nat : n -> nat **) - - let to_nat = function - | N0 -> O - | Npos p -> Coq_Pos.to_nat p - +module N = + struct (** val of_nat : nat -> n **) - + let of_nat = function | O -> N0 | S n' -> Npos (Coq_Pos.of_succ_nat n') - - (** val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let iter n0 f x = - match n0 with - | N0 -> x - | Npos p -> Coq_Pos.iter p f x - - (** val eq_dec : n -> n -> bool **) - - let eq_dec n0 m = - match n0 with - | N0 -> - (match m with - | N0 -> true - | Npos p -> false) - | Npos x -> - (match m with - | N0 -> false - | Npos p2 -> Coq_Pos.eq_dec x p2) - - (** val discr : n -> positive option **) - - let discr = function - | N0 -> None - | Npos p -> Some p - - (** val binary_rect : - 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let binary_rect f0 f2 fS2 n0 = - let f2' = fun p -> f2 (Npos p) in - let fS2' = fun p -> fS2 (Npos p) in - (match n0 with - | N0 -> f0 - | Npos p -> - let rec f = function - | XI p3 -> fS2' p3 (f p3) - | XO p3 -> f2' p3 (f p3) - | XH -> fS2 N0 f0 - in f p) - - (** val binary_rec : - 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let binary_rec = - binary_rect - - (** val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let peano_rect f0 f n0 = - let f' = fun p -> f (Npos p) in - (match n0 with - | N0 -> f0 - | Npos p -> Coq_Pos.peano_rect (f N0 f0) f' p) - - (** val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let peano_rec = - peano_rect - - module BootStrap = - struct - - end - - (** val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 **) - - let recursion x = - peano_rect x - - module OrderElts = - struct - type t = n - end - - module OrderTac = MakeOrderTac(OrderElts) - - module NZPowP = - struct - - end - - module NZSqrtP = - struct - - end - - (** val sqrt_up : n -> n **) - - let sqrt_up a = - match compare N0 a with - | Lt -> succ (sqrt (pred a)) - | _ -> N0 - - (** val log2_up : n -> n **) - - let log2_up a = - match compare (Npos XH) a with - | Lt -> succ (log2 (pred a)) - | _ -> N0 - - module NZDivP = - struct - - end - - (** val lcm : n -> n -> n **) - - let lcm a b = - mul a (div b (gcd a b)) - - (** val b2n : bool -> n **) - - let b2n = function - | true -> Npos XH - | false -> N0 - - (** val setbit : n -> n -> n **) - - let setbit a n0 = - coq_lor a (shiftl (Npos XH) n0) - - (** val clearbit : n -> n -> n **) - - let clearbit a n0 = - ldiff a (shiftl (Npos XH) n0) - - (** val ones : n -> n **) - - let ones n0 = - pred (shiftl (Npos XH) n0) - - (** val lnot : n -> n -> n **) - - let lnot a n0 = - coq_lxor a (ones n0) - - module T = - struct - - end - - module ORev = - struct - type t = n - end - - module MRev = - struct - (** val max : n -> n -> n **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : n -> n -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : n -> n -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : n -> n -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : n -> n -> bool **) - - let min_dec = - P.min_dec end (** val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 **) @@ -2006,66 +280,49 @@ let rec nth n0 l default = | O -> (match l with | [] -> default - | x::l' -> x) + | x::_ -> x) | S m -> (match l with | [] -> default - | x::t1 -> nth m t1 default) + | _::t0 -> nth m t0 default) (** val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list **) let rec map f = function | [] -> [] -| a::t1 -> (f a)::(map f t1) +| a::t0 -> (f a)::(map f t0) (** val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 **) let rec fold_right f a0 = function | [] -> a0 -| b::t1 -> f b (fold_right f a0 t1) - -module Z = - struct - type t = z - - (** val zero : z **) - - let zero = - Z0 - - (** val one : z **) - - let one = - Zpos XH - - (** val two : z **) - - let two = - Zpos (XO XH) - +| b::t0 -> f b (fold_right f a0 t0) + +module Z = + struct (** val double : z -> z **) - + let double = function | Z0 -> Z0 | Zpos p -> Zpos (XO p) | Zneg p -> Zneg (XO p) - + (** val succ_double : z -> z **) - + let succ_double = function | Z0 -> Zpos XH | Zpos p -> Zpos (XI p) | Zneg p -> Zneg (Coq_Pos.pred_double p) - + (** val pred_double : z -> z **) - + let pred_double = function | Z0 -> Zneg XH | Zpos p -> Zpos (Coq_Pos.pred_double p) | Zneg p -> Zneg (XI p) - + (** val pos_sub : positive -> positive -> z **) - + let rec pos_sub x y = match x with | XI p -> @@ -2083,9 +340,9 @@ module Z = | XI q0 -> Zneg (XO q0) | XO q0 -> Zneg (Coq_Pos.pred_double q0) | XH -> Z0) - + (** val add : z -> z -> z **) - + let add x y = match x with | Z0 -> y @@ -2099,31 +356,21 @@ module Z = | Z0 -> x | Zpos y' -> pos_sub y' x' | Zneg y' -> Zneg (Coq_Pos.add x' y')) - + (** val opp : z -> z **) - + let opp = function | Z0 -> Z0 | Zpos x0 -> Zneg x0 | Zneg x0 -> Zpos x0 - - (** val succ : z -> z **) - - let succ x = - add x (Zpos XH) - - (** val pred : z -> z **) - - let pred x = - add x (Zneg XH) - + (** val sub : z -> z -> z **) - + let sub m n0 = add m (opp n0) - + (** val mul : z -> z -> z **) - + let mul x y = match x with | Z0 -> Z0 @@ -2137,28 +384,16 @@ module Z = | Z0 -> Z0 | Zpos y' -> Zneg (Coq_Pos.mul x' y') | Zneg y' -> Zpos (Coq_Pos.mul x' y')) - - (** val pow_pos : z -> positive -> z **) - - let pow_pos z0 n0 = - Coq_Pos.iter n0 (mul z0) (Zpos XH) - - (** val pow : z -> z -> z **) - - let pow x = function - | Z0 -> Zpos XH - | Zpos p -> pow_pos x p - | Zneg p -> Z0 - + (** val compare : z -> z -> comparison **) - + let compare x y = match x with | Z0 -> (match y with | Z0 -> Eq - | Zpos y' -> Lt - | Zneg y' -> Gt) + | Zpos _ -> Lt + | Zneg _ -> Gt) | Zpos x' -> (match y with | Zpos y' -> Coq_Pos.compare x' y' @@ -2167,151 +402,74 @@ module Z = (match y with | Zneg y' -> compOpp (Coq_Pos.compare x' y') | _ -> Lt) - - (** val sgn : z -> z **) - - let sgn = function - | Z0 -> Z0 - | Zpos p -> Zpos XH - | Zneg p -> Zneg XH - + (** val leb : z -> z -> bool **) - + let leb x y = match compare x y with | Gt -> false | _ -> true - - (** val geb : z -> z -> bool **) - - let geb x y = - match compare x y with - | Lt -> false - | _ -> true - + (** val ltb : z -> z -> bool **) - + let ltb x y = match compare x y with | Lt -> true | _ -> false - + (** val gtb : z -> z -> bool **) - + let gtb x y = match compare x y with | Gt -> true | _ -> false - - (** val eqb : z -> z -> bool **) - - let eqb x y = - match x with - | Z0 -> - (match y with - | Z0 -> true - | _ -> false) - | Zpos p -> - (match y with - | Zpos q0 -> Coq_Pos.eqb p q0 - | _ -> false) - | Zneg p -> - (match y with - | Zneg q0 -> Coq_Pos.eqb p q0 - | _ -> false) - + (** val max : z -> z -> z **) - + let max n0 m = match compare n0 m with | Lt -> m | _ -> n0 - - (** val min : z -> z -> z **) - - let min n0 m = - match compare n0 m with - | Gt -> m - | _ -> n0 - + (** val abs : z -> z **) - + let abs = function | Zneg p -> Zpos p | x -> x - - (** val abs_nat : z -> nat **) - - let abs_nat = function - | Z0 -> O - | Zpos p -> Coq_Pos.to_nat p - | Zneg p -> Coq_Pos.to_nat p - - (** val abs_N : z -> n **) - - let abs_N = function - | Z0 -> N0 - | Zpos p -> Npos p - | Zneg p -> Npos p - - (** val to_nat : z -> nat **) - - let to_nat = function - | Zpos p -> Coq_Pos.to_nat p - | _ -> O - + (** val to_N : z -> n **) - + let to_N = function | Zpos p -> Npos p | _ -> N0 - - (** val of_nat : nat -> z **) - - let of_nat = function - | O -> Z0 - | S n1 -> Zpos (Coq_Pos.of_succ_nat n1) - - (** val of_N : n -> z **) - - let of_N = function - | N0 -> Z0 - | Npos p -> Zpos p - - (** val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 **) - - let iter n0 f x = - match n0 with - | Zpos p -> Coq_Pos.iter p f x - | _ -> x - + (** val pos_div_eucl : positive -> z -> z * z **) - + let rec pos_div_eucl a b = match a with | XI a' -> let q0,r = pos_div_eucl a' b in let r' = add (mul (Zpos (XO XH)) r) (Zpos XH) in - if gtb b r' + if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) | XO a' -> let q0,r = pos_div_eucl a' b in let r' = mul (Zpos (XO XH)) r in - if gtb b r' + if ltb r' b then (mul (Zpos (XO XH)) q0),r' else (add (mul (Zpos (XO XH)) q0) (Zpos XH)),(sub r' b) - | XH -> if geb b (Zpos (XO XH)) then Z0,(Zpos XH) else (Zpos XH),Z0 - + | XH -> if leb (Zpos (XO XH)) b then Z0,(Zpos XH) else (Zpos XH),Z0 + (** val div_eucl : z -> z -> z * z **) - + let div_eucl a b = match a with | Z0 -> Z0,Z0 | Zpos a' -> (match b with | Z0 -> Z0,Z0 - | Zpos p -> pos_div_eucl a' b + | Zpos _ -> pos_div_eucl a' b | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in (match r with @@ -2320,131 +478,20 @@ module Z = | Zneg a' -> (match b with | Z0 -> Z0,Z0 - | Zpos p -> + | Zpos _ -> let q0,r = pos_div_eucl a' b in (match r with | Z0 -> (opp q0),Z0 | _ -> (opp (add q0 (Zpos XH))),(sub b r)) | Zneg b' -> let q0,r = pos_div_eucl a' (Zpos b') in q0,(opp r)) - + (** val div : z -> z -> z **) - + let div a b = - let q0,x = div_eucl a b in q0 - - (** val modulo : z -> z -> z **) - - let modulo a b = - let x,r = div_eucl a b in r - - (** val quotrem : z -> z -> z * z **) - - let quotrem a b = - match a with - | Z0 -> Z0,Z0 - | Zpos a0 -> - (match b with - | Z0 -> Z0,a - | Zpos b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(of_N r) - | Zneg b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (opp (of_N q0)),(of_N r)) - | Zneg a0 -> - (match b with - | Z0 -> Z0,a - | Zpos b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in - (opp (of_N q0)),(opp (of_N r)) - | Zneg b0 -> - let q0,r = N.pos_div_eucl a0 (Npos b0) in (of_N q0),(opp (of_N r))) - - (** val quot : z -> z -> z **) - - let quot a b = - fst (quotrem a b) - - (** val rem : z -> z -> z **) - - let rem a b = - snd (quotrem a b) - - (** val even : z -> bool **) - - let even = function - | Z0 -> true - | Zpos p -> - (match p with - | XO p2 -> true - | _ -> false) - | Zneg p -> - (match p with - | XO p2 -> true - | _ -> false) - - (** val odd : z -> bool **) - - let odd = function - | Z0 -> false - | Zpos p -> - (match p with - | XO p2 -> false - | _ -> true) - | Zneg p -> - (match p with - | XO p2 -> false - | _ -> true) - - (** val div2 : z -> z **) - - let div2 = function - | Z0 -> Z0 - | Zpos p -> - (match p with - | XH -> Z0 - | _ -> Zpos (Coq_Pos.div2 p)) - | Zneg p -> Zneg (Coq_Pos.div2_up p) - - (** val quot2 : z -> z **) - - let quot2 = function - | Z0 -> Z0 - | Zpos p -> - (match p with - | XH -> Z0 - | _ -> Zpos (Coq_Pos.div2 p)) - | Zneg p -> - (match p with - | XH -> Z0 - | _ -> Zneg (Coq_Pos.div2 p)) - - (** val log2 : z -> z **) - - let log2 = function - | Zpos p2 -> - (match p2 with - | XI p -> Zpos (Coq_Pos.size p) - | XO p -> Zpos (Coq_Pos.size p) - | XH -> Z0) - | _ -> Z0 - - (** val sqrtrem : z -> z * z **) - - let sqrtrem = function - | Zpos p -> - let s,m = Coq_Pos.sqrtrem p in - (match m with - | Coq_Pos.IsPos r -> (Zpos s),(Zpos r) - | _ -> (Zpos s),Z0) - | _ -> Z0,Z0 - - (** val sqrt : z -> z **) - - let sqrt = function - | Zpos p -> Zpos (Coq_Pos.sqrt p) - | _ -> Z0 - + let q0,_ = div_eucl a b in q0 + (** val gcd : z -> z -> z **) - + let gcd a b = match a with | Z0 -> abs b @@ -2458,316 +505,6 @@ module Z = | Z0 -> abs a | Zpos b0 -> Zpos (Coq_Pos.gcd a0 b0) | Zneg b0 -> Zpos (Coq_Pos.gcd a0 b0)) - - (** val ggcd : z -> z -> z * (z * z) **) - - let ggcd a b = - match a with - | Z0 -> (abs b),(Z0,(sgn b)) - | Zpos a0 -> - (match b with - | Z0 -> (abs a),((sgn a),Z0) - | Zpos b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zpos aa),(Zpos bb)) - | Zneg b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zpos aa),(Zneg bb))) - | Zneg a0 -> - (match b with - | Z0 -> (abs a),((sgn a),Z0) - | Zpos b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zneg aa),(Zpos bb)) - | Zneg b0 -> - let g,p = Coq_Pos.ggcd a0 b0 in - let aa,bb = p in (Zpos g),((Zneg aa),(Zneg bb))) - - (** val testbit : z -> z -> bool **) - - let testbit a = function - | Z0 -> odd a - | Zpos p -> - (match a with - | Z0 -> false - | Zpos a0 -> Coq_Pos.testbit a0 (Npos p) - | Zneg a0 -> negb (N.testbit (Coq_Pos.pred_N a0) (Npos p))) - | Zneg p -> false - - (** val shiftl : z -> z -> z **) - - let shiftl a = function - | Z0 -> a - | Zpos p -> Coq_Pos.iter p (mul (Zpos (XO XH))) a - | Zneg p -> Coq_Pos.iter p div2 a - - (** val shiftr : z -> z -> z **) - - let shiftr a n0 = - shiftl a (opp n0) - - (** val coq_lor : z -> z -> z **) - - let coq_lor a b = - match a with - | Z0 -> b - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> Zpos (Coq_Pos.coq_lor a0 b0) - | Zneg b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N b0) (Npos a0)))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> Zneg (N.succ_pos (N.ldiff (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> - Zneg - (N.succ_pos (N.coq_land (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) - - (** val coq_land : z -> z -> z **) - - let coq_land a b = - match a with - | Z0 -> Z0 - | Zpos a0 -> - (match b with - | Z0 -> Z0 - | Zpos b0 -> of_N (Coq_Pos.coq_land a0 b0) - | Zneg b0 -> of_N (N.ldiff (Npos a0) (Coq_Pos.pred_N b0))) - | Zneg a0 -> - (match b with - | Z0 -> Z0 - | Zpos b0 -> of_N (N.ldiff (Npos b0) (Coq_Pos.pred_N a0)) - | Zneg b0 -> - Zneg - (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0)))) - - (** val ldiff : z -> z -> z **) - - let ldiff a b = - match a with - | Z0 -> Z0 - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> of_N (Coq_Pos.ldiff a0 b0) - | Zneg b0 -> of_N (N.coq_land (Npos a0) (Coq_Pos.pred_N b0))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> - Zneg (N.succ_pos (N.coq_lor (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> of_N (N.ldiff (Coq_Pos.pred_N b0) (Coq_Pos.pred_N a0))) - - (** val coq_lxor : z -> z -> z **) - - let coq_lxor a b = - match a with - | Z0 -> b - | Zpos a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> of_N (Coq_Pos.coq_lxor a0 b0) - | Zneg b0 -> - Zneg (N.succ_pos (N.coq_lxor (Npos a0) (Coq_Pos.pred_N b0)))) - | Zneg a0 -> - (match b with - | Z0 -> a - | Zpos b0 -> - Zneg (N.succ_pos (N.coq_lxor (Coq_Pos.pred_N a0) (Npos b0))) - | Zneg b0 -> of_N (N.coq_lxor (Coq_Pos.pred_N a0) (Coq_Pos.pred_N b0))) - - (** val eq_dec : z -> z -> bool **) - - let eq_dec x y = - match x with - | Z0 -> - (match y with - | Z0 -> true - | _ -> false) - | Zpos x0 -> - (match y with - | Zpos p2 -> Coq_Pos.eq_dec x0 p2 - | _ -> false) - | Zneg x0 -> - (match y with - | Zneg p2 -> Coq_Pos.eq_dec x0 p2 - | _ -> false) - - module BootStrap = - struct - - end - - module OrderElts = - struct - type t = z - end - - module OrderTac = MakeOrderTac(OrderElts) - - (** val sqrt_up : z -> z **) - - let sqrt_up a = - match compare Z0 a with - | Lt -> succ (sqrt (pred a)) - | _ -> Z0 - - (** val log2_up : z -> z **) - - let log2_up a = - match compare (Zpos XH) a with - | Lt -> succ (log2 (pred a)) - | _ -> Z0 - - module NZDivP = - struct - - end - - module Quot2Div = - struct - (** val div : z -> z -> z **) - - let div = - quot - - (** val modulo : z -> z -> z **) - - let modulo = - rem - end - - module NZQuot = - struct - - end - - (** val lcm : z -> z -> z **) - - let lcm a b = - abs (mul a (div b (gcd a b))) - - (** val b2z : bool -> z **) - - let b2z = function - | true -> Zpos XH - | false -> Z0 - - (** val setbit : z -> z -> z **) - - let setbit a n0 = - coq_lor a (shiftl (Zpos XH) n0) - - (** val clearbit : z -> z -> z **) - - let clearbit a n0 = - ldiff a (shiftl (Zpos XH) n0) - - (** val lnot : z -> z **) - - let lnot a = - pred (opp a) - - (** val ones : z -> z **) - - let ones n0 = - pred (shiftl (Zpos XH) n0) - - module T = - struct - - end - - module ORev = - struct - type t = z - end - - module MRev = - struct - (** val max : z -> z -> z **) - - let max x y = - min y x - end - - module MPRev = MaxLogicalProperties(ORev)(MRev) - - module P = - struct - (** val max_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let max_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat n0 (max n0 m) __ (hl __) - | _ -> compat m (max n0 m) __ (hr __)) - - (** val max_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 x1 = - max_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val max_dec : z -> z -> bool **) - - let max_dec n0 m = - max_case n0 m (fun x y _ h0 -> h0) true false - - (** val min_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) - -> 'a1 **) - - let min_case_strong n0 m compat hl hr = - let c = compSpec2Type n0 m (compare n0 m) in - (match c with - | CompGtT -> compat m (min n0 m) __ (hr __) - | _ -> compat n0 (min n0 m) __ (hl __)) - - (** val min_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 x1 = - min_case_strong n0 m x (fun _ -> x0) (fun _ -> x1) - - (** val min_dec : z -> z -> bool **) - - let min_dec n0 m = - min_case n0 m (fun x y _ h0 -> h0) true false - end - - (** val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let max_case_strong n0 m x x0 = - P.max_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) - - let max_case n0 m x x0 = - max_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val max_dec : z -> z -> bool **) - - let max_dec = - P.max_dec - - (** val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 **) - - let min_case_strong n0 m x x0 = - P.min_case_strong n0 m (fun x1 y _ x2 -> x2) x x0 - - (** val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 **) - - let min_case n0 m x x0 = - min_case_strong n0 m (fun _ -> x) (fun _ -> x0) - - (** val min_dec : z -> z -> bool **) - - let min_dec = - P.min_dec end (** val zeq_bool : z -> z -> bool **) @@ -2818,9 +555,9 @@ let rec peq ceqb p p' = (** val mkPinj : positive -> 'a1 pol -> 'a1 pol **) let mkPinj j p = match p with -| Pc c -> p +| Pc _ -> p | Pinj (j', q0) -> Pinj ((Coq_Pos.add j j'), q0) -| PX (p2, p3, p4) -> Pinj (j, p) +| PX (_, _, _) -> Pinj (j, p) (** val mkPinj_pred : positive -> 'a1 pol -> 'a1 pol **) @@ -2831,12 +568,13 @@ let mkPinj_pred j p = | XH -> p (** val mkPX : - 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 + pol **) let mkPX cO ceqb p i q0 = match p with | Pc c -> if ceqb c cO then mkPinj XH q0 else PX (p, i, q0) - | Pinj (p2, p3) -> PX (p, i, q0) + | Pinj (_, _) -> PX (p, i, q0) | PX (p', i', q') -> if peq ceqb q' (p0 cO) then PX (p', (Coq_Pos.add i' i), q0) @@ -2893,8 +631,8 @@ let rec paddI cadd pop q0 j = function | XH -> PX (p2, i, (pop q' q0))) (** 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 **) let rec psubI cadd copp pop q0 j = function | Pc c -> mkPinj j (paddC cadd (popp copp q0) c) @@ -2911,11 +649,11 @@ let rec psubI cadd copp pop q0 j = function | XH -> PX (p2, i, (pop q' q0))) (** val paddX : - 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol - -> positive -> 'a1 pol -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 + pol -> positive -> 'a1 pol -> 'a1 pol **) let rec paddX cO ceqb pop p' i' p = match p with -| Pc c -> PX (p', i', p) +| Pc _ -> PX (p', i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX (p', i', (Pinj ((XO j0), q'))) @@ -2928,15 +666,16 @@ let rec paddX cO ceqb pop p' i' p = match p with | Zneg k -> mkPX cO ceqb (paddX cO ceqb pop p' k p2) i q') (** 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 **) let rec psubX cO copp ceqb pop p' i' p = match p with -| Pc c -> PX ((popp copp p'), i', p) +| Pc _ -> PX ((popp copp p'), i', p) | Pinj (j, q') -> (match j with | XI j0 -> PX ((popp copp p'), i', (Pinj ((XO j0), q'))) - | XO j0 -> PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) + | XO j0 -> + PX ((popp copp p'), i', (Pinj ((Coq_Pos.pred_double j0), q'))) | XH -> PX ((popp copp p'), i', q')) | PX (p2, i, q') -> (match Z.pos_sub i i' with @@ -2945,8 +684,8 @@ let rec psubX cO copp ceqb pop p' i' p = match p with | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb pop p' k p2) i q') (** val padd : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol -> 'a1 pol **) let rec padd cO cadd ceqb p = function | Pc c' -> paddC cadd p c' @@ -2964,7 +703,8 @@ let rec padd cO cadd ceqb p = function | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> - mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i (padd cO cadd ceqb q0 q') + mkPX cO ceqb (padd cO cadd ceqb p2 p'0) i + (padd cO cadd ceqb q0 q') | Zpos k -> mkPX cO ceqb (padd cO cadd ceqb (PX (p2, k, (p0 cO))) p'0) i' (padd cO cadd ceqb q0 q') @@ -2973,8 +713,8 @@ let rec padd cO cadd ceqb p = function (padd cO cadd ceqb q0 q'))) (** 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 **) let rec psub cO cadd csub copp ceqb p = function | Pc c' -> psubC csub p c' @@ -2989,25 +729,27 @@ let rec psub cO cadd csub copp ceqb p = function (psub cO cadd csub copp ceqb (Pinj ((XO j0), q0)) q')) | XO j0 -> PX ((popp copp p'0), i', - (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) - q')) - | XH -> PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) + (psub cO cadd csub copp ceqb (Pinj ((Coq_Pos.pred_double j0), + q0)) q')) + | XH -> + PX ((popp copp p'0), i', (psub cO cadd csub copp ceqb q0 q'))) | PX (p2, i, q0) -> (match Z.pos_sub i i' with | Z0 -> mkPX cO ceqb (psub cO cadd csub copp ceqb p2 p'0) i (psub cO cadd csub copp ceqb q0 q') | Zpos k -> - mkPX cO ceqb (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) - i' (psub cO cadd csub copp ceqb q0 q') + mkPX cO ceqb + (psub cO cadd csub copp ceqb (PX (p2, k, (p0 cO))) p'0) i' + (psub cO cadd csub copp ceqb q0 q') | Zneg k -> mkPX cO ceqb (psubX cO copp ceqb (psub cO cadd csub copp ceqb) p'0 k p2) i (psub cO cadd csub copp ceqb q0 q'))) (** val pmulC_aux : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 -> - 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + -> 'a1 pol **) let rec pmulC_aux cO cmul ceqb p c = match p with @@ -3018,8 +760,8 @@ let rec pmulC_aux cO cmul ceqb p c = (pmulC_aux cO cmul ceqb q0 c) (** val pmulC : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> - 'a1 -> 'a1 pol **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol + -> 'a1 -> 'a1 pol **) let pmulC cO cI cmul ceqb p c = if ceqb c cO @@ -3027,8 +769,8 @@ let pmulC cO cI cmul ceqb p c = else if ceqb c cI then p else pmulC_aux cO cmul ceqb p c (** 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 **) let rec pmulI cO cI cmul ceqb pmul0 q0 j = function | Pc c -> mkPinj j (pmulC cO cI cmul ceqb q0 c) @@ -3049,12 +791,13 @@ let rec pmulI cO cI cmul ceqb pmul0 q0 j = function mkPX cO ceqb (pmulI cO cI cmul ceqb pmul0 q0 XH p') i' (pmul0 q' q0)) (** 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 **) let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with | Pc c -> pmulC cO cI cmul ceqb p c -| Pinj (j', q') -> pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p +| Pinj (j', q') -> + pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' j' p | PX (p', i', q') -> (match p with | Pc c -> pmulC cO cI cmul ceqb p'' c @@ -3063,22 +806,24 @@ let rec pmul cO cI cadd cmul ceqb p p'' = match p'' with match j with | XI j0 -> pmul cO cI cadd cmul ceqb (Pinj ((XO j0), q0)) q' | XO j0 -> - pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) q' + pmul cO cI cadd cmul ceqb (Pinj ((Coq_Pos.pred_double j0), q0)) + q' | XH -> pmul cO cI cadd cmul ceqb q0 q' in mkPX cO ceqb (pmul cO cI cadd cmul ceqb p p') i' qQ' | PX (p2, i, q0) -> let qQ' = pmul cO cI cadd cmul ceqb q0 q' in - let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 in + let pQ' = pmulI cO cI cmul ceqb (pmul cO cI cadd cmul ceqb) q' XH p2 + in let qP' = pmul cO cI cadd cmul ceqb (mkPinj XH q0) p' in let pP' = pmul cO cI cadd cmul ceqb p2 p' in padd cO cadd ceqb - (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') i' - (p0 cO)) (mkPX cO ceqb pQ' i qQ')) + (mkPX cO ceqb (padd cO cadd ceqb (mkPX cO ceqb pP' i (p0 cO)) qP') + i' (p0 cO)) (mkPX cO ceqb pQ' i qQ')) (** 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 **) let rec psquare cO cI cadd cmul ceqb = function | Pc c -> Pc (cmul c c) @@ -3107,9 +852,9 @@ let mk_X cO cI j = mkPinj_pred j (mkX cO cI) (** 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 **) let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function | XI p3 -> @@ -3123,16 +868,17 @@ let rec ppow_pos cO cI cadd cmul ceqb subst_l res p = function | XH -> subst_l (pmul cO cI cadd cmul ceqb res p) (** 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 **) let ppow_N cO cI cadd cmul ceqb subst_l p = function | N0 -> p1 cI | Npos p2 -> ppow_pos cO cI cadd cmul ceqb subst_l (p1 cI) p p2 (** 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 **) let rec norm_aux cO cI cadd cmul csub copp ceqb = function | PEc c -> Pc c @@ -3153,7 +899,8 @@ let rec norm_aux cO cI cadd cmul csub copp ceqb = function padd cO cadd ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2))) | PEsub (pe1, pe2) -> - psub cO cadd csub copp ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) + psub cO cadd csub copp ceqb + (norm_aux cO cI cadd cmul csub copp ceqb pe1) (norm_aux cO cI cadd cmul csub copp ceqb pe2) | PEmul (pe1, pe2) -> pmul cO cI cadd cmul ceqb (norm_aux cO cI cadd cmul csub copp ceqb pe1) @@ -3185,9 +932,9 @@ let rec map_bformula fct = function | N f0 -> N (map_bformula fct f0) | I (f1, f2) -> I ((map_bformula fct f1), (map_bformula fct f2)) -type 'term' clause = 'term' list +type 'x clause = 'x list -type 'term' cnf = 'term' clause list +type 'x cnf = 'x clause list (** val tt : 'a1 cnf **) @@ -3200,52 +947,52 @@ let ff = []::[] (** val add_term : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> 'a1 - clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 -> 'a1 clause -> + 'a1 clause option **) -let rec add_term unsat deduce t1 = function +let rec add_term unsat deduce t0 = function | [] -> - (match deduce t1 t1 with - | Some u -> if unsat u then None else Some (t1::[]) - | None -> Some (t1::[])) + (match deduce t0 t0 with + | Some u -> if unsat u then None else Some (t0::[]) + | None -> Some (t0::[])) | t'::cl0 -> - (match deduce t1 t' with + (match deduce t0 t' with | Some u -> if unsat u then None - else (match add_term unsat deduce t1 cl0 with + else (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None) | None -> - (match add_term unsat deduce t1 cl0 with + (match add_term unsat deduce t0 cl0 with | Some cl' -> Some (t'::cl') | None -> None)) (** val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause - -> 'a1 clause option **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 + clause -> 'a1 clause option **) let rec or_clause unsat deduce cl1 cl2 = match cl1 with | [] -> Some cl2 - | t1::cl -> - (match add_term unsat deduce t1 cl2 with + | t0::cl -> + (match add_term unsat deduce t0 cl2 with | Some cl' -> or_clause unsat deduce cl cl' | None -> None) (** val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> - 'a1 cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf + -> 'a1 cnf **) -let or_clause_cnf unsat deduce t1 f = +let or_clause_cnf unsat deduce t0 f = fold_right (fun e acc -> - match or_clause unsat deduce t1 e with + match or_clause unsat deduce t0 e with | Some cl -> cl::acc | None -> acc) [] f (** val or_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 - cnf **) + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> + 'a1 cnf **) let rec or_cnf unsat deduce f f' = match f with @@ -3259,8 +1006,8 @@ let and_cnf f1 f2 = app f1 f2 (** val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> + ('a1 -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf **) let rec xcnf unsat deduce normalise0 negate0 pol0 = function | TT -> if pol0 then tt else ff @@ -3300,9 +1047,9 @@ let rec cnf_checker checker f l = | c::l0 -> if checker e c then cnf_checker checker f0 l0 else false) (** val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 - -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> - bool **) + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> + ('a1 -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 + list -> bool **) let tauto_checker unsat deduce normalise0 negate0 checker f w = cnf_checker checker (xcnf unsat deduce normalise0 negate0 true f) w @@ -3335,18 +1082,18 @@ let opMult o o' = | Equal -> Some Equal | NonEqual -> (match o' with - | Strict -> None - | NonStrict -> None - | x -> Some x) + | Equal -> Some Equal + | NonEqual -> Some NonEqual + | _ -> None) | Strict -> (match o' with | NonEqual -> None | _ -> Some o') | NonStrict -> (match o' with + | Equal -> Some Equal | NonEqual -> None - | Strict -> Some NonStrict - | x -> Some x) + | _ -> Some NonStrict) (** val opAdd : op1 -> op1 -> op1 option **) @@ -3394,8 +1141,8 @@ let map_option2 f o o' = | None -> None (** 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 **) let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | ef,o -> @@ -3404,8 +1151,8 @@ let pexpr_times_nformula cO cI cplus ctimes ceqb e = function | _ -> None) (** 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 **) let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = let e1,o1 = f1 in @@ -3414,8 +1161,8 @@ let nformula_times_nformula cO cI cplus ctimes ceqb f1 f2 = (opMult o1 o2) (** 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 **) let nformula_plus_nformula cO cplus ceqb f1 f2 = let e1,o1 = f1 in @@ -3423,9 +1170,9 @@ let nformula_plus_nformula cO cplus ceqb f1 f2 = map_option (fun x -> Some ((padd cO cplus ceqb e1 e2),x)) (opAdd o1 o2) (** val eval_Psatz : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> 'a1 - nFormula option **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz + -> 'a1 nFormula option **) let rec eval_Psatz cO cI cplus ctimes ceqb cleb l = function | PsatzIn n0 -> Some (nth n0 l ((Pc cO),Equal)) @@ -3460,9 +1207,9 @@ let check_inconsistent cO ceqb cleb = function | _ -> false) (** val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> - bool **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz + -> bool **) let check_normalised_formulas cO cI cplus ctimes ceqb cleb l cm = match eval_Psatz cO cI cplus ctimes ceqb cleb l cm with @@ -3479,51 +1226,41 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } -(** val flhs : 'a1 formula -> 'a1 pExpr **) - -let flhs x = x.flhs - -(** val fop : 'a1 formula -> op2 **) - -let fop x = x.fop - -(** val frhs : 'a1 formula -> 'a1 pExpr **) - -let frhs x = x.frhs - (** 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 **) let norm cO cI cplus ctimes cminus copp ceqb = norm_aux cO cI cplus ctimes cminus copp ceqb (** 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 **) let psub0 cO cplus cminus copp ceqb = psub cO cplus cminus copp ceqb (** val padd0 : - 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol - -> 'a1 pol **) + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 + pol -> 'a1 pol **) let padd0 cO cplus ceqb = padd cO cplus ceqb (** val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula list **) -let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnormalise cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO + cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) @@ -3534,26 +1271,27 @@ let xnormalise cO cI cplus ctimes cminus copp ceqb t1 = | OpGt -> ((psub0 cO cplus cminus copp ceqb rhs0 lhs0),NonStrict)::[]) (** val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula cnf **) -let cnf_normalise cO cI cplus ctimes cminus copp ceqb t1 = - map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t1) +let cnf_normalise cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x::[]) (xnormalise cO cI cplus ctimes cminus copp ceqb t0) (** val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula list **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula list **) -let xnegate cO cI cplus ctimes cminus copp ceqb t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnegate cO cI cplus ctimes cminus copp ceqb t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm cO cI cplus ctimes cminus copp ceqb lhs in let rhs0 = norm cO cI cplus ctimes cminus copp ceqb rhs in (match o with | OpEq -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Equal)::[] | OpNEq -> - ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO cplus + ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::(((psub0 cO + cplus cminus copp ceqb rhs0 lhs0),Strict)::[]) @@ -3563,12 +1301,12 @@ let xnegate cO cI cplus ctimes cminus copp ceqb t1 = | OpGt -> ((psub0 cO cplus cminus copp ceqb lhs0 rhs0),Strict)::[]) (** val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 - -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 - nFormula cnf **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> + 'a1 -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> + 'a1 nFormula cnf **) -let cnf_negate cO cI cplus ctimes cminus copp ceqb t1 = - map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t1) +let cnf_negate cO cI cplus ctimes cminus copp ceqb t0 = + map (fun x -> x::[]) (xnegate cO cI cplus ctimes cminus copp ceqb t0) (** val xdenorm : positive -> 'a1 pol -> 'a1 pExpr **) @@ -3602,14 +1340,14 @@ let map_Formula c_of_S f = { flhs = (map_PExpr c_of_S l); fop = o; frhs = (map_PExpr c_of_S r) } (** val simpl_cone : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz -> - 'a1 psatz **) + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz + -> 'a1 psatz **) let simpl_cone cO cI ctimes ceqb e = match e with -| PsatzSquare t1 -> - (match t1 with +| PsatzSquare t0 -> + (match t0 with | Pc c -> if ceqb cO c then PsatzZ else PsatzC (ctimes c c) - | _ -> PsatzSquare t1) + | _ -> PsatzSquare t0) | PsatzMulE (t1, t2) -> (match t1 with | PsatzMulE (x, x0) -> @@ -3641,7 +1379,8 @@ let simpl_cone cO cI ctimes ceqb e = match e with | PsatzC p2 -> PsatzMulE ((PsatzC (ctimes c p2)), x) | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2))) | PsatzAdd (y, z0) -> - PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), z0))) + PsatzAdd ((PsatzMulE ((PsatzC c), y)), (PsatzMulE ((PsatzC c), + z0))) | PsatzC c0 -> PsatzC (ctimes c c0) | PsatzZ -> PsatzZ | _ -> if ceqb cI c then t2 else PsatzMulE (t1, t2)) @@ -3683,7 +1422,8 @@ let qle_bool x y = (** val qplus : q -> q -> q **) let qplus x y = - { qnum = (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); + { qnum = + (Z.add (Z.mul x.qnum (Zpos y.qden)) (Z.mul y.qnum (Zpos x.qden))); qden = (Coq_Pos.mul x.qden y.qden) } (** val qmult : q -> q -> q **) @@ -3711,8 +1451,8 @@ let qinv x = (** val qpower_positive : q -> positive -> q **) -let qpower_positive q0 p = - pow_pos qmult q0 p +let qpower_positive = + pow_pos qmult (** val qpower : q -> z -> q **) @@ -3721,12 +1461,12 @@ let qpower q0 = function | Zpos p -> qpower_positive q0 p | Zneg p -> qinv (qpower_positive q0 p) -type 'a t0 = +type 'a t = | Empty | Leaf of 'a -| Node of 'a t0 * 'a * 'a t0 +| Node of 'a t * 'a * 'a t -(** val find : 'a1 -> 'a1 t0 -> positive -> 'a1 **) +(** val find : 'a1 -> 'a1 t -> positive -> 'a1 **) let rec find default vm p = match vm with @@ -3738,6 +1478,29 @@ let rec find default vm p = | XO p2 -> find default l p2 | XH -> e) +(** val singleton : 'a1 -> positive -> 'a1 -> 'a1 t **) + +let rec singleton default x v = + match x with + | XI p -> Node (Empty, default, (singleton default p v)) + | XO p -> Node ((singleton default p v), default, Empty) + | XH -> Leaf v + +(** val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t **) + +let rec vm_add default x v = function +| Empty -> singleton default x v +| Leaf vl -> + (match x with + | XI p -> Node (Empty, vl, (singleton default p v)) + | XO p -> Node ((singleton default p v), vl, Empty) + | XH -> Leaf v) +| Node (l, o, r) -> + (match x with + | XI p -> Node (l, o, (vm_add default p v r)) + | XO p -> Node ((vm_add default p v l), o, r) + | XH -> Node (l, v, r)) + type zWitness = z psatz (** val zWeakChecker : z nFormula list -> z psatz -> bool **) @@ -3762,8 +1525,8 @@ let norm0 = (** val xnormalise0 : z formula -> z nFormula list **) -let xnormalise0 t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnormalise0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with @@ -3780,13 +1543,13 @@ let xnormalise0 t1 = (** val normalise : z formula -> z nFormula cnf **) -let normalise t1 = - map (fun x -> x::[]) (xnormalise0 t1) +let normalise t0 = + map (fun x -> x::[]) (xnormalise0 t0) (** val xnegate0 : z formula -> z nFormula list **) -let xnegate0 t1 = - let { flhs = lhs; fop = o; frhs = rhs } = t1 in +let xnegate0 t0 = + let { flhs = lhs; fop = o; frhs = rhs } = t0 in let lhs0 = norm0 lhs in let rhs0 = norm0 rhs in (match o with @@ -3803,8 +1566,8 @@ let xnegate0 t1 = (** val negate : z formula -> z nFormula cnf **) -let negate t1 = - map (fun x -> x::[]) (xnegate0 t1) +let negate t0 = + map (fun x -> x::[]) (xnegate0 t0) (** val zunsat : z nFormula -> bool **) @@ -3839,8 +1602,8 @@ let zgcdM x y = let rec zgcd_pol = function | Pc c -> Z0,c -| Pinj (p2, p3) -> zgcd_pol p3 -| PX (p2, p3, q0) -> +| Pinj (_, p2) -> zgcd_pol p2 +| PX (p2, _, q0) -> let g1,c1 = zgcd_pol p2 in let g2,c2 = zgcd_pol q0 in (zgcdM (zgcdM g1 c1) g2),c2 @@ -3872,7 +1635,8 @@ let genCuttingPlane = function then None else Some ((makeCuttingPlane e),Equal) | NonEqual -> Some ((e,Z0),op) - | Strict -> Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) + | Strict -> + Some ((makeCuttingPlane (psubC Z.sub e (Zpos XH))),NonStrict) | NonStrict -> Some ((makeCuttingPlane e),NonStrict)) (** val nformula_of_cutting_plane : ((z polC * z) * op1) -> z nFormula **) @@ -3966,8 +1730,8 @@ let qnormalise = (** val qnegate : q formula -> q nFormula cnf **) let qnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool (** val qunsat : q nFormula -> bool **) @@ -4025,8 +1789,8 @@ let rnormalise = (** val rnegate : q formula -> q nFormula cnf **) let rnegate = - cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } qplus - qmult qminus qopp qeq_bool + cnf_negate { qnum = Z0; qden = XH } { qnum = (Zpos XH); qden = XH } + qplus qmult qminus qopp qeq_bool (** val runsat : q nFormula -> bool **) @@ -4043,4 +1807,3 @@ let rdeduce = let rTautoChecker f w = tauto_checker runsat rdeduce rnormalise rnegate rWeakChecker (map_bformula (map_Formula q_of_Rcst) f) w - diff --git a/plugins/micromega/micromega.mli b/plugins/micromega/micromega.mli index bcd61f39b3..beb042f49d 100644 --- a/plugins/micromega/micromega.mli +++ b/plugins/micromega/micromega.mli @@ -1,15 +1,9 @@ -type __ = Obj.t - val negb : bool -> bool type nat = | O | S of nat -val fst : ('a1 * 'a2) -> 'a1 - -val snd : ('a1 * 'a2) -> 'a2 - val app : 'a1 list -> 'a1 list -> 'a1 list type comparison = @@ -19,24 +13,7 @@ type comparison = val compOpp : comparison -> comparison -type compareSpecT = -| CompEqT -| CompLtT -| CompGtT - -val compareSpec2Type : comparison -> compareSpecT - -type 'a compSpecT = compareSpecT - -val compSpec2Type : 'a1 -> 'a1 -> comparison -> 'a1 compSpecT - -type 'a sig0 = - 'a - (* singleton inductive, whose constructor was exist *) - -val plus : nat -> nat -> nat - -val nat_iter : nat -> ('a1 -> 'a1) -> 'a1 -> 'a1 +val add : nat -> nat -> nat type positive = | XI of positive @@ -52,560 +29,59 @@ type z = | Zpos of positive | Zneg of positive -module type TotalOrder' = - sig - type t - end - -module MakeOrderTac : - functor (O:TotalOrder') -> - sig - - end - -module MaxLogicalProperties : - functor (O:TotalOrder') -> - functor (M:sig - val max : O.t -> O.t -> O.t - end) -> - sig - module T : - sig - - end - end - -module Pos : - sig - type t = positive - - val succ : positive -> positive - - val add : positive -> positive -> positive - - val add_carry : positive -> positive -> positive - - val pred_double : positive -> positive - - val pred : positive -> positive - - val pred_N : positive -> n - +module Pos : + sig type mask = | IsNul | IsPos of positive | IsNeg - - val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val succ_double_mask : mask -> mask - - val double_mask : mask -> mask - - val double_pred_mask : positive -> mask - - val pred_mask : mask -> 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 : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val pow : positive -> positive -> positive - - val div2 : positive -> positive - - val div2_up : positive -> positive - - val size_nat : positive -> nat - - val size : positive -> positive - - val compare_cont : positive -> positive -> comparison -> comparison - - val compare : positive -> positive -> comparison - - val min : positive -> positive -> positive - - val max : positive -> positive -> positive - - val eqb : positive -> positive -> bool - - val leb : positive -> positive -> bool - - val ltb : positive -> positive -> bool - - val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) -> - positive * mask - - val sqrtrem : positive -> positive * mask - - val sqrt : positive -> positive - - val gcdn : nat -> positive -> positive -> positive - - val gcd : positive -> positive -> positive - - val ggcdn : nat -> positive -> positive -> positive * (positive * positive) - - val ggcd : positive -> positive -> positive * (positive * positive) - - val coq_Nsucc_double : n -> n - - val coq_Ndouble : n -> n - - val coq_lor : positive -> positive -> positive - - val coq_land : positive -> positive -> n - - val ldiff : positive -> positive -> n - - val coq_lxor : positive -> positive -> n - - val shiftl_nat : positive -> nat -> positive - - val shiftr_nat : positive -> nat -> positive - - val shiftl : positive -> n -> positive - - val shiftr : positive -> n -> positive - - val testbit_nat : positive -> nat -> bool - - val testbit : positive -> n -> bool - - val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 - - val to_nat : positive -> nat - - val of_nat : nat -> positive - - val of_succ_nat : nat -> positive end -module Coq_Pos : - sig - module Coq__1 : sig - type t = positive - end - type t = Coq__1.t - +module Coq_Pos : + sig val succ : positive -> positive - + val add : positive -> positive -> positive - + val add_carry : positive -> positive -> positive - + val pred_double : positive -> positive - - val pred : positive -> positive - - val pred_N : positive -> n - + type mask = Pos.mask = | IsNul | IsPos of positive | IsNeg - - val mask_rect : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - - val mask_rec : 'a1 -> (positive -> 'a1) -> 'a1 -> mask -> 'a1 - + val succ_double_mask : mask -> mask - + val double_mask : mask -> mask - + val double_pred_mask : positive -> mask - - val pred_mask : mask -> 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 : positive -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val pow : positive -> positive -> positive - - val div2 : positive -> positive - - val div2_up : positive -> positive - + val size_nat : positive -> nat - - val size : positive -> positive - - val compare_cont : positive -> positive -> comparison -> comparison - + + val compare_cont : comparison -> positive -> positive -> comparison + val compare : positive -> positive -> comparison - - val min : positive -> positive -> positive - - val max : positive -> positive -> positive - - val eqb : positive -> positive -> bool - - val leb : positive -> positive -> bool - - val ltb : positive -> positive -> bool - - val sqrtrem_step : - (positive -> positive) -> (positive -> positive) -> (positive * mask) -> - positive * mask - - val sqrtrem : positive -> positive * mask - - val sqrt : positive -> positive - + val gcdn : nat -> positive -> positive -> positive - + val gcd : positive -> positive -> positive - - val ggcdn : nat -> positive -> positive -> positive * (positive * positive) - - val ggcd : positive -> positive -> positive * (positive * positive) - - val coq_Nsucc_double : n -> n - - val coq_Ndouble : n -> n - - val coq_lor : positive -> positive -> positive - - val coq_land : positive -> positive -> n - - val ldiff : positive -> positive -> n - - val coq_lxor : positive -> positive -> n - - val shiftl_nat : positive -> nat -> positive - - val shiftr_nat : positive -> nat -> positive - - val shiftl : positive -> n -> positive - - val shiftr : positive -> n -> positive - - val testbit_nat : positive -> nat -> bool - - val testbit : positive -> n -> bool - - val iter_op : ('a1 -> 'a1 -> 'a1) -> positive -> 'a1 -> 'a1 - - val to_nat : positive -> nat - - val of_nat : nat -> positive - + val of_succ_nat : nat -> positive - - val eq_dec : positive -> positive -> bool - - val peano_rect : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 - - val peano_rec : 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> 'a1 - - type coq_PeanoView = - | PeanoOne - | PeanoSucc of positive * coq_PeanoView - - val coq_PeanoView_rect : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 - - val coq_PeanoView_rec : - 'a1 -> (positive -> coq_PeanoView -> 'a1 -> 'a1) -> positive -> - coq_PeanoView -> 'a1 - - val peanoView_xO : positive -> coq_PeanoView -> coq_PeanoView - - val peanoView_xI : positive -> coq_PeanoView -> coq_PeanoView - - val peanoView : positive -> coq_PeanoView - - val coq_PeanoView_iter : - 'a1 -> (positive -> 'a1 -> 'a1) -> positive -> coq_PeanoView -> 'a1 - - val switch_Eq : comparison -> comparison -> comparison - - val mask2cmp : mask -> comparison - - module T : - sig - - end - - module ORev : - sig - type t = Coq__1.t - end - - module MRev : - sig - val max : t -> t -> t - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : t -> t -> bool - - val min_case_strong : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - t -> t -> (t -> t -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : t -> t -> bool - end - - val max_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : t -> t -> 'a1 -> 'a1 -> 'a1 - - val max_dec : t -> t -> bool - - val min_case_strong : t -> t -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : t -> t -> 'a1 -> 'a1 -> 'a1 - - val min_dec : t -> t -> bool end -module N : - sig - type t = n - - val zero : n - - val one : n - - val two : n - - val succ_double : n -> n - - val double : n -> n - - val succ : n -> n - - val pred : n -> n - - val succ_pos : n -> positive - - val add : n -> n -> n - - val sub : n -> n -> n - - val mul : n -> n -> n - - val compare : n -> n -> comparison - - val eqb : n -> n -> bool - - val leb : n -> n -> bool - - val ltb : n -> n -> bool - - val min : n -> n -> n - - val max : n -> n -> n - - val div2 : n -> n - - val even : n -> bool - - val odd : n -> bool - - val pow : n -> n -> n - - val log2 : n -> n - - val size : n -> n - - val size_nat : n -> nat - - val pos_div_eucl : positive -> n -> n * n - - val div_eucl : n -> n -> n * n - - val div : n -> n -> n - - val modulo : n -> n -> n - - val gcd : n -> n -> n - - val ggcd : n -> n -> n * (n * n) - - val sqrtrem : n -> n * n - - val sqrt : n -> n - - val coq_lor : n -> n -> n - - val coq_land : n -> n -> n - - val ldiff : n -> n -> n - - val coq_lxor : n -> n -> n - - val shiftl_nat : n -> nat -> n - - val shiftr_nat : n -> nat -> n - - val shiftl : n -> n -> n - - val shiftr : n -> n -> n - - val testbit_nat : n -> nat -> bool - - val testbit : n -> n -> bool - - val to_nat : n -> nat - +module N : + sig val of_nat : nat -> n - - val iter : n -> ('a1 -> 'a1) -> 'a1 -> 'a1 - - val eq_dec : n -> n -> bool - - val discr : n -> positive option - - val binary_rect : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val binary_rec : 'a1 -> (n -> 'a1 -> 'a1) -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val peano_rect : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - val peano_rec : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - module BootStrap : - sig - - end - - val recursion : 'a1 -> (n -> 'a1 -> 'a1) -> n -> 'a1 - - module OrderElts : - sig - type t = n - end - - module OrderTac : - sig - - end - - module NZPowP : - sig - - end - - module NZSqrtP : - sig - - end - - val sqrt_up : n -> n - - val log2_up : n -> n - - module NZDivP : - sig - - end - - val lcm : n -> n -> n - - val b2n : bool -> n - - val setbit : n -> n -> n - - val clearbit : n -> n -> n - - val ones : n -> n - - val lnot : n -> n -> n - - module T : - sig - - end - - module ORev : - sig - type t = n - end - - module MRev : - sig - val max : n -> n -> n - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : n -> n -> bool - - val min_case_strong : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - n -> n -> (n -> n -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : n -> n -> bool - end - - val max_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : n -> n -> 'a1 -> 'a1 -> 'a1 - - val max_dec : n -> n -> bool - - val min_case_strong : n -> n -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : n -> n -> 'a1 -> 'a1 -> 'a1 - - val min_dec : n -> n -> bool end val pow_pos : ('a1 -> 'a1 -> 'a1) -> 'a1 -> positive -> 'a1 @@ -616,225 +92,45 @@ val map : ('a1 -> 'a2) -> 'a1 list -> 'a2 list val fold_right : ('a2 -> 'a1 -> 'a1) -> 'a1 -> 'a2 list -> 'a1 -module Z : - sig - type t = z - - val zero : z - - val one : z - - val two : z - +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 succ : z -> z - - val pred : 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 sgn : z -> z - + val leb : z -> z -> bool - - val geb : z -> z -> bool - + val ltb : z -> z -> bool - + val gtb : z -> z -> bool - - val eqb : z -> z -> bool - + val max : z -> z -> z - - val min : z -> z -> z - + val abs : z -> z - - val abs_nat : z -> nat - - val abs_N : z -> n - - val to_nat : z -> nat - + val to_N : z -> n - - val of_nat : nat -> z - - val of_N : n -> z - - val iter : z -> ('a1 -> 'a1) -> 'a1 -> 'a1 - + val pos_div_eucl : positive -> z -> z * z - + val div_eucl : z -> z -> z * z - + val div : z -> z -> z - - val modulo : z -> z -> z - - val quotrem : z -> z -> z * z - - val quot : z -> z -> z - - val rem : z -> z -> z - - val even : z -> bool - - val odd : z -> bool - - val div2 : z -> z - - val quot2 : z -> z - - val log2 : z -> z - - val sqrtrem : z -> z * z - - val sqrt : z -> z - + val gcd : z -> z -> z - - val ggcd : z -> z -> z * (z * z) - - val testbit : z -> z -> bool - - val shiftl : z -> z -> z - - val shiftr : z -> z -> z - - val coq_lor : z -> z -> z - - val coq_land : z -> z -> z - - val ldiff : z -> z -> z - - val coq_lxor : z -> z -> z - - val eq_dec : z -> z -> bool - - module BootStrap : - sig - - end - - module OrderElts : - sig - type t = z - end - - module OrderTac : - sig - - end - - val sqrt_up : z -> z - - val log2_up : z -> z - - module NZDivP : - sig - - end - - module Quot2Div : - sig - val div : z -> z -> z - - val modulo : z -> z -> z - end - - module NZQuot : - sig - - end - - val lcm : z -> z -> z - - val b2z : bool -> z - - val setbit : z -> z -> z - - val clearbit : z -> z -> z - - val lnot : z -> z - - val ones : z -> z - - module T : - sig - - end - - module ORev : - sig - type t = z - end - - module MRev : - sig - val max : z -> z -> z - end - - module MPRev : - sig - module T : - sig - - end - end - - module P : - sig - val max_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val max_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val max_dec : z -> z -> bool - - val min_case_strong : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> (__ -> 'a1) -> (__ -> 'a1) -> - 'a1 - - val min_case : - z -> z -> (z -> z -> __ -> 'a1 -> 'a1) -> 'a1 -> 'a1 -> 'a1 - - val min_dec : z -> z -> bool - end - - val max_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val max_case : z -> z -> 'a1 -> 'a1 -> 'a1 - - val max_dec : z -> z -> bool - - val min_case_strong : z -> z -> (__ -> 'a1) -> (__ -> 'a1) -> 'a1 - - val min_case : z -> z -> 'a1 -> 'a1 -> 'a1 - - val min_dec : z -> z -> bool end val zeq_bool : z -> z -> bool @@ -872,44 +168,44 @@ val paddI : 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 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 + '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 + '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 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> + 'a1 -> 'a1 pol val pmulI : 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> ('a1 pol -> 'a1 pol -> 'a1 pol) -> 'a1 pol -> positive -> 'a1 pol -> 'a1 pol val 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 type 'c pExpr = | PEc of 'c @@ -923,16 +219,17 @@ type 'c pExpr = val mk_X : 'a1 -> 'a1 -> positive -> 'a1 pol val ppow_pos : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> 'a1 pol -> positive -> + 'a1 pol val ppow_N : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 pol -> 'a1 pol) -> 'a1 pol -> n -> 'a1 pol val norm_aux : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pExpr -> 'a1 pol type 'a bFormula = | TT @@ -946,9 +243,9 @@ type 'a bFormula = val map_bformula : ('a1 -> 'a2) -> 'a1 bFormula -> 'a2 bFormula -type 'term' clause = 'term' list +type 'x clause = 'x list -type 'term' cnf = 'term' clause list +type 'x cnf = 'x clause list val tt : 'a1 cnf @@ -959,12 +256,12 @@ val add_term : clause option val or_clause : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause -> - 'a1 clause option + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 clause + -> 'a1 clause option val or_clause_cnf : - ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> 'a1 - cnf + ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 clause -> 'a1 cnf -> + 'a1 cnf val or_cnf : ('a1 -> bool) -> ('a1 -> 'a1 -> 'a1 option) -> 'a1 cnf -> 'a1 cnf -> 'a1 @@ -973,18 +270,20 @@ val or_cnf : val and_cnf : 'a1 cnf -> 'a1 cnf -> 'a1 cnf val xcnf : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> bool -> 'a1 bFormula -> 'a2 cnf val cnf_checker : ('a1 list -> 'a2 -> bool) -> 'a1 cnf -> 'a2 list -> bool val tauto_checker : - ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 -> - 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> bool + ('a2 -> bool) -> ('a2 -> 'a2 -> 'a2 option) -> ('a1 -> 'a2 cnf) -> ('a1 + -> 'a2 cnf) -> ('a2 list -> 'a3 -> bool) -> 'a1 bFormula -> 'a3 list -> + bool val cneqb : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool -val cltb : ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool +val cltb : + ('a1 -> 'a1 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 -> bool type 'c polC = 'c pol @@ -1015,28 +314,30 @@ 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 + '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 -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula -> + bool val check_normalised_formulas : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> bool + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> bool) -> ('a1 -> 'a1 -> bool) -> 'a1 nFormula list -> 'a1 psatz -> + bool type op2 = | OpEq @@ -1048,43 +349,37 @@ type op2 = type 't formula = { flhs : 't pExpr; fop : op2; frhs : 't pExpr } -val flhs : 'a1 formula -> 'a1 pExpr - -val fop : 'a1 formula -> op2 - -val frhs : 'a1 formula -> 'a1 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 + 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 pol -> 'a1 pol + -> 'a1 pol val xnormalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list val cnf_normalise : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf val xnegate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - list + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula list val cnf_negate : - 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> - 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 nFormula - cnf + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 + -> 'a1) -> ('a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 formula -> 'a1 + nFormula cnf val xdenorm : positive -> 'a1 pol -> 'a1 pExpr @@ -1095,8 +390,8 @@ 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 + 'a1 -> 'a1 -> ('a1 -> 'a1 -> 'a1) -> ('a1 -> 'a1 -> bool) -> 'a1 psatz + -> 'a1 psatz type q = { qnum : z; qden : positive } @@ -1122,12 +417,16 @@ val qpower_positive : q -> positive -> q val qpower : q -> z -> q -type 'a t0 = +type 'a t = | Empty | Leaf of 'a -| Node of 'a t0 * 'a * 'a t0 +| Node of 'a t * 'a * 'a t + +val find : 'a1 -> 'a1 t -> positive -> 'a1 -val find : 'a1 -> 'a1 t0 -> positive -> 'a1 +val singleton : 'a1 -> positive -> 'a1 -> 'a1 t + +val vm_add : 'a1 -> positive -> 'a1 -> 'a1 t -> 'a1 t type zWitness = z psatz @@ -1221,4 +520,3 @@ 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/mutils.ml b/plugins/micromega/mutils.ml index c13e8fc28f..b4c6d032bf 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -294,18 +294,6 @@ struct else XO (index (n lsr 1)) - let idx n = - (*a.k.a path_of_int *) - (* returns the list of digits of n in reverse order with initial 1 removed *) - let rec digits_of_int n = - if Int.equal n 1 then [] - else (Int.equal (n mod 2) 1)::(digits_of_int (n lsr 1)) - in - List.fold_right - (fun b c -> (if b then XI c else XO c)) - (List.rev (digits_of_int n)) - (XH) - let z x = match compare x 0 with | 0 -> Z0 diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 88b13abf9a..0e6d346a3b 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -92,7 +92,7 @@ let read_key_elem inch = Some (Marshal.from_channel inch) with | End_of_file -> None - | e when Errors.noncritical e -> raise InvalidTableFormat + | e when CErrors.noncritical e -> raise InvalidTableFormat (** We used to only lock/unlock regions. diff --git a/plugins/micromega/vo.itarget b/plugins/micromega/vo.itarget index bf6a1a7db2..c9009ea4de 100644 --- a/plugins/micromega/vo.itarget +++ b/plugins/micromega/vo.itarget @@ -10,4 +10,6 @@ Tauto.vo VarMap.vo ZCoeff.vo ZMicromega.vo -Lia.vo
\ No newline at end of file +Lia.vo +Lqa.vo +Lra.vo diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index 3068b53470..b11d15e5ca 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -298,7 +298,9 @@ Ltac nsatz_call_n info nparam p rr lp kont := match goal with | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ => intros _; + let lci := fresh "lci" in set (lci:=lci0); + let lq := fresh "lq" in set (lq:=lq0); kont c rr lq lci end. @@ -380,10 +382,13 @@ Ltac nsatz_generic radicalmax info lparam lvar := end in SplitPolyList ltac:(fun p lp => + let p21 := fresh "p21" in + let lp21 := fresh "lp21" in set (p21:=p) ; set (lp21:=lp); (* idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *) nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci => + let q := fresh "q" in set (q := PEmul c (PEpow p21 r)); let Hg := fresh "Hg" in assert (Hg:check lp21 q (lci,lq) = true); diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 482ce50538..7c2178222f 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -127,11 +127,11 @@ type polynom = num : int; sugar : int} -let nvar m = Array.length m - 1 +let nvar (m : mon) = Array.length m - 1 -let deg m = m.(0) +let deg (m : mon) = m.(0) -let mult_mon m m' = +let mult_mon (m : mon) (m' : mon) = let d = nvar m in let m'' = Array.make (d+1) 0 in for i=0 to d do @@ -140,7 +140,7 @@ let mult_mon m m' = m'' -let compare_mon m m' = +let compare_mon (m : mon) (m' : mon) = let d = nvar m in if !lexico then ( @@ -148,18 +148,18 @@ let compare_mon m m' = let res=ref 0 in let i=ref 1 in (* 1 si lexico pur 0 si degre*) while (!res=0) && (!i<=d) do - res:= (compare m.(!i) m'.(!i)); + res:= (Int.compare m.(!i) m'.(!i)); i:=!i+1; done; !res) else ( (* degre lexicographique inverse *) - match compare m.(0) m'.(0) with + match Int.compare m.(0) m'.(0) with | 0 -> (* meme degre total *) let res=ref 0 in let i=ref d in while (!res=0) && (!i>=1) do - res:= - (compare m.(!i) m'.(!i)); + res:= - (Int.compare m.(!i) m'.(!i)); i:=!i-1; done; !res @@ -402,29 +402,25 @@ let polconst d c = [(c,m)] let plusP p q = - let rec plusP p q = - match p with - [] -> q - |t::p' -> - match q with - [] -> p - |t'::q' -> - match compare_mon (snd t) (snd t') with - 1 -> t::(plusP p' q) - |(-1) -> t'::(plusP p q') - |_ -> let c=P.plusP (fst t) (fst t') in - match P.equal c coef0 with - true -> (plusP p' q') - |false -> (c,(snd t))::(plusP p' q') - in plusP p q + let rec plusP p q accu = match p, q with + | [], [] -> List.rev accu + | [], _ -> List.rev_append accu q + | _, [] -> List.rev_append accu p + | t :: p', t' :: q' -> + let c = compare_mon (snd t) (snd t') in + if c > 0 then plusP p' q (t :: accu) + else if c < 0 then plusP p q' (t' :: accu) + else + let c = P.plusP (fst t) (fst t') in + if P.equal c coef0 then plusP p' q' accu + else plusP p' q' ((c, (snd t)) :: accu) + in + plusP p q [] (* multiplication by (a,monomial) *) let mult_t_pol a m p = - let rec mult_t_pol p = - match p with - [] -> [] - |(b,m')::p -> ((P.multP a b),(mult_mon m m'))::(mult_t_pol p) - in mult_t_pol p + let map (b, m') = (P.multP a b, mult_mon m m') in + CList.map map p let coef_of_int x = P.of_num (Num.Int x) @@ -451,23 +447,27 @@ let emultP a p = in emultP p let multP p q = - let rec aux p = + let rec aux p accu = match p with - [] -> [] - |(a,m)::p' -> plusP (mult_t_pol a m q) (aux p') - in aux p + [] -> accu + |(a,m)::p' -> aux p' (plusP (mult_t_pol a m q) accu) + in aux p [] let puisP p n= match p with [] -> [] |_ -> + if n = 0 then let d = nvar (snd (List.hd p)) in - let rec puisP n = - match n with - 0 -> [coef1, Array.make (d+1) 0] - | 1 -> p - |_ -> multP p (puisP (n-1)) - in puisP n + [coef1, Array.make (d+1) 0] + else + let rec puisP p n = + if n = 1 then p + else + let q = puisP p (n / 2) in + let q = multP q q in + if n mod 2 = 0 then q else multP p q + in puisP p n let rec contentP p = match p with diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index ee1904a660..36bce780bd 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Term open Tactics @@ -468,6 +468,44 @@ let theoremedeszeros lpol p = open Ideal +(* Remove zero polynomials and duplicates from the list of polynomials lp + Return (clp, lb) + where clp is the reduced list and lb is a list of booleans + that has the same size than lp and where true indicates an + element that has been removed + *) +let rec clean_pol lp = + let t = Hashpol.create 12 in + let find p = try Hashpol.find t p + with + Not_found -> Hashpol.add t p true; false in + let rec aux lp = + match lp with + | [] -> [], [] + | p :: lp1 -> + let clp, lb = aux lp1 in + if equal p zeroP || find p then clp, true::lb + else + (p :: clp, false::lb) in + aux lp + +(* Expand the list of polynomials lp putting zeros where the list of + booleans lb indicates there is a missing element + Warning: + the expansion is relative to the end of the list in reversed order + lp cannot have less elements than lb +*) +let expand_pol lb lp = + let rec aux lb lp = + match lb with + | [] -> lp + | true :: lb1 -> zeroP :: aux lb1 lp + | false :: lb1 -> + match lp with + [] -> assert false + | p :: lp1 -> p :: aux lb1 lp1 + in List.rev (aux lb (List.rev lp)) + let theoremedeszeros_termes lp = nvars:=0;(* mise a jour par term_pol_sparse *) List.iter set_nvars_term lp; @@ -518,20 +556,29 @@ let theoremedeszeros_termes lp = | [] -> assert false | p::lp1 -> let lpol = List.rev lp1 in + (* preprocessing : + we remove zero polynomials and duplicate that are not handled by in_ideal + lb is kept in order to fix the certificate in the post-processing + *) + let lpol, lb = clean_pol lpol in let (cert,lp0,p,_lct) = theoremedeszeros lpol p in info "cert ok\n"; let lc = cert.last_comb::List.rev cert.gb_comb in match remove_zeros (fun x -> equal x zeroP) lc with | [] -> assert false | (lq::lci) -> + (* post-processing : we apply the correction for the last line *) + let lq = expand_pol lb lq in (* lci commence par les nouveaux polynomes *) - let m= !nvars in + let m = !nvars in let c = pol_sparse_to_term m (polconst m cert.coef) in let r = Pow(Zero,cert.power) in let lci = List.rev lci in + (* post-processing we apply the correction for the other lines *) + let lci = List.map (expand_pol lb) lci in let lci = List.map (List.map (pol_sparse_to_term m)) lci in let lq = List.map (pol_sparse_to_term m) lq in - info ("number of parametres: "^string_of_int nparam^"\n"); + info ("number of parameters: "^string_of_int nparam^"\n"); info "term computed\n"; (c,r,lci,lq) ) diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 8e2fc07c04..922432460d 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -51,7 +51,7 @@ let facteurs_liste div constant lp = if not (constant r) then l1:=r::(!l1) else p_dans_lmin:=true) - with e when Errors.noncritical e -> ()) + with e when CErrors.noncritical e -> ()) lmin; if !p_dans_lmin then factor lmin lp1 @@ -62,7 +62,7 @@ let facteurs_liste div constant lp = List.iter (fun q -> try (let r = div q p in if not (constant r) then l1:=r::(!l1)) - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> lmin1:=q::(!lmin1)) lmin; factor (List.rev (p::(!lmin1))) !l1) @@ -93,7 +93,7 @@ let factorise_tableau div zero c f l1 = li:=j::(!li); r:=rr; done) - with e when Errors.noncritical e -> ()) + with e when CErrors.noncritical e -> ()) l1; res.(i)<-(!r,!li)) f; diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 0bf30e7fd8..d625e3076a 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -open Errors +open CErrors open Util open Names open Nameops @@ -911,7 +911,7 @@ let rec transform p t = try let v,th,_ = find_constr t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v - with e when Errors.noncritical e -> + with e when CErrors.noncritical e -> let v = new_identifier_var () and th = new_identifier () in hide_constr t' v th isnat; @@ -951,7 +951,7 @@ let rec transform p t = end | Kapp((Zpos|Zneg|Z0),_) -> (try ([],Oz(recognize_number t)) - with e when Errors.noncritical e -> default false t) + with e when CErrors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> let tac,t' = transform (P_APP 1 :: p) t in diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index d7538146f9..5647fbf9fc 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -34,7 +34,7 @@ let omega_tactic l = | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" - | s -> Errors.error ("No Omega knowledge base for type "^s)) + | s -> CErrors.error ("No Omega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index dbd7460e25..b3ea4335f6 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -101,7 +101,7 @@ (*i*) -open Errors +open CErrors open Util open Names open Term diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 5e43dfc42d..187601fc62 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1451,27 +1451,27 @@ Ltac loop t := | (Tint ?X1) => loop X1 (* Eliminations *) | match ?X1 with - | EqTerm x x0 => _ - | LeqTerm x x0 => _ + | EqTerm _ _ => _ + | LeqTerm _ _ => _ | TrueTerm => _ | FalseTerm => _ - | Tnot x => _ - | GeqTerm x x0 => _ - | GtTerm x x0 => _ - | LtTerm x x0 => _ - | NeqTerm x x0 => _ - | Tor x x0 => _ - | Tand x x0 => _ - | Timp x x0 => _ - | Tprop x => _ + | Tnot _ => _ + | GeqTerm _ _ => _ + | GtTerm _ _ => _ + | LtTerm _ _ => _ + | NeqTerm _ _ => _ + | Tor _ _ => _ + | Tand _ _ => _ + | Timp _ _ => _ + | Tprop _ => _ end => destruct X1; auto; Simplify | match ?X1 with - | Tint x => _ - | (x + x0)%term => _ - | (x * x0)%term => _ - | (x - x0)%term => _ - | (- x)%term => _ - | [x]%term => _ + | Tint _ => _ + | (_ + _)%term => _ + | (_ * _)%term => _ + | (_ - _)%term => _ + | (- _)%term => _ + | [_]%term => _ end => destruct X1; auto; Simplify | (if beq ?X1 ?X2 then _ else _) => let H := fresh "H" in diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 21b0f78b5a..4935fe4bbc 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -39,7 +39,7 @@ let destructurate t = | Term.Var id,[] -> Kvar(Names.Id.to_string id) | Term.Prod (Names.Anonymous,typ,body), [] -> Kimp(typ,body) | Term.Prod (Names.Name _,_,_),[] -> - Errors.error "Omega: Not a quantifier-free goal" + CErrors.error "Omega: Not a quantifier-free goal" | _ -> Kufo exception Destruct @@ -346,7 +346,7 @@ let parse_term t = | Kapp("Z.succ",[t]) -> Tsucc t | Kapp("Z.pred",[t]) -> Tplus(t, mk_Z (Bigint.neg Bigint.one)) | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> - (try Tnum (recognize t) with e when Errors.noncritical e -> Tother) + (try Tnum (recognize t) with e when CErrors.noncritical e -> Tother) | _ -> Tother with e when Logic.catchable_exception e -> Tother @@ -368,6 +368,6 @@ let is_scalar t = | Kapp(("Z.opp"|"Z.succ"|"Z.pred"),[t]) -> aux t | Kapp(("Zpos"|"Zneg"|"Z0"),_) -> let _ = recognize t in true | _ -> false in - try aux t with e when Errors.noncritical e -> false + try aux t with e when CErrors.noncritical e -> false end diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index fd4ede6c3d..830dc54ddb 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -27,7 +27,7 @@ let romega_tactic l = | "positive" -> eval_tactic "zify_positive" | "N" -> eval_tactic "zify_N" | "Z" -> eval_tactic "zify_op" - | s -> Errors.error ("No ROmega knowledge base for type "^s)) + | s -> CErrors.error ("No ROmega knowledge base for type "^s)) (Util.List.sort_uniquize String.compare l) in Tacticals.New.tclTHEN diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index a059512d84..ba882e39a2 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -454,7 +454,7 @@ let rec scalar n = function | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_mult_assoc_reduced], Omult(t1,Oint (n*x)) | Omult(t1,t2) -> - Errors.error "Omega: Can't solve a goal with non-linear products" + CErrors.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [], Omult(t,Oint n) | Oint i -> do_list [Lazy.force coq_c_reduce],Oint(n*i) | (Oufo _ as t)-> do_list [], Oufo (Omult(t,Oint n)) @@ -473,7 +473,7 @@ let rec negate = function | Omult(t1,Oint x) -> do_list [Lazy.force coq_c_opp_mult_r], Omult(t1,Oint (Bigint.neg x)) | Omult(t1,t2) -> - Errors.error "Omega: Can't solve a goal with non-linear products" + CErrors.error "Omega: Can't solve a goal with non-linear products" | (Oatom _ as t) -> do_list [Lazy.force coq_c_opp_one], Omult(t,Oint(negone)) | Oint i -> do_list [Lazy.force coq_c_reduce] ,Oint(Bigint.neg i) @@ -545,7 +545,7 @@ let shrink_pair f1 f2 = Lazy.force coq_c_red4, Omult(Oatom v,Oplus(c1,c2)) | t1,t2 -> oprint stdout t1; print_newline (); oprint stdout t2; print_newline (); - flush Pervasives.stdout; Errors.error "shrink.1" + flush Pervasives.stdout; CErrors.error "shrink.1" end (* \subsection{Calcul d'une sous formule constante} *) @@ -559,9 +559,9 @@ let reduce_factor = function let rec compute = function Oint n -> n | Oplus(t1,t2) -> compute t1 + compute t2 - | _ -> Errors.error "condense.1" in + | _ -> CErrors.error "condense.1" in [Lazy.force coq_c_reduce], Omult(Oatom v,Oint(compute c)) - | t -> Errors.error "reduce_factor.1" + | t -> CErrors.error "reduce_factor.1" (* \subsection{Réordonnancement} *) @@ -1304,7 +1304,7 @@ let total_reflexive_omega_tactic gl = let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; resolution env full_reified_goal systems_list gl - with NO_CONTRADICTION -> Errors.error "ROmega can't solve this system" + with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index f3eae5f501..8b92611136 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Errors +open CErrors open Util open Goptions diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 0a0b459156..4ed9079517 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -8,7 +8,7 @@ module Search = Explore.Make(Proof_search) -open Errors +open CErrors open Util open Term open Tacmach @@ -67,12 +67,12 @@ let l_D_Or = lazy (constant "D_Or") let special_whd gl= - let infos=Closure.create_clos_infos Closure.betadeltaiota (pf_env gl) in - (fun t -> Closure.whd_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in + (fun t -> CClosure.whd_val infos (CClosure.inject t)) let special_nf gl= - let infos=Closure.create_clos_infos Closure.betaiotazeta (pf_env gl) in - (fun t -> Closure.norm_val infos (Closure.inject t)) + let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in + (fun t -> CClosure.norm_val infos (CClosure.inject t)) type atom_env= {mutable next:int; diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 55241ab2b3..90f5f8e63d 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -7,12 +7,12 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Term open Vars -open Closure +open CClosure open Environ open Libnames open Globnames @@ -82,7 +82,7 @@ let lookup_map map = errorlabstrm"lookup_map"(str"map "++qs map++str"not found") let protect_red map env sigma c = - kl (create_clos_infos betadeltaiota env) + kl (create_clos_infos all env) (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; let protect_tac map = diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 814e3a4d5a..a34fa4cae7 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -61,8 +61,8 @@ DECLARE PLUGIN "ssrmatching_plugin" type loc = Loc.t let dummy_loc = Loc.ghost -let errorstrm = Errors.errorlabstrm "ssrmatching" -let loc_error loc msg = Errors.user_err_loc (loc, msg, str msg) +let errorstrm = CErrors.errorlabstrm "ssrmatching" +let loc_error loc msg = CErrors.user_err_loc (loc, msg, str msg) let ppnl = Feedback.msg_info (* 0 cost pp function. Active only if env variable SSRDEBUG is set *) @@ -89,7 +89,7 @@ let env_size env = List.length (Environ.named_context env) let safeDestApp c = match kind_of_term c with App (f, a) -> f, a | _ -> c, [| |] let get_index = function ArgArg i -> i | _ -> - Errors.anomaly (str"Uninterpreted index") + CErrors.anomaly (str"Uninterpreted index") (* Toplevel constr must be globalized twice ! *) let glob_constr ist genv = function | _, Some ce -> @@ -150,7 +150,7 @@ let dC t = CastConv t (** Constructors for constr_expr *) let isCVar = function CRef (Ident _, _) -> true | _ -> false let destCVar = function CRef (Ident (_, id), _) -> id | _ -> - Errors.anomaly (str"not a CRef") + CErrors.anomaly (str"not a CRef") let mkCHole loc = CHole (loc, None, IntroAnonymous, None) let mkCLambda loc name ty t = CLambdaN (loc, [[loc, name], Default Explicit, ty], t) @@ -167,8 +167,8 @@ let mkRLambda n s t = GLambda (dummy_loc, n, Explicit, s, t) let combineCG t1 t2 f g = match t1, t2 with | (x, (t1, None)), (_, (t2, None)) -> x, (g t1 t2, None) | (x, (_, Some t1)), (_, (_, Some t2)) -> x, (mkRHole, Some (f t1 t2)) - | _, (_, (_, None)) -> Errors.anomaly (str"have: mixed C-G constr") - | _ -> Errors.anomaly (str"have: mixed G-C constr") + | _, (_, (_, None)) -> CErrors.anomaly (str"have: mixed C-G constr") + | _ -> CErrors.anomaly (str"have: mixed G-C constr") let loc_ofCG = function | (_, (s, None)) -> Glob_ops.loc_of_glob_constr s | (_, (_, Some s)) -> Constrexpr_ops.constr_loc s @@ -491,7 +491,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = | Evar (k, _) -> if Evd.mem sigma0 k then KpatEvar k, f, a else if a <> [] then KpatFlex, f, a else - (match p_origin with None -> Errors.error "indeterminate pattern" + (match p_origin with None -> CErrors.error "indeterminate pattern" | Some (dir, rule) -> errorstrm (str "indeterminate " ++ pr_dir_side dir ++ str " in " ++ pr_constr_pat rule)) @@ -632,12 +632,12 @@ let match_upats_FO upats env sigma0 ise orig_c = let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in raise (FoundUnif (ungen_upat lhs pt' u)) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u - | Not_found -> Errors.anomaly (str"incomplete ise in match_upats_FO") + | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO") | _ -> () in List.iter one_match fpats done; iter_constr_LR loop f; Array.iter loop a in - try loop orig_c with Invalid_argument _ -> Errors.anomaly (str"IN FO") + try loop orig_c with Invalid_argument _ -> CErrors.anomaly (str"IN FO") let prof_FO = mk_profiler "match_upats_FO";; let match_upats_FO upats env sigma0 ise c = @@ -684,7 +684,7 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsatisfiableConstraints _) -> failed_because_of_TC:=true - | e when Errors.noncritical e -> () in + | e when CErrors.noncritical e -> () in List.iter one_match fpats done; iter_constr_LR (aux upats env sigma0 ise) f; @@ -707,11 +707,11 @@ let fixed_upat = function let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) let assert_done r = - match !r with Some x -> x | None -> Errors.anomaly (str"do_once never called") + match !r with Some x -> x | None -> CErrors.anomaly (str"do_once never called") let assert_done_multires r = match !r with - | None -> Errors.anomaly (str"do_once never called") + | None -> CErrors.anomaly (str"do_once never called") | Some (n, xs) -> r := Some (n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch @@ -768,7 +768,7 @@ let source () = match upats_origin, upats with | Some (dir,rule), _ -> str"The " ++ pr_dir_side dir ++ str" of " ++ pr_constr_pat rule ++ spc() | _, [] | None, _::_::_ -> - Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in let on_instance, instances = let instances = ref [] in (fun x -> @@ -806,7 +806,7 @@ let rec uniquize = function errorstrm (source () ++ str "does not match any subterm of the goal") | NoProgress when (not raise_NoMatch) -> let dir = match upats_origin with Some (d,_) -> d | _ -> - Errors.anomaly (str"mk_tpattern_matcher with no upats_origin") in + CErrors.anomaly (str"mk_tpattern_matcher with no upats_origin") in errorstrm (str"all matches of "++source()++ str"are equal to the " ++ pr_dir_side (inv_dir dir)) | NoProgress -> raise NoMatch); @@ -841,7 +841,7 @@ let rec uniquize = function let sigma, uc, ({up_f = pf; up_a = pa} as u) = match !upat_that_matched with | Some (_,x) -> List.hd x | None when raise_NoMatch -> raise NoMatch - | None -> Errors.anomaly (str"companion function never called") in + | None -> CErrors.anomaly (str"companion function never called") in let p' = mkApp (pf, pa) in if max_occ <= !nocc then p', u.up_dir, (sigma, uc, u.up_t) else errorstrm (str"Only " ++ int !nocc ++ str" < " ++ int max_occ ++ @@ -903,7 +903,7 @@ let pr_ssrpattern_roundp _ _ _ = pr_pattern_roundp let wit_rpatternty = add_genarg "rpatternty" pr_pattern let glob_ssrterm gs = function - | k, (_, Some c) as x -> k, + | k, (_, Some c) -> k, let x = Tacintern.intern_constr gs c in fst x, Some c | ct -> ct @@ -1022,7 +1022,7 @@ let glob_cpattern gs p = | (r1, Some _), (r2, Some _) when isCVar t1 -> encode k "In" [r1; r2; bind_in t1 t2] | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] - | _ -> Errors.anomaly (str"where are we?") + | _ -> CErrors.anomaly (str"where are we?") with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] @@ -1109,9 +1109,9 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let v = Id.Map.find id ist.lfun in Option.get reccall (Value.cast (topwit (Option.get wit_ssrpatternarg)) v) - | it -> g t with e when Errors.noncritical e -> g t in + | it -> g t with e when CErrors.noncritical e -> g t in let decodeG t f g = decode ist (mkG t) f g in - let bad_enc id _ = Errors.anomaly (str"bad encoding for pattern "++str id) in + let bad_enc id _ = CErrors.anomaly (str"bad encoding for pattern "++str id) in let cleanup_XinE h x rp sigma = let h_k = match kind_of_term h with Evar (k,_) -> k | _ -> assert false in let to_clean, update = (* handle rename if x is already used *) @@ -1297,7 +1297,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = let e = match p with - | In_T _ | In_X_In_T _ -> Errors.anomaly (str"pattern without redex") + | In_T _ | In_X_In_T _ -> CErrors.anomaly (str"pattern without redex") | T e | X_In_T (e, _) | E_As_X_In_T (e, _, _) | E_In_X_In_T (e, _, _) -> e in let sigma = if not resolve_typeclasses then sigma @@ -1335,7 +1335,7 @@ let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = let fill_occ_term env cl occ sigma0 (sigma, t) = try let sigma',uc,t',cl,_= pf_fill_occ env cl occ sigma0 t (sigma, t) all_ok 1 in - if sigma' != sigma0 then Errors.error "matching impacts evars" + if sigma' != sigma0 then CErrors.error "matching impacts evars" else cl, (Evd.merge_universe_context sigma' uc, t') with NoMatch -> try let sigma', uc, t' = diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 03b49e3336..e18d19ced4 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -11,7 +11,7 @@ let __coq_plugin_name = "ascii_syntax_plugin" let () = Mltop.add_known_module __coq_plugin_name open Pp -open Errors +open CErrors open Util open Names open Glob_term diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 89305838b1..a9eb126b4f 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -17,7 +17,7 @@ open Glob_term open Bigint open Coqlib open Pp -open Errors +open CErrors (*i*) (**********************************************************************) diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index 57cb2f897a..f65f9b7910 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -100,7 +100,7 @@ let int31_of_pos_bigint dloc n = GApp (dloc, ref_construct, List.rev (args 31 n)) let error_negative dloc = - Errors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") + CErrors.user_err_loc (dloc, "interp_int31", Pp.str "int31 are only non-negative numbers.") let interp_int31 dloc n = if is_pos_or_zero n then @@ -189,7 +189,7 @@ let bigN_of_pos_bigint dloc n = GApp (dloc, ref_constructor, args) let bigN_error_negative dloc = - Errors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") + CErrors.user_err_loc (dloc, "interp_bigN", Pp.str "bigN are only non-negative numbers.") let interp_bigN dloc n = if is_pos_or_zero n then diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index ce86c0a65f..60803a369a 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -7,7 +7,7 @@ (************************************************************************) open Pp -open Errors +open CErrors open Util open Names open Bigint |