diff options
Diffstat (limited to 'plugins')
45 files changed, 445 insertions, 337 deletions
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 500f464ea7..f9078c4bdc 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -33,7 +33,6 @@ let debug x = let () = let gdopt= { optdepr=false; - optname="Congruence Verbose"; optkey=["Congruence";"Verbose"]; optread=(fun ()-> !cc_verbose); optwrite=(fun b -> cc_verbose := b)} @@ -492,7 +491,7 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in + let typ = Retyping.get_type_of state.env state.sigma (EConstr.of_constr trm) in let typ = canonize_name state.sigma typ in let new_node= match t with @@ -809,23 +808,23 @@ let new_state_var typ state = let complete_one_class state i= match (get_representative state.uf i).inductive_status with - Partial pac -> - let rec app t typ n = - if n<=0 then t else - let _,etyp,rest= destProd typ in - let id = new_state_var (EConstr.of_constr etyp) state in - app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = Typing.unsafe_type_of state.env state.sigma - (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in - let _c = EConstr.Unsafe.to_constr _c in - let _args = - List.map (fun i -> constr_of_term (term state.uf i)) - pac.args in - let typ = Term.prod_applist _c (List.rev _args) in - let ct = app (term state.uf i) typ pac.arity in - state.uf.epsilons <- pac :: state.uf.epsilons; - ignore (add_term state ct) - | _ -> anomaly (Pp.str "wrong incomplete class.") + | Partial pac -> + let rec app t typ n = + if n<=0 then t else + let _,etyp,rest= destProd typ in + let id = new_state_var (EConstr.of_constr etyp) state in + app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in + let c = Retyping.get_type_of state.env state.sigma + (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in + let c = EConstr.Unsafe.to_constr c in + let args = + List.map (fun i -> constr_of_term (term state.uf i)) + pac.args in + let typ = Term.prod_applist c (List.rev args) in + let ct = app (term state.uf i) typ pac.arity in + state.uf.epsilons <- pac :: state.uf.epsilons; + ignore (add_term state ct) + | _ -> anomaly (Pp.str "wrong incomplete class.") let complete state = Int.Set.iter (complete_one_class state) state.pa_classes diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 556e6b48e6..9ea2224272 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -90,14 +90,13 @@ let rec decompose_term env sigma t= if closed0 sigma t then Symb (EConstr.to_constr ~abort_on_undefined_evars:false sigma t) else raise Not_found (* decompose equality in members and type *) -open Termops let atom_of_constr env sigma term = let wh = whd_delta env sigma term in let kot = EConstr.kind sigma wh in match kot with App (f,args)-> - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if isRefX sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -132,7 +131,7 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= try destApp sigma (whd_delta env sigma term) with DestKO -> raise Not_found in - if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if isRefX sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in @@ -153,7 +152,7 @@ let patterns_of_constr env sigma nrels term= let rec quantified_atom_of_constr env sigma nrels term = match EConstr.kind sigma (whd_delta env sigma term) with Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then + if isRefX sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else @@ -165,7 +164,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let litteral_of_constr env sigma term= match EConstr.kind sigma (whd_delta env sigma term) with | Prod (id,atom,ff) -> - if is_global sigma (Lazy.force _False) ff then + if isRefX sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) @@ -277,10 +276,12 @@ 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 = +let type_and_refresh c k = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in + (* XXX is get_type_of enough? *) + let evm, ty = Typing.type_of env evm c in let evm, ty = refresh_type env evm ty in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (k ty) end @@ -289,7 +290,6 @@ let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> - let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) @@ -297,17 +297,17 @@ let rec proof_tac p : unit Proofview.tactic = let c = EConstr.of_constr c in let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in - refresh_universes (type_of l) (fun typ -> + type_and_refresh l (fun typ -> app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> let lr = constr_of_term t in - refresh_universes (type_of lr) (fun typ -> + type_and_refresh lr (fun typ -> 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 - refresh_universes (type_of t2) (fun typ -> + type_and_refresh t2 (fun typ -> let prf = app_global_with_holes _trans_eq [|typ;t1;t2;t3;|] 2 in Tacticals.New.tclTHENS prf [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> @@ -315,9 +315,9 @@ let rec proof_tac p : unit Proofview.tactic = 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 - refresh_universes (type_of tf1) (fun typf -> - refresh_universes (type_of tx1) (fun typx -> - refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> + type_and_refresh tf1 (fun typf -> + type_and_refresh tx1 (fun typx -> + type_and_refresh (mkApp (tf1,[|tx1|])) (fun typfx -> let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in let appx1 = mkLambda(make_annot (Name id) Sorts.Relevant,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in @@ -341,8 +341,8 @@ let rec proof_tac p : unit Proofview.tactic = let tj=constr_of_term prf.p_rhs in let default=constr_of_term p.p_lhs in let special=mkRel (1+nargs-argind) in - refresh_universes (type_of ti) (fun intype -> - refresh_universes (type_of default) (fun outtype -> + type_and_refresh ti (fun intype -> + type_and_refresh default (fun outtype -> let sigma, proj = build_projection intype cstr special default gl in @@ -362,7 +362,7 @@ let refute_tac c t1 t2 p = let neweq= 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 + in type_and_refresh tt1 k end let refine_exact_check c = @@ -382,7 +382,7 @@ let convert_to_goal_tac c t1 t2 p = 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; endt refine_exact_check] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k + in type_and_refresh tt2 k end let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -401,7 +401,8 @@ let discriminate_tac cstru p = let lhs=constr_of_term p.p_lhs and rhs=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl lhs) in + let evm, intype = Typing.type_of env evm lhs in + let evm, intype = refresh_type env evm intype in let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let neweq=app_global _eq [|intype;lhs;rhs|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) @@ -515,7 +516,7 @@ let f_equal = in Proofview.tclORELSE begin match EConstr.kind sigma concl with - | App (r,[|_;t;t'|]) when is_global sigma (Lazy.force _eq) r -> + | App (r,[|_;t;t'|]) when isRefX sigma (Lazy.force _eq) r -> begin match EConstr.kind sigma t, EConstr.kind sigma t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 35110552ab..853be82eb8 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -27,32 +27,7 @@ open Common (***************************************) let toplevel_env () = - let get_reference = function - | (_,kn), Lib.Leaf Libobject.AtomicObject o -> - let mp,l = KerName.repr kn in - begin match Libobject.object_tag o with - | "CONSTANT" -> - let constant = Global.lookup_constant (Constant.make1 kn) in - Some (l, SFBconst constant) - | "INDUCTIVE" -> - let inductive = Global.lookup_mind (MutInd.make1 kn) in - Some (l, SFBmind inductive) - | _ -> None - end - | (_,kn), Lib.Leaf Libobject.ModuleObject _ -> - let mp,l = KerName.repr kn in - let modl = Global.lookup_module (MPdot (mp, l)) in - Some (l, SFBmodule modl) - | (_,kn), Lib.Leaf Libobject.ModuleTypeObject _ -> - let mp,l = KerName.repr kn in - let modtype = Global.lookup_modtype (MPdot (mp, l)) in - Some (l, SFBmodtype modtype) - | (_,kn), Lib.Leaf Libobject.IncludeObject _ -> - user_err Pp.(str "No extraction of toplevel Include yet.") - | _ -> None - in - List.rev (List.map_filter get_reference (Lib.contents ())) - + List.rev (Safe_typing.structure_body_of_safe_env (Global.safe_env ())) let environment_until dir_opt = let rec parse = function diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 7b64706138..9d07cd7d93 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -503,7 +503,6 @@ let my_bool_option name initval = let access = fun () -> !flag in let () = declare_bool_option {optdepr = false; - optname = "Extraction "^name; optkey = ["Extraction"; name]; optread = access; optwrite = (:=) flag } @@ -575,14 +574,12 @@ let optims () = !opt_flag_ref let () = declare_bool_option {optdepr = false; - optname = "Extraction Optimize"; optkey = ["Extraction"; "Optimize"]; optread = (fun () -> not (Int.equal !int_flag_ref 0)); optwrite = (fun b -> chg_flag (if b then int_flag_init else 0))} let () = declare_int_option { optdepr = false; - optname = "Extraction Flag"; optkey = ["Extraction";"Flag"]; optread = (fun _ -> Some !int_flag_ref); optwrite = (function @@ -596,7 +593,6 @@ let conservative_types () = !conservative_types_ref let () = declare_bool_option {optdepr = false; - optname = "Extraction Conservative Types"; optkey = ["Extraction"; "Conservative"; "Types"]; optread = (fun () -> !conservative_types_ref); optwrite = (fun b -> conservative_types_ref := b) } @@ -608,7 +604,6 @@ let file_comment () = !file_comment_ref let () = declare_string_option {optdepr = false; - optname = "Extraction File Comment"; optkey = ["Extraction"; "File"; "Comment"]; optread = (fun () -> !file_comment_ref); optwrite = (fun s -> file_comment_ref := s) } diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 8946587a02..930801f6fd 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -36,7 +36,6 @@ let ground_depth=ref 3 let ()= let gdopt= { optdepr=false; - optname="Firstorder Depth"; optkey=["Firstorder";"Depth"]; optread=(fun ()->Some !ground_depth); optwrite= @@ -88,7 +87,7 @@ let gen_ground_tac flag taco ids bases = Proofview.Goal.enter begin fun gl -> let seq=empty_seq !ground_depth in let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in - let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in + let seq, sigma = extend_with_auto_hints (pf_env gl) sigma bases seq in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (k seq) end in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index e131cad7da..866b45e4df 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -100,25 +100,28 @@ let rec collect_quantified sigma seq= let dummy_bvid=Id.of_string "x" -let mk_open_instance env evmap id idc m t = - let var_id= - if id==dummy_id then dummy_bvid else - let typ=Typing.unsafe_type_of env evmap idc in +let mk_open_instance env sigma id idc m t = + let var_id = + (* XXX why physical equality? *) + if id == dummy_id then dummy_bvid else + let typ = Retyping.get_type_of env sigma idc in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd evmap (whd_all env evmap typ) in + let (nam,_,_) = destProd sigma (whd_all env sigma typ) in match nam.Context.binder_name with - Name id -> id - | Anonymous -> dummy_bvid in - let revt=substl (List.init m (fun i->mkRel (m-i))) t in - let rec aux n avoid env evmap decls = - if Int.equal n 0 then evmap, decls else - let nid=(fresh_id_in_env avoid var_id env) in - let (evmap, (c, _)) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + | Name id -> id + | Anonymous -> dummy_bvid + in + let revt = substl (List.init m (fun i->mkRel (m-i))) t in + let rec aux n avoid env sigma decls = + if Int.equal n 0 then sigma, decls else + let nid = fresh_id_in_env avoid var_id env in + let (sigma, (c, _)) = Evarutil.new_type_evar env sigma Evd.univ_flexible in let decl = LocalAssum (Context.make_annot (Name nid) Sorts.Relevant, c) in - aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) evmap (decl::decls) in - let evmap, decls = aux m Id.Set.empty env evmap [] in - (evmap, decls, revt) + aux (n-1) (Id.Set.add nid avoid) (EConstr.push_rel decl env) sigma (decl::decls) + in + let sigma, decls = aux m Id.Set.empty env sigma [] in + (sigma, decls, revt) (* tactics *) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 7d84ee6851..c77ddeb040 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -204,28 +204,28 @@ let extend_with_ref_list env sigma l seq = open Hints let extend_with_auto_hints env sigma l seq = - let seqref=ref seq in - let f p_a_t = + let f (seq,sigma) p_a_t = match repr_hint p_a_t.code with - Res_pf (c,_) | Give_exact (c,_) - | Res_pf_THEN_trivial_fail (c,_) -> - let (c, _, _) = c in - (try - let (gr, _) = Termops.global_of_constr sigma c in - let typ=(Typing.unsafe_type_of env sigma c) in - seqref:=add_formula env sigma Hint gr typ !seqref - with Not_found->()) - | _-> () in - let g _ _ l = List.iter f l in - let h dbname= - let hdb= + | Res_pf (c,_) | Give_exact (c,_) + | Res_pf_THEN_trivial_fail (c,_) -> + let (c, _, _) = c in + (match EConstr.destRef sigma c with + | exception Constr.DestKO -> seq, sigma + | gr, _ -> + let sigma, typ = Typing.type_of env sigma c in + add_formula env sigma Hint gr typ seq, sigma) + | _ -> seq, sigma + in + let h acc dbname = + let hdb = try searchtable_map dbname with Not_found-> - user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) in - Hint_db.iter g hdb in - List.iter h l; - !seqref, sigma (*FIXME: forgetting about universes*) + user_err Pp.(str ("Firstorder: "^dbname^" : No such Hint database")) + in + Hint_db.fold (fun _ _ l acc -> List.fold_left f acc l) hdb acc + in + List.fold_left h (seq,sigma) l let print_cmap map= let print_entry c l s= diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 6db0a1119b..9749af1e66 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -475,7 +475,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclIDTAC in try - scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] + scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -525,7 +525,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclMAP (fun id -> Proofview.V82.of_tactic (introduction id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_get_hyp_typ g' heq_id in (* compute the new value of the body *) let new_term_value = match EConstr.kind (project g') new_term_value_eq with @@ -536,22 +536,23 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ); anomaly (Pp.str "cannot compute new term value.") in - let fun_body = - mkLambda(make_annot Anonymous Sorts.Relevant, - pf_unsafe_type_of g' term, - Termops.replace_term (project g') term (mkRel 1) dyn_infos.info - ) - in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in - let new_infos = - {dyn_infos with + let g', termtyp = tac_type_of g' term in + let fun_body = + mkLambda(make_annot Anonymous Sorts.Relevant, + termtyp, + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info + ) + in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_infos = + {dyn_infos with info = new_body; eq_hyps = heq_id::dyn_infos.eq_hyps - } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g' - )]) - ] + } + in + clean_goal_with_heq ptes_infos continue_tac new_infos g' + )]) + ] g @@ -633,7 +634,7 @@ let build_proof let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (project g) (pf_concl g) in - let type_of_term = pf_unsafe_type_of g t in + let g, type_of_term = tac_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -849,7 +850,7 @@ let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in - let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in + let hyp_typ = pf_get_hyp_typ g hyp in let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> @@ -1351,7 +1352,7 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in + let _,hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = @@ -1573,19 +1574,16 @@ let prove_principle_for_gen (List.rev_map (get_name %> Nameops.Name.get_id) (princ_info.args@princ_info.branches@princ_info.predicates@princ_info.params) ); - (* observe_tac "" *) Proofview.V82.of_tactic (assert_by - (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc) - ); -(* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) -(* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) - (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) + Proofview.V82.of_tactic + (assert_by + (Name acc_rec_arg_id) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (Proofview.V82.tactic prove_rec_arg_acc)); + (revert (List.rev (acc_rec_arg_id::args_ids))); + (Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1))); h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); - (* observe_tac "finish" *) (fun gl' -> + (fun gl' -> let body = let _,args = destApp (project gl') (pf_concl gl') in Array.last args diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 58efee1518..68661174ac 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -617,7 +617,7 @@ let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let type_of_hid = pf_get_hyp_typ g hid in let sigma = project g in match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> @@ -953,7 +953,7 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + match EConstr.kind (project g) (pf_get_hyp_typ g id) with | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g @@ -993,7 +993,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : Tacmach.tacti (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = Reductionops.nf_zeta (pf_env g) (project g) (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g graph_principle in + let g, princ_type = tac_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them @@ -1210,7 +1210,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes + List.map (EConstr.of_constr %> Retyping.get_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in let i = ref (-1) in let sorts = @@ -2051,7 +2051,7 @@ let build_case_scheme fa = let (sigma, scheme) = Indrec.build_case_analysis_scheme_default env sigma ind sf in - let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in + let scheme_type = EConstr.Unsafe.to_constr ((Retyping.get_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> fst @@ UnivGen.fresh_sort_in_family x diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index e41b92d4dc..84f09c385f 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -514,8 +514,9 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) + (* XXX here and other [understand] calls drop the ctx *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let rt_typ = Retyping.get_type_of env (Evd.from_env env) rt_as_constr in let res_raw_type = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -629,7 +630,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret let v = match typ with None -> v | Some t -> DAst.make ?loc:rt.loc @@ GCast (v,CastConv t) in let v_res = build_entry_lc env sigma funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in + let v_type = Retyping.get_type_of env (Evd.from_env env) v_as_constr in let v_r = Sorts.Relevant in (* TODO relevance *) let new_env = match n with @@ -646,7 +647,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret build_entry_lc_from_case env sigma funnames make_discr el brl avoid | GIf(b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -678,7 +679,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Retyping.get_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -723,7 +724,7 @@ and build_entry_lc_from_case env sigma funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr) + EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) case_arg_as_constr) ) el in (****** The next works only if the match is not dependent ****) @@ -769,9 +770,7 @@ and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to let env_with_pat_ids = add_pat_variables sigma pat typ new_env in List.fold_right (fun id acc -> - let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) - in + let typ_of_id = Typing.type_of_variable env_with_pat_ids id in let raw_typ_of_id = Detyping.detype Detyping.Now false Id.Set.empty env_with_pat_ids (Evd.from_env env) typ_of_id @@ -832,7 +831,7 @@ and build_entry_lc_from_case_term env sigma types funname make_discr patterns_to (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in + let typ_of_id = Typing.type_of_variable new_env id in let raw_typ_of_id = Detyping.detype Detyping.Now false Id.Set.empty new_env (Evd.from_env env) typ_of_id in @@ -1166,7 +1165,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in - let type_t' = Typing.unsafe_type_of env evd t' in + let type_t' = Retyping.get_type_of env evd t' in let t' = EConstr.Unsafe.to_constr t' in let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (make_annot n Sorts.Relevant,t',type_t')) env in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a205c0744a..f28e98dcc2 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -64,12 +64,10 @@ let functional_induction with_clean c princl pat = | InSet -> finfo.rec_lemma | InType -> finfo.rect_lemma in - let princ = (* then we get the principle *) + let sigma, princ = (* then we get the principle *) match princ_option with | Some princ -> - let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT princ + Evd.fresh_global (pf_env gl) (project gl) (GlobRef.ConstRef princ) | None -> (*i If there is not default lemma defined then, we cross our finger and try to find a lemma named f_ind @@ -87,19 +85,18 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++ Printer.pr_leconstr_env (pf_env gl) sigma (mkConst c') ) in - let sigma, princ = Evd.fresh_global (pf_env gl) (project gl) princ_ref in - Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT princ + Evd.fresh_global (pf_env gl) (project gl) princ_ref in - princ >>= fun princ -> - (* We need to refresh gl due to the updated evar_map in princ *) - Proofview.Goal.enter_one (fun gl -> - Proofview.tclUNIT (princ, Tactypes.NoBindings, pf_unsafe_type_of gl princ, args)) + let princt = Retyping.get_type_of (pf_env gl) sigma princ in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT (princ, Tactypes.NoBindings, princt, args) | _ -> CErrors.user_err (str "functional induction must be used with a function" ) end | Some ((princ,binding)) -> - Proofview.tclUNIT (princ, binding, pf_unsafe_type_of gl princ, args) + let sigma, princt = pf_type_of gl princ in + Proofview.Unsafe.tclEVARS sigma <*> + Proofview.tclUNIT (princ, binding, princt, args) ) >>= fun (princ, bindings, princ_type, args) -> Proofview.Goal.enter (fun gl -> let sigma = project gl in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index b55d8537d6..b2ee0f9370 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -320,7 +320,6 @@ open Goptions let functional_induction_rewrite_dependent_proofs_sig = { optdepr = false; - optname = "Functional Induction Rewrite Dependent"; optkey = ["Functional";"Induction";"Rewrite";"Dependent"]; optread = (fun () -> !functional_induction_rewrite_dependent_proofs); optwrite = (fun b -> functional_induction_rewrite_dependent_proofs := b) @@ -332,7 +331,6 @@ let do_rewrite_dependent () = !functional_induction_rewrite_dependent_proofs = t let function_debug_sig = { optdepr = false; - optname = "Function debug"; optkey = ["Function_debug"]; optread = (fun () -> !function_debug); optwrite = (fun b -> function_debug := b) @@ -416,7 +414,6 @@ let is_strict_tcc () = !strict_tcc let strict_tcc_sig = { optdepr = false; - optname = "Raw Function Tcc"; optkey = ["Function_raw_tcc"]; optread = (fun () -> !strict_tcc); optwrite = (fun b -> strict_tcc := b) @@ -526,3 +523,7 @@ let funind_purify f x = let e = CErrors.push e in Vernacstate.unfreeze_interp_state st; Exninfo.iraise e + +let tac_type_of g c = + let sigma, t = Tacmach.pf_type_of g c in + {g with Evd.sigma}, t diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 550f727951..bd8b34088b 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -119,3 +119,5 @@ type tcc_lemma_value = | Not_needed val funind_purify : ('a -> 'b) -> ('a -> 'b) + +val tac_type_of : Goal.goal Evd.sigma -> EConstr.constr -> Goal.goal Evd.sigma * EConstr.types diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d72319d078..332d058ce7 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -28,7 +28,7 @@ open Indfun_common *) let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> let sigma = project gl in - let typ = pf_unsafe_type_of gl (mkVar hid) in + let typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma typ with | App(i,args) when isInd sigma i -> let ((kn',num) as ind'),u = destInd sigma i in @@ -77,7 +77,7 @@ let revert_graph kn post_tac hid = Proofview.Goal.enter (fun gl -> let functional_inversion kn hid fconst f_correct = Proofview.Goal.enter (fun gl -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps gl) Id.Set.empty in let sigma = project gl in - let type_of_h = pf_unsafe_type_of gl (mkVar hid) in + let type_of_h = pf_get_hyp_typ hid gl in match EConstr.kind sigma type_of_h with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> let pre_tac,f_args,res = @@ -128,7 +128,7 @@ let invfun qhyp f = | None -> let tac_action hid gl = let sigma = project gl in - let hyp_typ = pf_unsafe_type_of gl (mkVar hid) in + let hyp_typ = pf_get_hyp_typ hid gl in match EConstr.kind sigma hyp_typ with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 66ed1961ba..f7f8004998 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -31,7 +31,6 @@ open Tactics open Nametab open Declare open Tacred -open Goal open Glob_term open Pretyping open Termops @@ -110,9 +109,10 @@ let pf_get_new_ids idl g = let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) -let compute_renamed_type gls c = +let compute_renamed_type gls id = rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty (*no rels*) [] - (pf_unsafe_type_of gls c) + (pf_get_hyp_typ gls id) + let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -370,7 +370,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> - let ty_teq = pf_unsafe_type_of g' (mkVar heq) in + let ty_teq = pf_get_hyp_typ g' heq in let teq_lhs,teq_rhs = let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) @@ -487,13 +487,13 @@ let rec prove_lt hyple g = in let h = List.find (fun id -> - match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with + match decompose_app sigma (pf_get_hyp_typ g id) with | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) in observe_tclTHENLIST (fun _ _ -> str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) @@ -645,9 +645,7 @@ let pf_typel l tac = modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) -let mkDestructEq : - Id.t list -> constr -> goal Evd.sigma -> tactic * Id.t list = - fun not_on_hyp expr g -> +let mkDestructEq not_on_hyp expr g = let hyps = pf_hyps g in let to_revert = Util.List.map_filter @@ -657,9 +655,9 @@ let mkDestructEq : if Id.List.mem id not_on_hyp || not (Termops.dependent (project g) expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_unsafe_type_of g expr in - let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: - to_revert_constr in + let g, type_of_expr = tac_type_of g expr in + let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|])::to_revert_constr in + let tac = pf_typel new_hyps (fun _ -> observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); @@ -668,7 +666,9 @@ let mkDestructEq : pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]), to_revert + Proofview.V82.of_tactic (simplest_case expr)]) + in + g, tac, to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let sigma = project g in @@ -686,7 +686,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = info = mkCase(ci,t,a',l); is_main_branch = expr_info.is_main_branch; is_final = expr_info.is_final} in - let destruct_tac,rev_to_thin_intro = + let g,destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in observe_tac (fun _ _ -> str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr_env (pf_env g) sigma a') @@ -842,7 +842,7 @@ let rec make_rewrite_list expr_info max = function (observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p ) ( (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in + let t_eq = compute_renamed_type g hp in let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in @@ -868,7 +868,7 @@ let make_rewrite expr_info l hp max = (observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS (fun g -> let sigma = project g in - let t_eq = compute_renamed_type g (mkVar hp) in + let t_eq = compute_renamed_type g hp in let k,def = let k_na,_,t = destProd sigma t_eq in let _,_,t = destProd sigma t in diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 6c63a891e8..513f5ca77b 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -736,7 +736,7 @@ let refl_equal () = Coqlib.lib_ref "core.eq.type" call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.enter begin fun gl -> - let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in + let type_of_a = Tacmach.New.pf_get_type_of gl a in Tacticals.New.pf_constr_of_global (delayed_force refl_equal) >>= fun req -> Tacticals.New.tclTHENLIST [Tactics.generalize [(mkApp(req, [| type_of_a; a|]))]; @@ -794,7 +794,7 @@ let destauto t = let destauto_in id = Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in + let ctype = Tacmach.New.pf_get_type_of gl (mkVar id) in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 81a6651745..7ea843ca69 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -368,7 +368,6 @@ let print_info_trace = ref None let () = declare_int_option { optdepr = false; - optname = "print info trace"; optkey = ["Info" ; "Level"]; optread = (fun () -> !print_info_trace); optwrite = fun n -> print_info_trace := n; diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index fe5ebf1172..7529f9fce6 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -450,7 +450,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac Profiling"; optkey = ["Ltac"; "Profiling"]; optread = get_profiling; optwrite = set_profiling } diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 98d14f3d33..fbc64d95d0 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -289,18 +289,18 @@ end) = struct if Int.equal n 0 then c else match EConstr.kind sigma c with - | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + | App (f, [| a; b; relb |]) when isRefX sigma (pointwise_relation_ref ()) f -> decomp_pointwise sigma (pred n) relb - | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + | App (f, [| a; b; arelb |]) when isRefX sigma (forall_relation_ref ()) f -> decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1])) | _ -> invalid_arg "decomp_pointwise" let rec apply_pointwise sigma rel = function | arg :: args -> (match EConstr.kind sigma rel with - | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + | App (f, [| a; b; relb |]) when isRefX sigma (pointwise_relation_ref ()) f -> apply_pointwise sigma relb args - | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + | App (f, [| a; b; arelb |]) when isRefX sigma (forall_relation_ref ()) f -> apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args | _ -> invalid_arg "apply_pointwise") | [] -> rel @@ -357,7 +357,7 @@ end) = struct match EConstr.kind sigma t with | App (c, args) when Array.length args >= 2 -> let head = if isApp sigma c then fst (destApp sigma c) else c in - if Termops.is_global sigma (coq_eq_ref ()) head then None + if isRefX sigma (coq_eq_ref ()) head then None else (try let params, args = Array.chop (Array.length args - 2) args in @@ -483,7 +483,7 @@ let rec decompose_app_rel env evd t = | App (f, [||]) -> assert false | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in - let ty = Typing.unsafe_type_of env evd argl in + let ty = Retyping.get_type_of env evd argl in let r = Retyping.relevance_of_type env evd ty in let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, @@ -789,7 +789,8 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let morphargs, morphobjs = Array.chop first args in let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in - let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in + let evd, appmtype = Typing.type_of env (goalevars evars) appm in + let evars = evd, snd evars in let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') @@ -1879,13 +1880,13 @@ let declare_projection n instance_id r = let rec aux t = match EConstr.kind sigma t with | App (f, [| a ; a' ; rel; rel' |]) - when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + when isRefX sigma (PropGlobal.respectful_ref ()) f -> succ (aux rel') | _ -> 0 in let init = match EConstr.kind sigma typ with - App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + App (f, args) when isRefX sigma (PropGlobal.respectful_ref ()) f -> mkApp (f, fst (Array.chop (Array.length args - 2) args)) | _ -> typ in aux init @@ -1906,7 +1907,7 @@ let declare_projection n instance_id r = let build_morphism_signature env sigma m = let m,ctx = Constrintern.interp_constr env sigma m in let sigma = Evd.from_ctx ctx in - let t = Typing.unsafe_type_of env sigma m in + let t = Retyping.get_type_of env sigma m in let cstrs = let rec aux t = match EConstr.kind sigma t with @@ -1936,7 +1937,7 @@ let build_morphism_signature env sigma m = let default_morphism sign m = let env = Global.env () in let sigma = Evd.from_env env in - let t = Typing.unsafe_type_of env sigma m in + let t = Retyping.get_type_of env sigma m in let evars, _, sign, cstrs = PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in @@ -2195,10 +2196,10 @@ let setoid_transitivity c = (transitivity_red true c) let setoid_symmetry_in id = - let open Tacmach.New in Proofview.Goal.enter begin fun gl -> - let sigma = project gl in - let ctype = pf_unsafe_type_of gl (mkVar id) in + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let ctype = Retyping.get_type_of env sigma (mkVar id) in let binders,concl = decompose_prod_assum sigma ctype in let (equiv, args) = decompose_app sigma concl in let rec split_last_two = function diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index a57cc76faa..de70fb292a 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -341,8 +341,8 @@ let coerce_to_reference sigma v = match Value.to_constr v with | Some c -> begin - try fst (Termops.global_of_constr sigma c) - with Not_found -> raise (CannotCoerceTo "a reference") + try fst (EConstr.destRef sigma c) + with DestKO -> raise (CannotCoerceTo "a reference") end | None -> raise (CannotCoerceTo "a reference") diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 98aa649b62..6e620b71db 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2082,7 +2082,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac debug"; optkey = ["Ltac";"Debug"]; optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } @@ -2091,7 +2090,6 @@ let () = let open Goptions in declare_bool_option { optdepr = false; - optname = "Ltac Backtrace"; optkey = ["Ltac"; "Backtrace"]; optread = (fun () -> !log_trace); optwrite = (fun b -> log_trace := b) } diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index 539536911c..0e9465839a 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -86,7 +86,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "Ltac batch debug"; optkey = ["Ltac";"Batch";"Debug"]; optread = (fun () -> !batch); optwrite = (fun x -> batch := x) } diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index ba759441e5..92110d7a43 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -68,7 +68,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "unfolding of not in intuition"; optkey = ["Intuition";"Negation";"Unfolding"]; optread = (fun () -> !negation_unfolding); optwrite = (:=) negation_unfolding } diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 97f6fe0613..edfb5a2a94 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -523,3 +523,22 @@ Instance SatProdPos : Saturate Z.mul := SatOk := Z.mul_pos_pos |}. Add Saturate SatProdPos. + +Lemma pow_pos_strict : + forall a b, + 0 < a -> 0 < b -> 0 < a ^ b. +Proof. + intros. + apply Z.pow_pos_nonneg; auto. + apply Z.lt_le_incl;auto. +Qed. + + +Instance SatPowPos : Saturate Z.pow := + {| + PArg1 := fun x => 0 < x; + PArg2 := fun y => 0 < y; + PRes := fun r => 0 < r; + SatOk := pow_pos_strict + |}. +Add Saturate SatPowPos. diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index cb15274736..61234145e1 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -395,50 +395,40 @@ let saturate_by_linear_equalities sys = output_sys sys output_sys sys'; sys' -(* let saturate_linear_equality_non_linear sys0 = - let (l,_) = extract_all (is_substitution false) sys0 in - let rec elim l acc = - match l with - | [] -> acc - | (v,pc)::l' -> - let nc = saturate (non_linear_pivot sys0 pc v) (sys0@acc) in - elim l' (nc@acc) in - elim l [] - *) - -let bounded_vars (sys : WithProof.t list) = - let l = fst (extract_all (fun ((p, o), prf) -> LinPoly.is_variable p) sys) in - List.fold_left (fun acc (i, wp) -> IMap.add i wp acc) IMap.empty l - -let rec power n p = if n = 1 then p else WithProof.product p (power (n - 1) p) - -let bound_monomial mp m = - if Monomial.is_var m || Monomial.is_const m then None - else - try - Some - (Monomial.fold - (fun v i acc -> - let wp = IMap.find v mp in - WithProof.product (power i wp) acc) - m (WithProof.const (Int 1))) - with Not_found -> None - let bound_monomials (sys : WithProof.t list) = - let mp = bounded_vars sys in - let m = + let l = + extract_all + (fun ((p, o), _) -> + match LinPoly.get_bound p with + | None -> None + | Some Vect.Bound.{cst; var; coeff} -> + Some (Monomial.degree (LinPoly.MonT.retrieve var))) + sys + in + let deg = + List.fold_left (fun acc ((p, o), _) -> max acc (LinPoly.degree p)) 0 sys + in + let vars = List.fold_left - (fun acc ((p, _), _) -> - Vect.fold - (fun acc v _ -> - let m = LinPoly.MonT.retrieve v in - match bound_monomial mp m with - | None -> acc - | Some r -> IMap.add v r acc) - acc p) - IMap.empty sys + (fun acc ((p, o), _) -> ISet.union (LinPoly.monomials p) acc) + ISet.empty sys + in + let bounds = + saturate_bin + (fun (i1, w1) (i2, w2) -> + if i1 + i2 > deg then None + else + match WithProof.mul_bound w1 w2 with + | None -> None + | Some b -> Some (i1 + i2, b)) + (fst l) + in + let has_mon (_, ((p, o), _)) = + match LinPoly.get_bound p with + | None -> false + | Some Vect.Bound.{cst; var; coeff} -> ISet.mem var vars in - IMap.fold (fun _ e acc -> e :: acc) m [] + List.map snd (List.filter has_mon bounds) @ snd l let develop_constraints prfdepth n_spec sys = LinPoly.MonT.clear (); diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 92a2222cfa..4b656f8e61 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -55,7 +55,6 @@ let use_csdp_cache = ref true let () = let int_opt l vref = { optdepr = false - ; optname = List.fold_right ( ^ ) l "" ; optkey = l ; optread = (fun () -> Some !vref) ; optwrite = @@ -63,42 +62,36 @@ let () = in let lia_enum_opt = { optdepr = false - ; optname = "Lia Enum" ; optkey = ["Lia"; "Enum"] ; optread = (fun () -> !lia_enum) ; optwrite = (fun x -> lia_enum := x) } in let solver_opt = { optdepr = false - ; optname = "Use the Simplex instead of Fourier elimination" ; optkey = ["Simplex"] ; optread = (fun () -> !Certificate.use_simplex) ; optwrite = (fun x -> Certificate.use_simplex := x) } in let dump_file_opt = { optdepr = false - ; optname = "Generate Coq goals in file from calls to 'lia' 'nia'" ; optkey = ["Dump"; "Arith"] ; optread = (fun () -> !Certificate.dump_file) ; optwrite = (fun x -> Certificate.dump_file := x) } in let lia_cache_opt = { optdepr = false - ; optname = "cache of lia (.lia.cache)" ; optkey = ["Lia"; "Cache"] ; optread = (fun () -> !use_lia_cache) ; optwrite = (fun x -> use_lia_cache := x) } in let nia_cache_opt = { optdepr = false - ; optname = "cache of nia (.nia.cache)" ; optkey = ["Nia"; "Cache"] ; optread = (fun () -> !use_nia_cache) ; optwrite = (fun x -> use_nia_cache := x) } in let nra_cache_opt = { optdepr = false - ; optname = "cache of nra (.nra.cache)" ; optkey = ["Nra"; "Cache"] ; optread = (fun () -> !use_nra_cache) ; optwrite = (fun x -> use_nra_cache := x) } @@ -2416,6 +2409,36 @@ let nqa = (fun _ x -> x) Mc.cnfQ qq_domain_spec dump_qexpr nlinear_prover_R +let print_lia_profile () = + Simplex.( + let { number_of_successes + ; number_of_failures + ; success_pivots + ; failure_pivots + ; average_pivots + ; maximum_pivots } = + Simplex.get_profile_info () + in + Feedback.msg_notice + Pp.( + (* successes *) + str "number of successes: " + ++ int number_of_successes ++ fnl () + (* success pivots *) + ++ str "number of success pivots: " + ++ int success_pivots ++ fnl () + (* failure *) + ++ str "number of failures: " + ++ int number_of_failures ++ fnl () + (* failure pivots *) + ++ str "number of failure pivots: " + ++ int failure_pivots ++ fnl () + (* Other *) + ++ str "average number of pivots: " + ++ int average_pivots ++ fnl () + ++ str "maximum number of pivots: " + ++ int maximum_pivots ++ fnl ())) + (* Local Variables: *) (* coding: utf-8 *) (* End: *) diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index 37ea560241..bcfc47357f 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(*val is_ground_tac : EConstr.constr -> unit Proofview.tactic*) val psatz_Z : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_Q : int -> unit Proofview.tactic -> unit Proofview.tactic val psatz_R : int -> unit Proofview.tactic -> unit Proofview.tactic @@ -21,6 +20,7 @@ val sos_Q : unit Proofview.tactic -> unit Proofview.tactic val sos_R : unit Proofview.tactic -> unit Proofview.tactic val lra_Q : unit Proofview.tactic -> unit Proofview.tactic val lra_R : unit Proofview.tactic -> unit Proofview.tactic +val print_lia_profile : unit -> unit (** {5 Use Micromega independently from tactics. } *) diff --git a/plugins/micromega/g_micromega.mlg b/plugins/micromega/g_micromega.mlg index edf8106f30..d0f70bceac 100644 --- a/plugins/micromega/g_micromega.mlg +++ b/plugins/micromega/g_micromega.mlg @@ -28,10 +28,6 @@ open Tacarg DECLARE PLUGIN "micromega_plugin" -TACTIC EXTEND RED -| [ "myred" ] -> { Tactics.red_in_concl } -END - TACTIC EXTEND PsatzZ | [ "psatz_Z" int_or_var(i) tactic(t) ] -> { (Coq_micromega.psatz_Z i (Tacinterp.tactic_of_value ist t)) @@ -87,3 +83,6 @@ TACTIC EXTEND PsatzQ | [ "psatz_Q" tactic(t) ] -> { (Coq_micromega.psatz_Q (-1) (Tacinterp.tactic_of_value ist t)) } END +VERNAC COMMAND EXTEND ShowLiaProfile CLASSIFIED AS QUERY +| [ "Show" "Lia" "Profile" ] -> { Coq_micromega.print_lia_profile () } +END diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 03f042647c..160b492d3d 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -140,6 +140,25 @@ let saturate p f sys = Printexc.print_backtrace stdout; raise x +let saturate_bin (f : 'a -> 'a -> 'a option) (l : 'a list) = + let rec map_with acc e l = + match l with + | [] -> acc + | e' :: l' -> ( + match f e e' with + | None -> map_with acc e l' + | Some r -> map_with (r :: acc) e l' ) + in + let rec map2_with acc l' = + match l' with [] -> acc | e' :: l' -> map2_with (map_with acc e' l) l' + in + let rec iterate acc l' = + match map2_with [] l' with + | [] -> List.rev_append l' acc + | res -> iterate (List.rev_append l' acc) res + in + iterate [] l + open Num open Big_int diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index ef8d154b13..5dcaf3be44 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -116,6 +116,7 @@ val simplify : ('a -> 'a option) -> 'a list -> 'a list option val saturate : ('a -> 'b option) -> ('b * 'a -> 'a -> 'a option) -> 'a list -> 'a list +val saturate_bin : ('a -> 'a -> 'a option) -> 'a list -> 'a list val generate : ('a -> 'b option) -> 'a list -> 'b list val app_funs : ('a -> 'b option) list -> 'a -> 'b option val command : string -> string array -> 'a -> 'b diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index a4f9b60b14..b20213979b 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -379,6 +379,8 @@ module LinPoly = struct else acc) [] l + let get_bound p = Vect.Bound.of_vect p + let min_list (l : int list) = match l with [] -> None | e :: l -> Some (List.fold_left min e l) @@ -892,8 +894,9 @@ module WithProof = struct if Vect.is_null r && n >/ Int 0 then ((LinPoly.product p p1, o1), ProofFormat.mul_cst_proof n prf1) else ( - Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output - ((p1, o1), prf1); + if debug then + Printf.printf "mult_error %a [*] %a\n" LinPoly.pp p output + ((p1, o1), prf1); raise InvalidProof ) let cutting_plane ((p, o), prf) = @@ -1027,6 +1030,31 @@ module WithProof = struct else None in saturate select gen sys0 + + open Vect.Bound + + let mul_bound w1 w2 = + let (p1, o1), prf1 = w1 in + let (p2, o2), prf2 = w2 in + match (LinPoly.get_bound p1, LinPoly.get_bound p2) with + | None, _ | _, None -> None + | ( Some {cst = c1; var = v1; coeff = c1'} + , Some {cst = c2; var = v2; coeff = c2'} ) -> ( + let good_coeff b o = + match o with + | Eq -> Some (minus_num b) + | _ -> if b <=/ Int 0 then Some (minus_num b) else None + in + match (good_coeff c1 o2, good_coeff c2 o1) with + | None, _ | _, None -> None + | Some c1, Some c2 -> + let ext_mult c w = + if c =/ Int 0 then zero else mult (LinPoly.constant c) w + in + Some + (addition + (addition (product w1 w2) (ext_mult c1 w2)) + (ext_mult c2 w1)) ) end (* Local Variables: *) diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 7e905ac69b..4b56b037e0 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -224,6 +224,8 @@ module LinPoly : sig p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) + val get_bound : t -> Vect.Bound.t option + val product : t -> t -> t (** [product p q] @return the product of the polynomial [p*q] *) @@ -372,4 +374,5 @@ module WithProof : sig val saturate_subst : bool -> t list -> t list val is_substitution : bool -> t -> var option + val mul_bound : t -> t -> t option end diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index ade8143f3c..54976221bc 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -18,6 +18,49 @@ type ('a, 'b) sum = Inl of 'a | Inr of 'b let debug = false +(** Exploiting profiling information *) + +let profile_info = ref [] +let nb_pivot = ref 0 + +type profile_info = + { number_of_successes : int + ; number_of_failures : int + ; success_pivots : int + ; failure_pivots : int + ; average_pivots : int + ; maximum_pivots : int } + +let init_profile = + { number_of_successes = 0 + ; number_of_failures = 0 + ; success_pivots = 0 + ; failure_pivots = 0 + ; average_pivots = 0 + ; maximum_pivots = 0 } + +let get_profile_info () = + let update_profile + { number_of_successes + ; number_of_failures + ; success_pivots + ; failure_pivots + ; average_pivots + ; maximum_pivots } (b, i) = + { number_of_successes = (number_of_successes + if b then 1 else 0) + ; number_of_failures = (number_of_failures + if b then 0 else 1) + ; success_pivots = (success_pivots + if b then i else 0) + ; failure_pivots = (failure_pivots + if b then 0 else i) + ; average_pivots = average_pivots + 1 (* number of proofs *) + ; maximum_pivots = max maximum_pivots i } + in + let p = List.fold_left update_profile init_profile !profile_info in + profile_info := []; + { p with + average_pivots = + ( try (p.success_pivots + p.failure_pivots) / p.average_pivots + with Division_by_zero -> 0 ) } + type iset = unit IMap.t type tableau = Vect.t IMap.t @@ -60,10 +103,7 @@ let output_tableau o t = t let output_env o t = - IMap.iter - (fun k v -> - Printf.fprintf o "%a : %a\n" LinPoly.pp_var k WithProof.output v) - t + IMap.iter (fun k v -> Printf.fprintf o "%i : %a\n" k WithProof.output v) t let output_vars o m = IMap.iter (fun k _ -> Printf.fprintf o "%a " LinPoly.pp_var k) m @@ -224,6 +264,7 @@ let pivot_with (m : tableau) (v : var) (p : Vect.t) = IMap.map (fun (r : Vect.t) -> pivot_row r v p) m let pivot (m : tableau) (r : var) (c : var) = + incr nb_pivot; let row = safe_find "pivot" r m in let piv = solve_column c r row in IMap.add c piv (pivot_with (IMap.remove r m) c piv) @@ -477,8 +518,11 @@ let make_farkas_proof (env : WithProof.t IMap.t) vm v = try let x', b = IMap.find x vm in let n = if b then n else Num.minus_num n in - WithProof.mult (Vect.cst n) (IMap.find x' env) - with Not_found -> WithProof.mult (Vect.cst n) (IMap.find x env) + let prf = IMap.find x' env in + WithProof.mult (Vect.cst n) prf + with Not_found -> + let prf = IMap.find x env in + WithProof.mult (Vect.cst n) prf end) WithProof.zero v @@ -493,21 +537,43 @@ type ('a, 'b) hitkind = let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = let n, r = Vect.decomp_cst v in - let f = frac_num n in - if f =/ Int 0 then Forget (* The solution is integral *) + let fn = frac_num n in + if fn =/ Int 0 then Forget (* The solution is integral *) else - (* This is potentially a cut *) - let t = - if f </ Int 1 // Int 2 then - let t' = Int 1 // f in - if Num.is_integer_num t' then t' -/ Int 1 else Num.floor_num t' - else Int 1 - in - let cut_coeff1 v = + (* The cut construction is from: + Letchford and Lodi. Strengthening Chvatal-Gomory cuts and Gomory fractional cuts. + + We implement the classic Proposition 2 from the "known results" + *) + + (* Proposition 3 requires all the variables to be restricted and is + therefore not always applicable. *) + (* let ccoeff_prop1 v = frac_num v in + let ccoeff_prop3 v = + (* mixed integer cut *) let fv = frac_num v in - if fv <=/ Int 1 -/ f then fv // (Int 1 -/ f) else (Int 1 -/ fv) // f + Num.min_num fv (fn */ (Int 1 -/ fv) // (Int 1 -/ fn)) in - let cut_coeff2 v = frac_num (t */ v) in + let ccoeff_prop3 = + if Restricted.is_restricted x rst then ("Prop3", ccoeff_prop3) + else ("Prop1", ccoeff_prop1) + in *) + let n0_5 = Int 1 // Int 2 in + (* If the fractional part [fn] is small, we construct the t-cut. + If the fractional part [fn] is big, we construct the t-cut of the negated row. + (This is only a cut if all the fractional variables are restricted.) + *) + let ccoeff_prop2 = + let tmin = + if fn </ n0_5 then (* t-cut *) + Num.ceiling_num (n0_5 // fn) + else + (* multiply by -1 & t-cut *) + minus_num (Num.ceiling_num (n0_5 // (Int 1 -/ fn))) + in + ("Prop2", fun v -> frac_num (v */ tmin)) + in + let ccoeff = ccoeff_prop2 in let cut_vector ccoeff = Vect.fold (fun acc x n -> @@ -516,35 +582,31 @@ let cut env rmin sol vm (rst : Restricted.t) tbl (x, v) = Vect.null r in let lcut = - List.map - (fun cv -> Vect.normalise (cut_vector cv)) - [cut_coeff1; cut_coeff2] + ( fst ccoeff + , make_farkas_proof env vm (Vect.normalise (cut_vector (snd ccoeff))) ) in - let lcut = List.map (make_farkas_proof env vm) lcut in - let check_cutting_plane c = + let check_cutting_plane (p, c) = match WithProof.cutting_plane c with | None -> if debug then - Printf.printf "This is not a cutting plane for %a\n%a:" LinPoly.pp_var - x WithProof.output c; + Printf.printf "%s: This is not a cutting plane for %a\n%a:" p + LinPoly.pp_var x WithProof.output c; None | Some (v, prf) -> if debug then ( - Printf.printf "This is a cutting plane for %a:" LinPoly.pp_var x; + Printf.printf "%s: This is a cutting plane for %a:" p LinPoly.pp_var x; Printf.printf " %a\n" WithProof.output (v, prf) ); - if snd v = Eq then (* Unsat *) Some (x, (v, prf)) - else - let vl = Vect.dotproduct (fst v) (Vect.set 0 (Int 1) sol) in - if eval_op Ge vl (Int 0) then ( - if debug then - Printf.printf "The cut is feasible %s >= 0 \n" - (Num.string_of_num vl); - None ) - else Some (x, (v, prf)) + Some (x, (v, prf)) in - match find_some check_cutting_plane lcut with + match check_cutting_plane lcut with | Some r -> Hit r - | None -> Keep (x, v) + | None -> + let has_unrestricted = + Vect.fold + (fun acc v vl -> acc || not (Restricted.is_restricted v rst)) + false r + in + if has_unrestricted then Keep (x, v) else Forget let merge_result_old oldr f x = match oldr with @@ -681,12 +743,16 @@ let integer_solver lp = isolve env None vr res let integer_solver lp = + nb_pivot := 0; if debug then Printf.printf "Input integer solver\n%a\n" WithProof.output_sys (List.map WithProof.of_cstr lp); match integer_solver lp with - | None -> None + | None -> + profile_info := (false, !nb_pivot) :: !profile_info; + None | Some prf -> + profile_info := (true, !nb_pivot) :: !profile_info; if debug then Printf.fprintf stdout "Proof %a\n" ProofFormat.output_proof prf; Some prf diff --git a/plugins/micromega/simplex.mli b/plugins/micromega/simplex.mli index 19bcce3590..ff672edafd 100644 --- a/plugins/micromega/simplex.mli +++ b/plugins/micromega/simplex.mli @@ -9,6 +9,20 @@ (************************************************************************) open Polynomial +(** Profiling *) + +type profile_info = + { number_of_successes : int + ; number_of_failures : int + ; success_pivots : int + ; failure_pivots : int + ; average_pivots : int + ; maximum_pivots : int } + +val get_profile_info : unit -> profile_info + +(** Simplex interface *) + val optimise : Vect.t -> cstr list -> (Num.num option * Num.num option) option val find_point : cstr list -> Vect.t option val find_unsat_certificate : cstr list -> Vect.t option diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index dcd85401d6..118db01ecb 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -67,7 +67,6 @@ open Goptions let () = declare_bool_option { optdepr = false; - optname = "Omega system time displaying flag"; optkey = ["Omega";"System"]; optread = read display_system_flag; optwrite = write display_system_flag } @@ -75,7 +74,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega action display flag"; optkey = ["Omega";"Action"]; optread = read display_action_flag; optwrite = write display_action_flag } @@ -83,7 +81,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega old style flag"; optkey = ["Omega";"OldStyle"]; optread = read old_style_flag; optwrite = write old_style_flag } @@ -91,7 +88,6 @@ let () = let () = declare_bool_option { optdepr = true; - optname = "Omega automatic reset of generated names"; optkey = ["Stable";"Omega"]; optread = read reset_flag; optwrite = write reset_flag } @@ -99,7 +95,6 @@ let () = let () = declare_bool_option { optdepr = false; - optname = "Omega takes advantage of context variables with body"; optkey = ["Omega";"UseLocalDefs"]; optread = read letin_flag; optwrite = write letin_flag } @@ -1713,7 +1708,6 @@ let onClearedName2 id tac = let destructure_hyps = Proofview.Goal.enter begin fun gl -> - let type_of = Tacmach.New.pf_unsafe_type_of gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let decidability = decidability env sigma in @@ -1759,7 +1753,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if Termops.is_Prop sigma (type_of t2) + if Termops.is_Prop sigma (Retyping.get_type_of env sigma t2) then let d1 = decidability t1 in tclTHENLIST [ diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 4cc32cfb26..ab34489de9 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -49,7 +49,6 @@ let pruning = ref true let opt_pruning= {optdepr=false; - optname="Rtauto Pruning"; optkey=["Rtauto";"Pruning"]; optread=(fun () -> !pruning); optwrite=(fun b -> pruning:=b)} diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 0c155c9d0a..b86c8d096c 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -227,7 +227,6 @@ let verbose = ref false let opt_verbose= {optdepr=false; - optname="Rtauto Verbose"; optkey=["Rtauto";"Verbose"]; optread=(fun () -> !verbose); optwrite=(fun b -> verbose:=b)} @@ -238,7 +237,6 @@ let check = ref false let opt_check= {optdepr=false; - optname="Rtauto Check"; optkey=["Rtauto";"Check"]; optread=(fun () -> !check); optwrite=(fun b -> check:=b)} diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index f7e4a95a22..3841501b6a 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -18,7 +18,6 @@ open EConstr open Vars open CClosure open Environ -open Globnames open Glob_term open Locus open Tacexpr @@ -43,12 +42,12 @@ type protection = Evd.evar_map -> EConstr.t -> GlobRef.t -> (Int.t -> protect_fl let global_head_of_constr sigma c = let f, args = decompose_app sigma c in - try fst (Termops.global_of_constr sigma f) - with Not_found -> CErrors.anomaly (str "global_head_of_constr.") + try fst (EConstr.destRef sigma f) + with DestKO -> CErrors.anomaly (str "global_head_of_constr.") let global_of_constr_nofail c = - try global_of_constr c - with Not_found -> GlobRef.VarRef (Id.of_string "dummy") + try fst @@ Constr.destRef c + with DestKO -> GlobRef.VarRef (Id.of_string "dummy") let rec mk_clos_but f_map n t = let (f, args) = Constr.decompose_appvect t in @@ -97,9 +96,9 @@ let protect_tac_in map id = let rec closed_under sigma cset t = try - let (gr, _) = Termops.global_of_constr sigma t in + let (gr, _) = destRef sigma t in GlobRef.Set_env.mem gr cset - with Not_found -> + with DestKO -> match EConstr.kind sigma t with | Cast(c,_,_) -> closed_under sigma cset c | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l @@ -758,22 +757,21 @@ let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = - let open Termops in let th_typ = Retyping.get_type_of env !evd th_spec in match EConstr.kind !evd th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global !evd (Lazy.force afield_theory) f -> + when isRefX !evd (Lazy.force afield_theory) f -> let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global !evd (Lazy.force field_theory) f -> + when isRefX !evd (Lazy.force field_theory) f -> let rth = plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when is_global !evd (Lazy.force sfield_theory) f -> + when isRefX !evd (Lazy.force sfield_theory) f -> let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index cdda84a18d..df001b6084 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -34,8 +34,7 @@ open Tacmach let ssroldreworder = Summary.ref ~name:"SSR:oldreworder" false let () = Goptions.(declare_bool_option - { optname = "ssreflect 1.3 compatibility flag"; - optkey = ["SsrOldRewriteGoalsOrder"]; + { optkey = ["SsrOldRewriteGoalsOrder"]; optread = (fun _ -> !ssroldreworder); optdepr = false; optwrite = (fun b -> ssroldreworder := b) }) diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index f486d1e457..235dfc257d 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -69,8 +69,7 @@ let ssrhaveNOtcresolution = Summary.ref ~name:"SSR:havenotcresolution" false let () = Goptions.(declare_bool_option - { optname = "have type classes"; - optkey = ["SsrHave";"NoTCResolution"]; + { optkey = ["SsrHave";"NoTCResolution"]; optread = (fun _ -> !ssrhaveNOtcresolution); optdepr = false; optwrite = (fun b -> ssrhaveNOtcresolution := b); diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 22325f3fc3..21b832a326 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -1662,8 +1662,7 @@ let ssr_reserved_ids = Summary.ref ~name:"SSR:idents" true let () = Goptions.(declare_bool_option - { optname = "ssreflect identifiers"; - optkey = ["SsrIdents"]; + { optkey = ["SsrIdents"]; optdepr = false; optread = (fun _ -> !ssr_reserved_ids); optwrite = (fun b -> ssr_reserved_ids := b) @@ -2395,8 +2394,7 @@ let ssr_rw_syntax = Summary.ref ~name:"SSR:rewrite" true let () = Goptions.(declare_bool_option - { optname = "ssreflect rewrite"; - optkey = ["SsrRewrite"]; + { optkey = ["SsrRewrite"]; optread = (fun _ -> !ssr_rw_syntax); optdepr = false; optwrite = (fun b -> ssr_rw_syntax := b) }) diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index f0aed1a934..22250202b5 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -134,8 +134,7 @@ let ppdebug_ref = ref (fun _ -> ()) let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) let () = Goptions.(declare_bool_option - { optname = "ssreflect debugging"; - optkey = ["Debug";"Ssreflect"]; + { optkey = ["Debug";"Ssreflect"]; optdepr = false; optread = (fun _ -> !ppdebug_ref == ssr_pp); optwrite = (fun b -> diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index d8dbf2f3dc..b212e7046a 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -151,7 +151,7 @@ let declare_one_prenex_implicit locality f = with _ -> errorstrm (pr_qualid f ++ str " is not declared") in let rec loop = function | a :: args' when Impargs.is_status_implicit a -> - Impargs.MaximallyImplicit :: loop args' + MaxImplicit :: loop args' | args' when List.exists Impargs.is_status_implicit args' -> errorstrm (str "Expected prenex implicits for " ++ pr_qualid f) | _ -> [] in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 6cb464918a..e45bae19ca 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -34,7 +34,6 @@ open Tacinterp open Pretyping open Ppconstr open Printer -open Globnames open Namegen open Evar_kinds open Constrexpr @@ -55,8 +54,7 @@ let debug b = if b then pp_ref := ssr_pp else pp_ref := fun _ -> () let _ = Goptions.declare_bool_option - { Goptions.optname = "ssrmatching debugging"; - Goptions.optkey = ["Debug";"SsrMatching"]; + { Goptions.optkey = ["Debug";"SsrMatching"]; Goptions.optdepr = false; Goptions.optread = (fun _ -> !pp_ref == ssr_pp); Goptions.optwrite = debug } @@ -464,7 +462,7 @@ let nb_cs_proj_args pc f u = | Sort s -> na (Sort_cs (Sorts.family s)) | Const (c',_) when Constant.equal c' pc -> nargs_of_proj u.up_f | Proj (c',_) when Constant.equal (Projection.constant c') pc -> nargs_of_proj u.up_f - | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) + | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (fst @@ destRef f)) | _ -> -1 with Not_found -> -1 diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 70c1077106..f6fbdaa958 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -164,7 +164,7 @@ let rawnum_of_r c = match DAst.get c with let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in let i = Bigint.to_string i in let se = if is_gr md glob_Rdiv then "-" else "" in - let e = se ^ Bigint.to_string e in + let e = "e" ^ se ^ Bigint.to_string e in s, { NumTok.int = i; frac = ""; exp = e } | _ -> raise Non_closed_number end |