diff options
Diffstat (limited to 'plugins')
34 files changed, 597 insertions, 503 deletions
diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 0c305d09e8..c485c38009 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -290,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 -> - try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> @@ -350,7 +349,6 @@ let rec proof_tac p : unit Proofview.tactic = app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Tacticals.New.tclTHEN injt (proof_tac prf)))) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end let refute_tac c t1 t2 p = @@ -508,11 +506,9 @@ let f_equal = let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = - try (* type_of can raise an exception *) Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) [Proofview.tclUNIT ();Tacticals.New.tclTRY ((app_global _refl_equal [||]) apply)] - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE begin match EConstr.kind sigma concl with diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index afc83b780b..0f96b9bbe8 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -259,7 +259,7 @@ let parse_ind_args si args relmax = let rec extract_type env sg db j c args = - match EConstr.kind sg (whd_betaiotazeta sg c) with + match EConstr.kind sg (whd_betaiotazeta env sg c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env sg db j d (Array.to_list args' @ args) @@ -380,7 +380,7 @@ and extract_type_app env sg db (r,s) args = and extract_type_scheme env sg db c p = if Int.equal p 0 then extract_type env sg db 0 c [] else - let c = whd_betaiotazeta sg c in + let c = whd_betaiotazeta env sg c in match EConstr.kind sg c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) sg db d (p-1) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 834e4251d3..f13901c36d 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -57,12 +57,12 @@ let make_simple_atoms seq= | None->[] in {negative=seq.latoms;positive=ratoms} -let do_sequent sigma setref triv id seq i dom atoms= +let do_sequent env sigma setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = let do_pair t1 t2 = - match unif_atoms sigma i dom t1 t2 with + match unif_atoms env sigma i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true | Some c ->flag:=false;setref:=IS.add (c,id) !setref in @@ -72,16 +72,16 @@ let do_sequent sigma setref triv id seq i dom atoms= do_atoms atoms (make_simple_atoms seq); !flag && !phref -let match_one_quantified_hyp sigma setref seq lf= +let match_one_quantified_hyp env sigma setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> - if do_sequent sigma setref triv lf.id seq i dom lf.atoms then + if do_sequent env sigma setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref | _ -> anomaly (Pp.str "can't happen.") -let give_instances sigma lf seq= +let give_instances env sigma lf seq= let setref=ref IS.empty in - List.iter (match_one_quantified_hyp sigma setref seq) lf; + List.iter (match_one_quantified_hyp env sigma setref seq) lf; IS.elements !setref (* collector for the engine *) @@ -129,9 +129,10 @@ let left_instance_tac (inst,id) continue seq= let open EConstr in Proofview.Goal.enter begin fun gl -> let sigma = project gl in + let env = Proofview.Goal.env gl in match inst with Phantom dom-> - if lookup sigma (id,None) seq then + if lookup env sigma (id,None) seq then tclFAIL 0 (Pp.str "already done") else tclTHENS (cut dom) @@ -148,7 +149,7 @@ let left_instance_tac (inst,id) continue seq= tclTRY assumption] | Real((m,t),_)-> let c = (m, EConstr.to_constr sigma t) in - if lookup sigma (id,Some c) seq then + if lookup env sigma (id,Some c) seq then tclFAIL 0 (Pp.str "already done") else let special_generalize= @@ -205,7 +206,8 @@ let instance_tac inst= let quantified_tac lf backtrack continue seq = Proofview.Goal.enter begin fun gl -> - let insts=give_instances (project gl) lf seq in + let env = Proofview.Goal.env gl in + let insts=give_instances env (project gl) lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) backtrack diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index c0f4c78ff3..08c2c4d916 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -13,7 +13,7 @@ open Rules val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t -val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> +val give_instances : Environ.env -> Evd.evar_map -> Formula.t list -> Sequent.t -> (Unify.instance * GlobRef.t) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 7bf13fd25b..3dd5059e5d 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -109,7 +109,7 @@ let deepen seq={seq with depth=seq.depth-1} let record item seq={seq with history=History.add item seq.history} -let lookup sigma item seq= +let lookup env sigma item seq= History.mem item seq.history || match item with (_,None)->false @@ -117,7 +117,7 @@ let lookup sigma item seq= let p (id2,o)= match o with None -> false - | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in + | Some (m2, t2)-> GlobRef.equal id id2 && m2>m && more_general env sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in History.exists p seq.history let add_formula env sigma side nam t seq = diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 3a5da6ad14..bba89c823c 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -39,7 +39,7 @@ val deepen: t -> t val record: h_item -> t -> t -val lookup: Evd.evar_map -> h_item -> t -> bool +val lookup: Environ.env -> Evd.evar_map -> h_item -> t -> bool val add_formula : Environ.env -> Evd.evar_map -> side -> GlobRef.t -> constr -> t -> t diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index e58e80116d..9c3debe48f 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -29,7 +29,7 @@ let subst_meta subst t = let subst = List.map (fun (m, c) -> (m, EConstr.Unsafe.to_constr c)) subst in EConstr.of_constr (subst_meta subst (EConstr.Unsafe.to_constr t)) -let unif evd t1 t2= +let unif env evd t1 t2= let bige=Queue.create () and sigma=ref [] in let bind i t= @@ -46,8 +46,8 @@ let unif evd t1 t2= Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta evd t1) - and nt2=head_reduce (whd_betaiotazeta evd t2) in + let nt1=head_reduce (whd_betaiotazeta env evd t1) + and nt2=head_reduce (whd_betaiotazeta env evd t2) in match (EConstr.kind evd nt1),(EConstr.kind evd nt2) with Meta i,Meta j-> if not (Int.equal i j) then @@ -123,9 +123,9 @@ let mk_rel_inst evd t= in let nt=renum_rec 0 t in (!new_rel - 1,nt) -let unif_atoms evd i dom t1 t2= +let unif_atoms env evd i dom t1 t2= try - let t=Int.List.assoc i (unif evd t1 t2) in + let t=Int.List.assoc i (unif env evd t1 t2) in if isMeta evd t then Some (Phantom dom) else Some (Real(mk_rel_inst evd t,value evd i t1)) with @@ -136,11 +136,11 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=List.init n (fun i->mkMeta (k+i)) in substl l t -let more_general evd (m1,t1) (m2,t2)= +let more_general env evd (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in try - let sigma=unif evd mt1 mt2 in + let sigma=unif env evd mt1 mt2 in let p (n,t)= n<m1 || isMeta evd t in List.for_all p sigma with UFAIL(_,_)->false diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 71e786eb90..c6767f04ac 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -13,12 +13,12 @@ open EConstr exception UFAIL of constr*constr -val unif : Evd.evar_map -> constr -> constr -> (int*constr) list +val unif : Environ.env -> Evd.evar_map -> constr -> constr -> (int*constr) list type instance= Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) | Phantom of constr (* domaine de quantification *) -val unif_atoms : Evd.evar_map -> metavariable -> constr -> constr -> constr -> instance option +val unif_atoms : Environ.env -> Evd.evar_map -> metavariable -> constr -> constr -> constr -> instance option -val more_general : Evd.evar_map -> (int*constr) -> (int*constr) -> bool +val more_general : Environ.env -> Evd.evar_map -> (int*constr) -> (int*constr) -> bool diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f4200854c2..b864b18887 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -116,7 +116,7 @@ let prove_trivial_eq h_id context (constructor, type_of_term, term) = refine to_refine g) ] let find_rectype env sigma c = - let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta env sigma c) in match EConstr.kind sigma t with | Ind ind -> (t, l) | Construct _ -> (t, l) @@ -243,19 +243,25 @@ let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = let new_ctxt, new_end_of_type = decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in - let prove_new_hyp : tactic = - tclTHEN - (tclDO ctxt_size (Proofview.V82.of_tactic intro)) - (fun g -> - let all_ids = pf_ids_of_hyps g in - let new_ids, _ = list_chop ctxt_size all_ids in - let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in - tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g) + let prove_new_hyp = + let open Tacticals.New in + let open Tacmach.New in + tclTHEN (tclDO ctxt_size intro) + (Proofview.Goal.enter (fun g -> + let all_ids = pf_ids_of_hyps g in + let new_ids, _ = list_chop ctxt_size all_ids in + let to_refine = applist (witness_fun, List.rev_map mkVar new_ids) in + let evm, _ = + Typing.type_of (Proofview.Goal.env g) (Proofview.Goal.sigma g) + to_refine + in + tclTHEN + (Proofview.Unsafe.tclEVARS evm) + (Proofview.V82.tactic (refine to_refine)))) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp - prove_new_hyp + (Proofview.V82.of_tactic prove_new_hyp) in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) @@ -534,11 +540,13 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = let prov_hid = pf_get_new_id hid g in let c = mkApp (mkVar hid, args) in let evm, _ = pf_apply Typing.type_of g c in - tclTHENLIST - [ Refiner.tclEVARS evm - ; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c) - ; thin [hid] - ; Proofview.V82.of_tactic (rename_hyp [(prov_hid, hid)]) ] + let open Tacticals.New in + Proofview.V82.of_tactic + (tclTHENLIST + [ Proofview.Unsafe.tclEVARS evm + ; pose_proof (Name prov_hid) c + ; clear [hid] + ; rename_hyp [(prov_hid, hid)] ]) g) (fun (* if not then we are in a mutual function block diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 55e659d487..608155eb71 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -159,7 +159,7 @@ let recompute_binder_list fixpoint_exprl = fixpoint_exprl in let (_, _, _, typel), _, ctx, _ = - ComFixpoint.interp_fixpoint ~cofix:false fixl + ComFixpoint.interp_fixpoint ~check_recursivity:false ~cofix:false fixl in let constr_expr_typel = with_full_print @@ -191,61 +191,35 @@ let prepare_body {Vernacexpr.binders} rt = let fun_args, rt' = chop_rlambda_n n rt in (fun_args, rt') -let build_functional_principle ?(opaque = Declare.Transparent) - (evd : Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = +let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs + _i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = - (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)) + (Tactics.compute_elim_sig sigma (EConstr.of_constr old_princ_type)) .Tactics.nparams in - (* let time1 = System.get_time () in *) let new_principle_type = Functional_principles_types.compute_new_princ_type_from_rel (Array.map Constr.mkConstU funs) sorts old_princ_type in - (* let time2 = System.get_time () in *) - (* Pp.msgnl (str "computing principle type := " ++ System.fmt_time_difference time1 time2); *) - let new_princ_name = - Namegen.next_ident_away_in_goal - (Id.of_string "___________princ_________") - Id.Set.empty - in let sigma, _ = - Typing.type_of ~refresh:true (Global.env ()) !evd + Typing.type_of ~refresh:true (Global.env ()) sigma (EConstr.of_constr new_principle_type) in - evd := sigma; - let hook = DeclareDef.Hook.make (hook new_principle_type) in - let lemma = - Lemmas.start_lemma ~name:new_princ_name ~poly:false !evd - (EConstr.of_constr new_principle_type) - in - (* let _tim1 = System.get_time () in *) let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let lemma, _ = - Lemmas.by - (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams)) - lemma + let ftac = + Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams) in - (* let _tim2 = System.get_time () in *) - (* begin *) - (* let dur1 = System.time_difference tim1 tim2 in *) - (* Pp.msgnl (str ("Time to compute proof: ") ++ str (string_of_float dur1)); *) - (* end; *) - let {Declare.entries} = - Lemmas.pf_fold - (Declare.close_proof ~opaque ~keep_body_ucst_separate:false) - lemma + let env = Global.env () in + let uctx = Evd.evar_universe_context sigma in + let typ = EConstr.of_constr new_principle_type in + let body, typ, univs, _safe, _uctx = + Declare.build_by_tactic env ~uctx ~poly:false ~typ ftac in - match entries with - | [entry] -> (entry, hook) - | _ -> - CErrors.anomaly - Pp.( - str - "[build_functional_principle] close_proof returned more than one \ - proof term") + (* uctx was ignored before *) + let hook = Declare.Hook.make (hook new_principle_type) in + (body, typ, univs, hook, sigma) let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in @@ -333,17 +307,19 @@ let generate_functional_principle (evd : Evd.evar_map ref) old_princ_type sorts register_with_sort Sorts.InProp; register_with_sort Sorts.InSet ) in - let entry, hook = - build_functional_principle evd old_princ_type new_sorts funs i proof_tac + let body, types, univs, hook, sigma0 = + build_functional_principle !evd old_princ_type new_sorts funs i proof_tac hook in + evd := sigma0; (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in + let entry = Declare.definition_entry ~univs ?types body in let (_ : Names.GlobRef.t) = - DeclareDef.declare_entry ~name:new_princ_name ~hook - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + Declare.declare_entry ~name:new_princ_name ~hook + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~kind:Decls.(IsProof Theorem) ~impargs:[] ~uctx entry in @@ -424,7 +400,7 @@ let register_struct is_rec fixpoint_exprl = Pp.(str "Body of Function must be given") in ComDefinition.do_definition ~name:fname.CAst.v ~poly:false - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~kind:Decls.Definition univs binders None body (Some rtype); let evd, rev_pconstants = List.fold_left @@ -443,7 +419,7 @@ let register_struct is_rec fixpoint_exprl = (None, evd, List.rev rev_pconstants) | _ -> ComFixpoint.do_fixpoint - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly:false + ~scope:(Declare.Global Declare.ImportDefaultBehavior) ~poly:false fixpoint_exprl; let evd, rev_pconstants = List.fold_left @@ -1334,8 +1310,7 @@ let get_funs_constant mp = in l_const -let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : - Evd.side_effects Declare.proof_entry list = +let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : _ list = let exception Found_type of int in let env = Global.env () in let funs = List.map fst fas in @@ -1402,18 +1377,19 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : if Declareops.is_opaque (Global.lookup_constant equation) then Opaque else Transparent in - let entry, _hook = + let body, typ, univs, _hook, sigma0 = try - build_functional_principle ~opaque evd first_type (Array.of_list sorts) + build_functional_principle !evd first_type (Array.of_list sorts) this_block_funs 0 (Functional_principles_proofs.prove_princ_for_struct evd false 0 (Array.of_list (List.map fst funs))) (fun _ _ -> ()) with e when CErrors.noncritical e -> raise (Defining_principle e) in + evd := sigma0; incr i; (* The others are just deduced *) - if List.is_empty other_princ_types then [entry] + if List.is_empty other_princ_types then [(body, typ, univs, opaque)] else let other_fun_princ_types = let funs = Array.map Constr.mkConstU this_block_funs in @@ -1422,10 +1398,8 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body = entry.Declare.proof_entry_body in - let ctxt, fix = - Term.decompose_lam_assum (fst (fst (Future.force first_princ_body))) - in + let first_princ_body = body in + let ctxt, fix = Term.decompose_lam_assum first_princ_body in (* the principle has for forall ...., fix .*) let (idxs, _), ((_, ta, _) as decl) = Constr.destFix fix in let other_result = @@ -1457,8 +1431,8 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (* If we reach this point, the two principle are not mutually recursive We fall back to the previous method *) - let entry, _hook = - build_functional_principle evd + let body, typ, univs, _hook, sigma0 = + build_functional_principle !evd (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs !i (Functional_principles_proofs.prove_princ_for_struct evd false @@ -1466,15 +1440,16 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : (Array.of_list (List.map fst funs))) (fun _ _ -> ()) in - entry + evd := sigma0; + (body, typ, univs, opaque) with Found_type i -> let princ_body = Termops.it_mkLambda_or_LetIn (Constr.mkFix ((idxs, i), decl)) ctxt in - Declare.definition_entry ~types:scheme_type princ_body) + (princ_body, Some scheme_type, univs, opaque)) other_fun_princ_types in - entry :: other_result + (body, typ, univs, opaque) :: other_result (* [derive_correctness funs graphs] create correctness and completeness lemmas for each function in [funs] w.r.t. [graphs] @@ -1527,11 +1502,8 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) with Not_found -> Array.of_list (List.map - (fun entry -> - ( EConstr.of_constr - (fst (fst (Future.force entry.Declare.proof_entry_body))) - , EConstr.of_constr (Option.get entry.Declare.proof_entry_type) - )) + (fun (body, typ, _opaque, _univs) -> + (EConstr.of_constr body, EConstr.of_constr (Option.get typ))) (make_scheme evd (Array.map_to_list (fun const -> (const, Sorts.InType)) funs))) in @@ -2225,11 +2197,14 @@ let build_scheme fas = in let bodies_types = make_scheme evd pconstants in List.iter2 - (fun (princ_id, _, _) def_entry -> - ignore - (Declare.declare_constant ~name:princ_id - ~kind:Decls.(IsProof Theorem) - (Declare.DefinitionEntry def_entry)); + (fun (princ_id, _, _) (body, types, univs, opaque) -> + let (_ : Constant.t) = + let opaque = if opaque = Declare.Opaque then true else false in + let def_entry = Declare.definition_entry ~univs ~opaque ?types body in + Declare.declare_constant ~name:princ_id + ~kind:Decls.(IsProof Theorem) + (Declare.DefinitionEntry def_entry) + in Declare.definition_message princ_id) fas bodies_types diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index e83fe56cc9..af53f16e1f 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -2,7 +2,7 @@ open Names open Pp open Constr open Libnames -open Refiner +open Tacmach let mk_prefix pre id = Id.of_string (pre ^ Id.to_string id) let mk_rel_id = mk_prefix "R_" @@ -395,7 +395,8 @@ let jmeq_refl () = 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 + Proofview.V82.of_tactic + (Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l) let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" @@ -427,15 +428,16 @@ let evaluable_of_global_reference r = | _ -> assert false let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = - tclREPEAT - (List.fold_right - (fun (eq, b) i -> - tclORELSE - (Proofview.V82.of_tactic - ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) - i) - (if rev then List.rev eqs else eqs) - (tclFAIL 0 (mt ()))) + let open Tacticals in + (tclREPEAT + (List.fold_right + (fun (eq, b) i -> + tclORELSE + (Proofview.V82.of_tactic + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + i) + (if rev then List.rev eqs else eqs) + (tclFAIL 0 (mt ()))) [@ocaml.warning "-3"]) let decompose_lam_n sigma n = if n < 0 then diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index ffb9a7e69b..9b2d9c4815 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -703,9 +703,16 @@ let terminate_letin (na, b, t, e) expr_info continuation_tac info g = in continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g -let pf_type c tac gl = - let evars, ty = Typing.type_of (pf_env gl) (project gl) c in - tclTHEN (Refiner.tclEVARS evars) (tac ty) gl +let pf_type c tac = + let open Tacticals.New in + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let evars, ty = Typing.type_of env sigma c in + tclTHEN (Proofview.Unsafe.tclEVARS evars) (tac ty)) + +let pf_type c tac = + Proofview.V82.of_tactic (pf_type c (fun ty -> Proofview.V82.tactic (tac ty))) let pf_typel l tac = let rec aux tys l = @@ -1483,7 +1490,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in - let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in + let info = Lemmas.Info.make ~hook:(Declare.Hook.make hook) () in let lemma = Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info sigma gls_type in @@ -1721,7 +1728,7 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls let tcc_lemma_name = add_suffix function_name "_tcc" in let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (fun _ _ -> str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) - let hook {DeclareDef.Hook.S.uctx; _} = + let hook {Declare.Hook.S.uctx; _} = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name Decls.(IsProof Lemma) arg_types term_ref @@ -1767,5 +1774,5 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls functional_ref (EConstr.of_constr rec_arg_type) relation rec_arg_num term_id using_lemmas (List.length res_vars) evd - (DeclareDef.Hook.make hook)) + (Declare.Hook.make hook)) () diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index 17a7121a3f..f867a47c08 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -14,10 +14,7 @@ open Constr open Context open CErrors open Evar_refiner -open Tacmach open Tacexpr -open Refiner -open Evd open Locus open Context.Named.Declaration open Ltac_pretype @@ -26,7 +23,11 @@ module NamedDecl = Context.Named.Declaration (* The instantiate tactic *) -let instantiate_evar evk (ist,rawc) env sigma = +let instantiate_evar evk (ist,rawc) = + let open Proofview.Notations in + Proofview.tclENV >>= fun env -> + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let evi = Evd.find sigma evk in let filtered = Evd.evar_filtered_env env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in @@ -37,7 +38,8 @@ let instantiate_evar evk (ist,rawc) env sigma = ltac_genargs = ist.Geninterp.lfun; } in let sigma' = w_refine (evk,evi) (lvar ,rawc) env sigma in - tclEVARS sigma' + Proofview.Unsafe.tclEVARS sigma' + end let evar_list sigma c = let rec evrec acc c = @@ -47,14 +49,15 @@ let evar_list sigma c = evrec [] c let instantiate_tac n c ido = - Proofview.V82.tactic begin fun gl -> - let env = Global.env () in - let sigma = gl.sigma in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in let evl = match ido with - ConclLocation () -> evar_list sigma (pf_concl gl) + ConclLocation () -> evar_list sigma concl | HypLocation (id,hloc) -> - let decl = Environ.lookup_named id (pf_env gl) in + let decl = Environ.lookup_named id env in match hloc with InHyp -> (match decl with @@ -70,17 +73,16 @@ let instantiate_tac n c ido = user_err Pp.(str "Not enough uninstantiated existential variables."); if n <= 0 then user_err Pp.(str "Incorrect existential variable index."); let evk,_ = List.nth evl (n-1) in - instantiate_evar evk c env sigma gl + instantiate_evar evk c end let instantiate_tac_by_name id c = - Proofview.V82.tactic begin fun gl -> - let env = Global.env () in - let sigma = gl.sigma in + Proofview.Goal.enter begin fun gl -> + let sigma = Proofview.Goal.sigma gl in let evk = try Evd.evar_key id sigma with Not_found -> user_err Pp.(str "Unknown existential variable.") in - instantiate_evar evk c env sigma gl + instantiate_evar evk c end let let_evar name typ = diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index c4731e5c34..eb53fd45d0 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -31,6 +31,8 @@ let create_generic_quotation name e wit = let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string +let () = create_generic_quotation "smart_global" Pcoq.Prim.smart_global Stdarg.wit_smart_global + let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr @@ -342,3 +344,55 @@ let pr_lpar_id_colon _ _ _ _ = mt () ARGUMENT EXTEND test_lpar_id_colon TYPED AS unit PRINTED BY { pr_lpar_id_colon } | [ local_test_lpar_id_colon(x) ] -> { () } END + +{ + +(* Work around a limitation of the macro system *) +let strategy_level0 = Pcoq.Prim.strategy_level + +let pr_strategy _ _ _ v = Conv_oracle.pr_level v + +} + +ARGUMENT EXTEND strategy_level PRINTED BY { pr_strategy } +| [ strategy_level0(n) ] -> { n } +END + +{ + +let intern_strategy ist v = match v with +| ArgVar id -> ArgVar (Tacintern.intern_hyp ist id) +| ArgArg v -> ArgArg v + +let subst_strategy _ v = v + +let interp_strategy ist gl = function +| ArgArg n -> gl.Evd.sigma, n +| ArgVar { CAst.v = id; CAst.loc } -> + let v = + try Id.Map.find id ist.lfun + with Not_found -> + CErrors.user_err ?loc + (str "Unbound variable " ++ Id.print id ++ str".") + in + let v = + try Tacinterp.Value.cast (Genarg.topwit wit_strategy_level) v + with CErrors.UserError _ -> Taccoerce.error_ltac_variable ?loc id None v "a strategy_level" + in + gl.Evd.sigma, v + +let pr_loc_strategy _ _ _ v = Pputils.pr_or_var Conv_oracle.pr_level v + +} + +ARGUMENT EXTEND strategy_level_or_var + TYPED AS strategy_level + PRINTED BY { pr_strategy } + INTERPRETED BY { interp_strategy } + GLOBALIZED BY { intern_strategy } + SUBSTITUTED BY { subst_strategy } + RAW_PRINTED BY { pr_loc_strategy } + GLOB_PRINTED BY { pr_loc_strategy } +| [ strategy_level(n) ] -> { ArgArg n } +| [ identref(id) ] -> { ArgVar id } +END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli index fbdb7c0032..e52bf55f71 100644 --- a/plugins/ltac/extraargs.mli +++ b/plugins/ltac/extraargs.mli @@ -78,3 +78,7 @@ val wit_in_clause : (lident Locus.clause_expr, lident Locus.clause_expr, Id.t Locus.clause_expr) Genarg.genarg_type + +val wit_strategy_level : Conv_oracle.level Genarg.uniform_genarg_type + +val wit_strategy_level_or_var : (Conv_oracle.level Locus.or_var, Conv_oracle.level Locus.or_var, Conv_oracle.level) Genarg.genarg_type diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 0bad3cbe5b..ffb597d4cb 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -1119,3 +1119,11 @@ let tclOPTIMIZE_HEAP = TACTIC EXTEND optimize_heap | [ "optimize_heap" ] -> { tclOPTIMIZE_HEAP } END + +(** Tactic analogous to [Strategy] vernacular *) + +TACTIC EXTEND with_strategy +| [ "with_strategy" strategy_level_or_var(v) "[" ne_smart_global_list(q) "]" tactic3(tac) ] -> { + with_set_strategy [(v, q)] (Tacinterp.tactic_of_value ist tac) +} +END diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 0f0341f123..81e745b714 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -54,16 +54,23 @@ END { +let pr_search_strategy_name _prc _prlc _prt = function + | Dfs -> Pp.str "dfs" + | Bfs -> Pp.str "bfs" + let pr_search_strategy _prc _prlc _prt = function - | Some Dfs -> Pp.str "dfs" - | Some Bfs -> Pp.str "bfs" + | Some s -> pr_search_strategy_name _prc _prlc _prt s | None -> Pp.mt () } +ARGUMENT EXTEND eauto_search_strategy_name PRINTED BY { pr_search_strategy_name } +| [ "bfs" ] -> { Bfs } +| [ "dfs" ] -> { Dfs } +END + ARGUMENT EXTEND eauto_search_strategy PRINTED BY { pr_search_strategy } -| [ "(bfs)" ] -> { Some Bfs } -| [ "(dfs)" ] -> { Some Dfs } +| [ "(" eauto_search_strategy_name(s) ")" ] -> { Some s } | [ ] -> { None } END diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 5baa23b3e9..0e661543db 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -216,8 +216,8 @@ GRAMMAR EXTEND Gram ; match_key: [ [ "match" -> { Once } - | "lazymatch" -> { Select } - | "multimatch" -> { General } ] ] + | IDENT "lazymatch" -> { Select } + | IDENT "multimatch" -> { General } ] ] ; input_fun: [ [ "_" -> { Name.Anonymous } @@ -342,7 +342,7 @@ GRAMMAR EXTEND Gram hint: [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; tac = Pltac.tactic -> - { ComHints.HintsExtern (n,c, in_tac tac) } ] ] + { Vernacexpr.HintsExtern (n,c, in_tac tac) } ] ] ; operconstr: LEVEL "0" [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 6a158bde17..e51b1f051d 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -30,9 +30,6 @@ open Pcoq let all_with delta = Redops.make_red_flag [FBeta;FMatch;FFix;FCofix;FZeta;delta] -let tactic_kw = [ "->"; "<-" ; "by" ] -let _ = List.iter CLexer.add_keyword tactic_kw - let err () = raise Stream.Failure (* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 09f1fc371a..d74e981c6d 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -1325,6 +1325,8 @@ let () = register_basic_print0 wit_int_or_var (pr_or_var int) (pr_or_var int) int; register_basic_print0 wit_ref pr_qualid (pr_or_var (pr_located pr_global)) pr_global; + register_basic_print0 wit_smart_global + (pr_or_by_notation pr_qualid) (pr_or_var (pr_located pr_global)) pr_global; register_basic_print0 wit_ident pr_id pr_id pr_id; register_basic_print0 wit_var pr_lident pr_lident pr_id; register_print0 wit_intropattern pr_raw_intro_pattern pr_glob_intro_pattern pr_intro_pattern_env [@warning "-3"]; diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 3834b21a14..d6b2a17882 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -478,7 +478,7 @@ let error_no_relation () = user_err Pp.(str "Cannot find a relation to rewrite." let rec decompose_app_rel env evd t = (* Head normalize for compatibility with the old meta mechanism *) - let t = Reductionops.whd_betaiota evd t in + let t = Reductionops.whd_betaiota env evd t in match EConstr.kind evd t with | App (f, [||]) -> assert false | App (f, [|arg|]) -> @@ -711,7 +711,7 @@ let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) ~fail:true env sigma in let evd = solve_remaining_by env sigma holes by in - let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta evd c) in + let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta env evd c) in let c1 = nf c1 and c2 = nf c2 and rew_car = nf car and rel = nf rel and prf = nf prf in @@ -971,7 +971,7 @@ let unfold_match env sigma sk app = | App (f', args) when Constant.equal (fst (destConst sigma f')) sk -> let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in let v = EConstr.of_constr v in - Reductionops.whd_beta sigma (mkApp (v, args)) + Reductionops.whd_beta env sigma (mkApp (v, args)) | _ -> app let is_rew_cast = function RewCast _ -> true | _ -> false @@ -1894,10 +1894,10 @@ let declare_projection name instance_id r = in it_mkProd_or_LetIn ccl ctx in let types = Some (it_mkProd_or_LetIn typ ctx) in - let kind, opaque, scope = Decls.(IsDefinition Definition), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let kind, opaque, scope = Decls.(IsDefinition Definition), false, Declare.Global Declare.ImportDefaultBehavior in let impargs, udecl = [], UState.default_univ_decl in let _r : GlobRef.t = - DeclareDef.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma + Declare.declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ~poly ~types ~body sigma in () let build_morphism_signature env sigma m = @@ -1961,10 +1961,10 @@ let add_morphism_as_parameter atts m n : unit = let env = Global.env () in let evd = Evd.from_env env in let poly = atts.polymorphic in - let kind, opaque, scope = Decls.(IsAssumption Logical), false, DeclareDef.Global Declare.ImportDefaultBehavior in + let kind, opaque, scope = Decls.(IsAssumption Logical), false, Declare.Global Declare.ImportDefaultBehavior in let impargs, udecl = [], UState.default_univ_decl in let evd, types = build_morphism_signature env evd m in - let evd, pe = DeclareDef.prepare_parameter ~poly ~udecl ~types evd in + let evd, pe = Declare.prepare_parameter ~poly ~udecl ~types evd in let cst = Declare.declare_constant ~name:instance_id ~kind (Declare.ParameterEntry pe) in let cst = GlobRef.ConstRef cst in Classes.add_instance @@ -1981,7 +1981,7 @@ let add_morphism_interactive atts m n : Lemmas.t = let poly = atts.polymorphic in let kind = Decls.(IsDefinition Instance) in let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in - let hook { DeclareDef.Hook.S.dref; _ } = dref |> function + let hook { Declare.Hook.S.dref; _ } = dref |> function | GlobRef.ConstRef cst -> Classes.add_instance (Classes.mk_instance (PropGlobal.proper_class env evd) Hints.empty_hint_info @@ -1989,7 +1989,7 @@ let add_morphism_interactive atts m n : Lemmas.t = declare_projection n instance_id (GlobRef.ConstRef cst) | _ -> assert false in - let hook = DeclareDef.Hook.make hook in + let hook = Declare.Hook.make hook in let info = Lemmas.Info.make ~hook ~kind () in Flags.silently (fun () -> diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 04d85ed390..91d26519b8 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -293,6 +293,13 @@ let coerce_to_evaluable_ref env sigma v = | VarRef var -> EvalVarRef var | ConstRef c -> EvalConstRef c | IndRef _ | ConstructRef _ -> fail () + else if has_type v (topwit wit_smart_global) then + let open GlobRef in + let r = out_gen (topwit wit_smart_global) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () else match Value.to_constr v with | Some c when isConst sigma c -> EvalConstRef (fst (destConst sigma c)) diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 9910796d9c..e6c59f446d 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -683,6 +683,111 @@ let tactic_extend plugin_name tacname ~level ?deprecation sign = Tacenv.register_ml_tactic ml_tactic_name @@ Array.of_list (List.map eval sign); Mltop.declare_cache_obj obj plugin_name +type (_, 'a) ml_ty_sig = +| MLTyNil : ('a, 'a) ml_ty_sig +| MLTyArg : ('r, 'a) ml_ty_sig -> (Geninterp.Val.t -> 'r, 'a) ml_ty_sig + +let rec ml_sig_len : type r a. (r, a) ml_ty_sig -> int = function +| MLTyNil -> 0 +| MLTyArg sign -> 1 + ml_sig_len sign + +let rec cast_ml : type r a. (r, a) ml_ty_sig -> r -> Geninterp.Val.t list -> a = + fun sign f -> + match sign with + | MLTyNil -> + begin function + | [] -> f + | _ :: _ -> CErrors.anomaly (str "Arity mismatch") + end + | MLTyArg sign -> + function + | [] -> CErrors.anomaly (str "Arity mismatch") + | arg :: args -> cast_ml sign (f arg) args + +let ml_tactic_extend ~plugin ~name ~local ?deprecation sign tac = + let open Tacexpr in + let tac args _ = cast_ml sign tac args in + let ml_tactic_name = { mltac_tactic = name; mltac_plugin = plugin } in + let ml = { mltac_name = ml_tactic_name; mltac_index = 0 } in + let len = ml_sig_len sign in + let args = List.init len (fun i -> Id.of_string (Printf.sprintf "arg%i" i)) in + let vars = List.map (fun id -> Name id) args in + let args = List.map (fun id -> Reference (Locus.ArgVar (CAst.make id))) args in + let body = Tacexpr.TacFun (vars, Tacexpr.TacML (CAst.make (ml, args))) in + let id = Names.Id.of_string name in + let obj () = Tacenv.register_ltac true local id body ?deprecation in + let () = Tacenv.register_ml_tactic ml_tactic_name [|tac|] in + Mltop.declare_cache_obj obj plugin + +module MLName = +struct + open Tacexpr + type t = ml_tactic_name + let compare tac1 tac2 = + let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in + if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin + else c +end + +module MLTacMap = Map.Make(MLName) + +let ml_table : (Geninterp.Val.t list -> Geninterp.Val.t Ftactic.t) MLTacMap.t ref = ref MLTacMap.empty + +type ml_ltac_val = { + tacval_tac : Tacexpr.ml_tactic_name; + tacval_var : Id.t list; +} + +let in_tacval = +(* This is a hack to emulate value-returning ML-implemented tactics in Ltac. + We use a dummy generic argument to work around the limitations of the Ltac + runtime. Indeed, the TacML node needs to return unit values, since it is + considered a "tactic" in the runtime. Changing it to allow arbitrary values + would require to toggle this status, and thus to make it a "value" node. + This would in turn create too much backwards incompatibility. Instead, we + piggy back on the TacGeneric node, which by construction is used to return + values. + + The trick is to represent a n-ary application of a ML function as a generic + argument. We store in the node the name of the tactic and its arity, while + giving canonical names to the bound variables of the closure. This trick is + already performed in several external developments for specific calls, we + make it here generic. The argument should not be used for other purposes, so + we only export the registering functions. + *) + let wit : (Empty.t, ml_ltac_val, Geninterp.Val.t) Genarg.genarg_type = + Genarg.create_arg "ltac:val" + in + (* No need to internalize this ever *) + let intern_fun _ e = Empty.abort e in + let subst_fun s v = v in + let () = Genintern.register_intern0 wit intern_fun in + let () = Genintern.register_subst0 wit subst_fun in + (* No need to register a value tag for it via register_val0 since we will + never access this genarg directly. *) + let interp_fun ist tac = + let args = List.map (fun id -> Id.Map.get id ist.Geninterp.lfun) tac.tacval_var in + let tac = MLTacMap.get tac.tacval_tac !ml_table in + tac args + in + let () = Geninterp.register_interp0 wit interp_fun in + (fun v -> Genarg.in_gen (Genarg.Glbwit wit) v) + + +let ml_val_tactic_extend ~plugin ~name ~local ?deprecation sign tac = + let open Tacexpr in + let tac args = cast_ml sign tac args in + let ml_tactic_name = { mltac_tactic = name; mltac_plugin = plugin } in + let len = ml_sig_len sign in + let vars = List.init len (fun i -> Id.of_string (Printf.sprintf "arg%i" i)) in + let body = TacGeneric (in_tacval { tacval_tac = ml_tactic_name; tacval_var = vars }) in + let vars = List.map (fun id -> Name id) vars in + let body = Tacexpr.TacFun (vars, Tacexpr.TacArg (CAst.make body)) in + let id = Names.Id.of_string name in + let obj () = Tacenv.register_ltac true local id body ?deprecation in + let () = assert (not @@ MLTacMap.mem ml_tactic_name !ml_table) in + let () = ml_table := MLTacMap.add ml_tactic_name tac !ml_table in + Mltop.declare_cache_obj obj plugin (** ARGUMENT EXTEND *) diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli index ce38431a18..6ee3ce091b 100644 --- a/plugins/ltac/tacentries.mli +++ b/plugins/ltac/tacentries.mli @@ -69,6 +69,25 @@ val print_ltacs : unit -> unit val print_located_tactic : Libnames.qualid -> unit (** Display the absolute name of a tactic. *) +(** {5 Low-level registering of tactics} *) + +type (_, 'a) ml_ty_sig = +| MLTyNil : ('a, 'a) ml_ty_sig +| MLTyArg : ('r, 'a) ml_ty_sig -> (Geninterp.Val.t -> 'r, 'a) ml_ty_sig + +val ml_tactic_extend : plugin:string -> name:string -> local:locality_flag -> + ?deprecation:Deprecation.t -> ('r, unit Proofview.tactic) ml_ty_sig -> 'r -> unit +(** Helper function to define directly an Ltac function in OCaml without any + associated parsing rule nor further shenanigans. The Ltac function will be + defined as [name] in the Coq file that loads the ML plugin where this + function is called. It will have the arity given by the [ml_ty_sig] + argument. *) + +val ml_val_tactic_extend : plugin:string -> name:string -> local:locality_flag -> + ?deprecation:Deprecation.t -> ('r, Geninterp.Val.t Ftactic.t) ml_ty_sig -> 'r -> unit +(** Same as {!ml_tactic_extend} but the function can return an argument + instead. *) + (** {5 TACTIC EXTEND} *) type _ ty_sig = diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index 597c3fdaac..53dc518bd3 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -14,7 +14,6 @@ open CAst open Pattern open Genredexpr open Glob_term -open Tacred open Util open Names open Libnames @@ -95,9 +94,16 @@ let intern_string_or_var = intern_or_var (fun (s : string) -> s) let intern_global_reference ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) - else - try ArgArg (qid.CAst.loc,locate_global_with_alias qid) - with Not_found -> Nametab.error_global_not_found qid + else if qualid_is_ident qid && find_hyp (qualid_basename qid) ist then + let id = qualid_basename qid in + ArgArg (qid.CAst.loc, GlobRef.VarRef id) + else match locate_global_with_alias ~head:true qid with + | r -> ArgArg (qid.CAst.loc, r) + | exception Not_found -> + if not !strict_check && qualid_is_ident qid then + let id = qualid_basename qid in + ArgArg (qid.CAst.loc, GlobRef.VarRef id) + else Nametab.error_global_not_found qid let intern_ltac_variable ist qid = if qualid_is_ident qid && find_var (qualid_basename qid) ist then @@ -287,38 +293,42 @@ let intern_destruction_arg ist = function else clear,ElimOnIdent (make ?loc id) -let short_name = function - | {v=AN qid} when qualid_is_ident qid && not !strict_check -> +let short_name qid = + if qualid_is_ident qid && not !strict_check then Some (make ?loc:qid.CAst.loc @@ qualid_basename qid) - | _ -> None - -let intern_evaluable_global_reference ist qid = - try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true qid) - with Not_found -> - if qualid_is_ident qid && not !strict_check then EvalVarRef (qualid_basename qid) - else Nametab.error_global_not_found qid + else None + +let evalref_of_globref ?loc ?short = function + | GlobRef.ConstRef cst -> ArgArg (EvalConstRef cst, short) + | GlobRef.VarRef id -> ArgArg (EvalVarRef id, short) + | r -> + let tpe = match r with + | GlobRef.IndRef _ -> "inductive" + | GlobRef.ConstructRef _ -> "constructor" + | (GlobRef.VarRef _ | GlobRef.ConstRef _) -> assert false + in + user_err ?loc (str "Cannot turn" ++ spc () ++ str tpe ++ spc () ++ + Nametab.pr_global_env Id.Set.empty r ++ spc () ++ + str "into an evaluable reference.") + +let intern_evaluable ist = function + | {v=AN qid} -> + begin match intern_global_reference ist qid with + | ArgVar _ as v -> v + | ArgArg (loc, r) -> + let short = short_name qid in + evalref_of_globref ?loc ?short r + end + | {v=ByNotation (ntn,sc);loc} -> + let check = GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) in + let r = Notation.interp_notation_as_global_reference ?loc ~head:true check ntn sc in + evalref_of_globref ?loc r -let intern_evaluable_reference_or_by_notation ist = function - | {v=AN r} -> intern_evaluable_global_reference ist r +let intern_smart_global ist = function + | {v=AN r} -> intern_global_reference ist r | {v=ByNotation (ntn,sc);loc} -> - evaluable_of_global_reference ist.genv - (Notation.interp_notation_as_global_reference ?loc - GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) - -(* Globalize a reduction expression *) -let intern_evaluable ist r = - let f ist r = - let e = intern_evaluable_reference_or_by_notation ist r in - let na = short_name r in - ArgArg (e,na) - in - match r with - | {v=AN qid} when qualid_is_ident qid && find_var (qualid_basename qid) ist -> - ArgVar (make ?loc:qid.CAst.loc @@ qualid_basename qid) - | {v=AN qid} when qualid_is_ident qid && not !strict_check && find_hyp (qualid_basename qid) ist -> - let id = qualid_basename qid in - ArgArg (EvalVarRef id, Some (make ?loc:qid.CAst.loc id)) - | _ -> f ist r + ArgArg (loc, (Notation.interp_notation_as_global_reference ?loc ~head:true + GlobRef.(function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc)) let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) @@ -380,10 +390,10 @@ let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let c = Constrintern.interp_reference sign r in match DAst.get c with | GRef (r,None) -> - Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + Inl (evalref_of_globref r) | GVar id -> - let r = evaluable_of_global_reference ist.genv (GlobRef.VarRef id) in - Inl (ArgArg (r,None)) + let r = evalref_of_globref (GlobRef.VarRef id) in + Inl r | _ -> let bound_names = Glob_ops.bound_glob_vars c in Inr (bound_names,(c,None),dummy_pat) in @@ -813,6 +823,7 @@ let intern_ltac ist tac = let () = Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_smart_global (lift intern_smart_global); Genintern.register_intern0 wit_ref (lift intern_global_reference); Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); Genintern.register_intern0 wit_ident intern_ident'; diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index dda7f0742c..6d350ade8d 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -162,17 +162,27 @@ let catching_error call_trace fail (e, info) = fail located_exc end -let catch_error call_trace f x = +let update_loc ?loc (e, info) = + (e, Option.cata (Loc.add_loc info) info loc) + +let catch_error ?loc call_trace f x = try f x with e when CErrors.noncritical e -> let e = Exninfo.capture e in + let e = update_loc ?loc e in catching_error call_trace Exninfo.iraise e -let wrap_error tac k = - if is_traced () then Proofview.tclORELSE tac k else tac +let catch_error_loc ?loc tac = + Proofview.tclOR tac (fun exn -> + let (e, info) = update_loc ?loc exn in + Proofview.tclZERO ~info e) + +let wrap_error ?loc tac k = + if is_traced () then Proofview.tclORELSE tac k + else catch_error_loc ?loc tac -let catch_error_tac call_trace tac = - wrap_error +let catch_error_tac ?loc call_trace tac = + wrap_error ?loc tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -535,9 +545,10 @@ let interp_gen kind ist pattern_mode flags env sigma c = ltac_idents = constrvars.idents; ltac_genargs = ist.lfun; } in - let trace = push_trace (loc_of_glob_constr term,LtacConstrInterp (term,vars)) ist in + let loc = loc_of_glob_constr term in + let trace = push_trace (loc,LtacConstrInterp (term,vars)) ist in let (evd,c) = - catch_error trace (understand_ltac flags env sigma vars kind) term + catch_error ?loc trace (understand_ltac flags env sigma vars kind) term in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess @@ -1059,7 +1070,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let call = LtacAtomCall t in let trace = push_trace(loc,call) ist in Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac trace (interp_atomic ist t)) + (catch_error_tac ?loc trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> @@ -1087,7 +1098,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacShowHyps tac -> Proofview.V82.tactic begin tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) - end + end [@ocaml.warning "-3"] | TacAbstract (t,ido) -> let call = LtacMLCall tac in let trace = push_trace(None,call) ist in @@ -1149,7 +1160,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with ; poly ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> - Ftactic.lift (tactic_of_value ist v) + Ftactic.lift (catch_error_loc ?loc (tactic_of_value ist v)) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> @@ -1175,7 +1186,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + Proofview.Trace.name_tactic name (catch_error_tac ?loc trace (tac args ist)) in Ftactic.run args tac @@ -1278,7 +1289,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac trace (val_interp ist body)) >>= fun v -> + (catch_error_tac ?loc trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1895,8 +1906,7 @@ module Value = struct let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in of_tacvalue closure - (** Apply toplevel tactic values *) - let apply (f : value) (args: value list) = + let apply_expr f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar CAst.(make id)) in @@ -1905,9 +1915,18 @@ module Value = struct let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let lfun = Id.Map.add (Id.of_string "F") f lfun in let ist = { (default_ist ()) with lfun = lfun; } in - let tac = TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) in + ist, TacArg(CAst.make @@ TacCall (CAst.make (ArgVar CAst.(make @@ Id.of_string "F"),args))) + + + (** Apply toplevel tactic values *) + let apply (f : value) (args: value list) = + let ist, tac = apply_expr f args in eval_tactic_ist ist tac + let apply_val (f : value) (args: value list) = + let ist, tac = apply_expr f args in + val_interp ist tac + end (* globalization + interpretation *) @@ -2014,6 +2033,7 @@ let interp_pre_ident ist env sigma s = let () = register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_smart_global (lift interp_reference); register_interp0 wit_ref (lift interp_reference); register_interp0 wit_pre_ident (lift interp_pre_ident); register_interp0 wit_ident (lift interp_ident); diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index ce34356a37..cbb17bf0fa 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -29,6 +29,7 @@ sig val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a val apply : t -> t list -> unit Proofview.tactic + val apply_val : t -> t list -> t Ftactic.t end (** Values for interpretation *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index 600c30b403..ed298b7e66 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -280,6 +280,7 @@ and subst_genarg subst (GenArg (Glbwit wit, x)) = let () = Genintern.register_subst0 wit_int_or_var (fun _ v -> v); Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_smart_global subst_global_reference; Genintern.register_subst0 wit_pre_ident (fun _ v -> v); Genintern.register_subst0 wit_ident (fun _ v -> v); Genintern.register_subst0 wit_var (fun _ v -> v); diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 7e4c4ce5c6..0f8d941b41 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -128,249 +128,142 @@ let selecti s m = *) module M = struct (** - * Location of the Coq libraries. - *) - - let logic_dir = ["Coq"; "Logic"; "Decidable"] - - let mic_modules = - [ ["Coq"; "Lists"; "List"] - ; ["Coq"; "micromega"; "ZMicromega"] - ; ["Coq"; "micromega"; "Tauto"] - ; ["Coq"; "micromega"; "DeclConstant"] - ; ["Coq"; "micromega"; "RingMicromega"] - ; ["Coq"; "micromega"; "EnvRing"] - ; ["Coq"; "micromega"; "ZMicromega"] - ; ["Coq"; "micromega"; "RMicromega"] - ; ["Coq"; "micromega"; "Tauto"] - ; ["Coq"; "micromega"; "RingMicromega"] - ; ["Coq"; "micromega"; "EnvRing"] - ; ["Coq"; "QArith"; "QArith_base"] - ; ["Coq"; "Reals"; "Rdefinitions"] - ; ["Coq"; "Reals"; "Rpow_def"] - ; ["LRing_normalise"] ] - - [@@@ocaml.warning "-3"] - - let coq_modules = - Coqlib.( - init_modules @ [logic_dir] @ arith_modules @ zarith_base_modules - @ mic_modules) - - let bin_module = [["Coq"; "Numbers"; "BinNums"]] - - let r_modules = - [ ["Coq"; "Reals"; "Rdefinitions"] - ; ["Coq"; "Reals"; "Rpow_def"] - ; ["Coq"; "Reals"; "Raxioms"] - ; ["Coq"; "QArith"; "Qreals"] ] - - let z_modules = [["Coq"; "ZArith"; "BinInt"]] - - (** * Initialization : a large amount of Caml symbols are derived from * ZMicromega.v *) - let gen_constant_in_modules s m n = + let constr_of_ref str = EConstr.of_constr - ( UnivGen.constr_of_monomorphic_global - @@ Coqlib.gen_reference_in_modules s m n ) - - let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules - - [@@@ocaml.warning "+3"] - - let constant = gen_constant_in_modules "ZMicromega" coq_modules - let bin_constant = gen_constant_in_modules "ZMicromega" bin_module - let r_constant = gen_constant_in_modules "ZMicromega" r_modules - let z_constant = gen_constant_in_modules "ZMicromega" z_modules - let m_constant = gen_constant_in_modules "ZMicromega" mic_modules - let coq_and = lazy (init_constant "and") - let coq_or = lazy (init_constant "or") - let coq_not = lazy (init_constant "not") - let coq_iff = lazy (init_constant "iff") - let coq_True = lazy (init_constant "True") - let coq_False = lazy (init_constant "False") - let coq_cons = lazy (constant "cons") - let coq_nil = lazy (constant "nil") - let coq_list = lazy (constant "list") - let coq_O = lazy (init_constant "O") - let coq_S = lazy (init_constant "S") - let coq_nat = lazy (init_constant "nat") - let coq_unit = lazy (init_constant "unit") + (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref str)) + + let coq_and = lazy (constr_of_ref "core.and.type") + let coq_or = lazy (constr_of_ref "core.or.type") + let coq_not = lazy (constr_of_ref "core.not.type") + let coq_iff = lazy (constr_of_ref "core.iff.type") + let coq_True = lazy (constr_of_ref "core.True.type") + let coq_False = lazy (constr_of_ref "core.False.type") + let coq_cons = lazy (constr_of_ref "core.list.cons") + let coq_nil = lazy (constr_of_ref "core.list.nil") + let coq_list = lazy (constr_of_ref "core.list.type") + let coq_O = lazy (constr_of_ref "num.nat.O") + let coq_S = lazy (constr_of_ref "num.nat.S") + let coq_nat = lazy (constr_of_ref "num.nat.type") + let coq_unit = lazy (constr_of_ref "core.unit.type") (* let coq_option = lazy (init_constant "option")*) - let coq_None = lazy (init_constant "None") - let coq_tt = lazy (init_constant "tt") - let coq_Inl = lazy (init_constant "inl") - let coq_Inr = lazy (init_constant "inr") - let coq_N0 = lazy (bin_constant "N0") - let coq_Npos = lazy (bin_constant "Npos") - let coq_xH = lazy (bin_constant "xH") - let coq_xO = lazy (bin_constant "xO") - let coq_xI = lazy (bin_constant "xI") - let coq_Z = lazy (bin_constant "Z") - let coq_ZERO = lazy (bin_constant "Z0") - let coq_POS = lazy (bin_constant "Zpos") - let coq_NEG = lazy (bin_constant "Zneg") - let coq_Q = lazy (constant "Q") - let coq_R = lazy (constant "R") - let coq_Qmake = lazy (constant "Qmake") - let coq_Rcst = lazy (constant "Rcst") - let coq_C0 = lazy (m_constant "C0") - let coq_C1 = lazy (m_constant "C1") - let coq_CQ = lazy (m_constant "CQ") - let coq_CZ = lazy (m_constant "CZ") - let coq_CPlus = lazy (m_constant "CPlus") - let coq_CMinus = lazy (m_constant "CMinus") - let coq_CMult = lazy (m_constant "CMult") - let coq_CPow = lazy (m_constant "CPow") - let coq_CInv = lazy (m_constant "CInv") - let coq_COpp = lazy (m_constant "COpp") - let coq_R0 = lazy (constant "R0") - let coq_R1 = lazy (constant "R1") - let coq_proofTerm = lazy (constant "ZArithProof") - let coq_doneProof = lazy (constant "DoneProof") - let coq_ratProof = lazy (constant "RatProof") - let coq_cutProof = lazy (constant "CutProof") - let coq_enumProof = lazy (constant "EnumProof") - let coq_ExProof = lazy (constant "ExProof") - let coq_Zgt = lazy (z_constant "Z.gt") - let coq_Zge = lazy (z_constant "Z.ge") - let coq_Zle = lazy (z_constant "Z.le") - let coq_Zlt = lazy (z_constant "Z.lt") - let coq_Eq = lazy (init_constant "eq") - let coq_Zplus = lazy (z_constant "Z.add") - let coq_Zminus = lazy (z_constant "Z.sub") - let coq_Zopp = lazy (z_constant "Z.opp") - let coq_Zmult = lazy (z_constant "Z.mul") - let coq_Zpower = lazy (z_constant "Z.pow") - let coq_Qle = lazy (constant "Qle") - let coq_Qlt = lazy (constant "Qlt") - let coq_Qeq = lazy (constant "Qeq") - let coq_Qplus = lazy (constant "Qplus") - let coq_Qminus = lazy (constant "Qminus") - let coq_Qopp = lazy (constant "Qopp") - let coq_Qmult = lazy (constant "Qmult") - let coq_Qpower = lazy (constant "Qpower") - let coq_Rgt = lazy (r_constant "Rgt") - let coq_Rge = lazy (r_constant "Rge") - let coq_Rle = lazy (r_constant "Rle") - let coq_Rlt = lazy (r_constant "Rlt") - let coq_Rplus = lazy (r_constant "Rplus") - let coq_Rminus = lazy (r_constant "Rminus") - let coq_Ropp = lazy (r_constant "Ropp") - let coq_Rmult = lazy (r_constant "Rmult") - let coq_Rinv = lazy (r_constant "Rinv") - let coq_Rpower = lazy (r_constant "pow") - let coq_powerZR = lazy (r_constant "powerRZ") - let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (r_constant "Q2R") - let coq_PEX = lazy (constant "PEX") - let coq_PEc = lazy (constant "PEc") - let coq_PEadd = lazy (constant "PEadd") - let coq_PEopp = lazy (constant "PEopp") - let coq_PEmul = lazy (constant "PEmul") - let coq_PEsub = lazy (constant "PEsub") - let coq_PEpow = lazy (constant "PEpow") - let coq_PX = lazy (constant "PX") - let coq_Pc = lazy (constant "Pc") - let coq_Pinj = lazy (constant "Pinj") - let coq_OpEq = lazy (constant "OpEq") - let coq_OpNEq = lazy (constant "OpNEq") - let coq_OpLe = lazy (constant "OpLe") - let coq_OpLt = lazy (constant "OpLt") - let coq_OpGe = lazy (constant "OpGe") - let coq_OpGt = lazy (constant "OpGt") - let coq_PsatzIn = lazy (constant "PsatzIn") - let coq_PsatzSquare = lazy (constant "PsatzSquare") - let coq_PsatzMulE = lazy (constant "PsatzMulE") - let coq_PsatzMultC = lazy (constant "PsatzMulC") - let coq_PsatzAdd = lazy (constant "PsatzAdd") - let coq_PsatzC = lazy (constant "PsatzC") - let coq_PsatzZ = lazy (constant "PsatzZ") + let coq_None = lazy (constr_of_ref "core.option.None") + let coq_tt = lazy (constr_of_ref "core.unit.tt") + let coq_Inl = lazy (constr_of_ref "core.sum.inl") + let coq_Inr = lazy (constr_of_ref "core.sum.inr") + let coq_N0 = lazy (constr_of_ref "num.N.N0") + let coq_Npos = lazy (constr_of_ref "num.N.Npos") + let coq_xH = lazy (constr_of_ref "num.pos.xH") + let coq_xO = lazy (constr_of_ref "num.pos.xO") + let coq_xI = lazy (constr_of_ref "num.pos.xI") + let coq_Z = lazy (constr_of_ref "num.Z.type") + let coq_ZERO = lazy (constr_of_ref "num.Z.Z0") + let coq_POS = lazy (constr_of_ref "num.Z.Zpos") + let coq_NEG = lazy (constr_of_ref "num.Z.Zneg") + let coq_Q = lazy (constr_of_ref "rat.Q.type") + let coq_Qmake = lazy (constr_of_ref "rat.Q.Qmake") + let coq_R = lazy (constr_of_ref "reals.R.type") + let coq_Rcst = lazy (constr_of_ref "micromega.Rcst.type") + let coq_C0 = lazy (constr_of_ref "micromega.Rcst.C0") + let coq_C1 = lazy (constr_of_ref "micromega.Rcst.C1") + let coq_CQ = lazy (constr_of_ref "micromega.Rcst.CQ") + let coq_CZ = lazy (constr_of_ref "micromega.Rcst.CZ") + let coq_CPlus = lazy (constr_of_ref "micromega.Rcst.CPlus") + let coq_CMinus = lazy (constr_of_ref "micromega.Rcst.CMinus") + let coq_CMult = lazy (constr_of_ref "micromega.Rcst.CMult") + let coq_CPow = lazy (constr_of_ref "micromega.Rcst.CPow") + let coq_CInv = lazy (constr_of_ref "micromega.Rcst.CInv") + let coq_COpp = lazy (constr_of_ref "micromega.Rcst.COpp") + let coq_R0 = lazy (constr_of_ref "reals.R.R0") + let coq_R1 = lazy (constr_of_ref "reals.R.R1") + let coq_proofTerm = lazy (constr_of_ref "micromega.ZArithProof.type") + let coq_doneProof = lazy (constr_of_ref "micromega.ZArithProof.DoneProof") + let coq_ratProof = lazy (constr_of_ref "micromega.ZArithProof.RatProof") + let coq_cutProof = lazy (constr_of_ref "micromega.ZArithProof.CutProof") + let coq_enumProof = lazy (constr_of_ref "micromega.ZArithProof.EnumProof") + let coq_ExProof = lazy (constr_of_ref "micromega.ZArithProof.ExProof") + let coq_Zgt = lazy (constr_of_ref "num.Z.gt") + let coq_Zge = lazy (constr_of_ref "num.Z.ge") + let coq_Zle = lazy (constr_of_ref "num.Z.le") + let coq_Zlt = lazy (constr_of_ref "num.Z.lt") + let coq_Eq = lazy (constr_of_ref "core.eq.type") + let coq_Zplus = lazy (constr_of_ref "num.Z.add") + let coq_Zminus = lazy (constr_of_ref "num.Z.sub") + let coq_Zopp = lazy (constr_of_ref "num.Z.opp") + let coq_Zmult = lazy (constr_of_ref "num.Z.mul") + let coq_Zpower = lazy (constr_of_ref "num.Z.pow") + let coq_Qle = lazy (constr_of_ref "rat.Q.Qle") + let coq_Qlt = lazy (constr_of_ref "rat.Q.Qlt") + let coq_Qeq = lazy (constr_of_ref "rat.Q.Qeq") + let coq_Qplus = lazy (constr_of_ref "rat.Q.Qplus") + let coq_Qminus = lazy (constr_of_ref "rat.Q.Qminus") + let coq_Qopp = lazy (constr_of_ref "rat.Q.Qopp") + let coq_Qmult = lazy (constr_of_ref "rat.Q.Qmult") + let coq_Qpower = lazy (constr_of_ref "rat.Q.Qpower") + let coq_Rgt = lazy (constr_of_ref "reals.R.Rgt") + let coq_Rge = lazy (constr_of_ref "reals.R.Rge") + let coq_Rle = lazy (constr_of_ref "reals.R.Rle") + let coq_Rlt = lazy (constr_of_ref "reals.R.Rlt") + let coq_Rplus = lazy (constr_of_ref "reals.R.Rplus") + let coq_Rminus = lazy (constr_of_ref "reals.R.Rminus") + let coq_Ropp = lazy (constr_of_ref "reals.R.Ropp") + let coq_Rmult = lazy (constr_of_ref "reals.R.Rmult") + let coq_Rinv = lazy (constr_of_ref "reals.R.Rinv") + let coq_Rpower = lazy (constr_of_ref "reals.R.pow") + let coq_powerZR = lazy (constr_of_ref "reals.R.powerRZ") + let coq_IZR = lazy (constr_of_ref "reals.R.IZR") + let coq_IQR = lazy (constr_of_ref "reals.R.Q2R") + let coq_PEX = lazy (constr_of_ref "micromega.PExpr.PEX") + let coq_PEc = lazy (constr_of_ref "micromega.PExpr.PEc") + let coq_PEadd = lazy (constr_of_ref "micromega.PExpr.PEadd") + let coq_PEopp = lazy (constr_of_ref "micromega.PExpr.PEopp") + let coq_PEmul = lazy (constr_of_ref "micromega.PExpr.PEmul") + let coq_PEsub = lazy (constr_of_ref "micromega.PExpr.PEsub") + let coq_PEpow = lazy (constr_of_ref "micromega.PExpr.PEpow") + let coq_PX = lazy (constr_of_ref "micromega.Pol.PX") + let coq_Pc = lazy (constr_of_ref "micromega.Pol.Pc") + let coq_Pinj = lazy (constr_of_ref "micromega.Pol.Pinj") + let coq_OpEq = lazy (constr_of_ref "micromega.Op2.OpEq") + let coq_OpNEq = lazy (constr_of_ref "micromega.Op2.OpNEq") + let coq_OpLe = lazy (constr_of_ref "micromega.Op2.OpLe") + let coq_OpLt = lazy (constr_of_ref "micromega.Op2.OpLt") + let coq_OpGe = lazy (constr_of_ref "micromega.Op2.OpGe") + let coq_OpGt = lazy (constr_of_ref "micromega.Op2.OpGt") + let coq_PsatzIn = lazy (constr_of_ref "micromega.Psatz.PsatzIn") + let coq_PsatzSquare = lazy (constr_of_ref "micromega.Psatz.PsatzSquare") + let coq_PsatzMulE = lazy (constr_of_ref "micromega.Psatz.PsatzMulE") + let coq_PsatzMultC = lazy (constr_of_ref "micromega.Psatz.PsatzMulC") + let coq_PsatzAdd = lazy (constr_of_ref "micromega.Psatz.PsatzAdd") + let coq_PsatzC = lazy (constr_of_ref "micromega.Psatz.PsatzC") + let coq_PsatzZ = lazy (constr_of_ref "micromega.Psatz.PsatzZ") (* let coq_GT = lazy (m_constant "GT")*) - let coq_DeclaredConstant = lazy (m_constant "DeclaredConstant") - - let coq_TT = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "TT") - - let coq_FF = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "FF") - - let coq_And = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "Cj") - - let coq_Or = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "D") - - let coq_Neg = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "N") - - let coq_Atom = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "A") - - let coq_X = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "X") - - let coq_Impl = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "I") + let coq_DeclaredConstant = + lazy (constr_of_ref "micromega.DeclaredConstant.type") - let coq_Formula = - lazy - (gen_constant_in_modules "ZMicromega" - [["Coq"; "micromega"; "Tauto"]; ["Tauto"]] - "BFormula") + let coq_TT = lazy (constr_of_ref "micromega.GFormula.TT") + let coq_FF = lazy (constr_of_ref "micromega.GFormula.FF") + let coq_And = lazy (constr_of_ref "micromega.GFormula.Cj") + let coq_Or = lazy (constr_of_ref "micromega.GFormula.D") + let coq_Neg = lazy (constr_of_ref "micromega.GFormula.N") + let coq_Atom = lazy (constr_of_ref "micromega.GFormula.A") + let coq_X = lazy (constr_of_ref "micromega.GFormula.X") + let coq_Impl = lazy (constr_of_ref "micromega.GFormula.I") + let coq_Formula = lazy (constr_of_ref "micromega.BFormula.type") (** * Initialization : a few Caml symbols are derived from other libraries; * QMicromega, ZArithRing, RingMicromega. *) - let coq_QWitness = - lazy - (gen_constant_in_modules "QMicromega" - [["Coq"; "micromega"; "QMicromega"]] - "QWitness") - - let coq_Build = - lazy - (gen_constant_in_modules "RingMicromega" - [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] - "Build_Formula") - - let coq_Cstr = - lazy - (gen_constant_in_modules "RingMicromega" - [["Coq"; "micromega"; "RingMicromega"]; ["RingMicromega"]] - "Formula") + let coq_QWitness = lazy (constr_of_ref "micromega.QWitness.type") + let coq_Build = lazy (constr_of_ref "micromega.Formula.Build_Formula") + let coq_Cstr = lazy (constr_of_ref "micromega.Formula.type") (** * Parsing and dumping : transformation functions between Caml and Coq @@ -1318,29 +1211,10 @@ end open M -let coq_Branch = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Branch") - -let coq_Elt = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Elt") - -let coq_Empty = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "Empty") - -let coq_VarMap = - lazy - (gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "t") +let coq_Branch = lazy (constr_of_ref "micromega.VarMap.Branch") +let coq_Elt = lazy (constr_of_ref "micromega.VarMap.Elt") +let coq_Empty = lazy (constr_of_ref "micromega.VarMap.Empty") +let coq_VarMap = lazy (constr_of_ref "micromega.VarMap.type") let rec dump_varmap typ m = match m with @@ -1900,13 +1774,7 @@ let micromega_order_changer cert env ff = [ ( "__ff" , ff , EConstr.mkApp (Lazy.force coq_Formula, [|formula_typ|]) ) - ; ( "__varmap" - , vm - , EConstr.mkApp - ( gen_constant_in_modules "VarMap" - [["Coq"; "micromega"; "VarMap"]; ["VarMap"]] - "t" - , [|typ|] ) ) + ; ("__varmap", vm, EConstr.mkApp (Lazy.force coq_VarMap, [|typ|])) ; ("__wit", cert, cert_typ) ] (Tacmach.New.pf_concl gl)) (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) @@ -2029,8 +1897,6 @@ type provername = string * int option * The caching mechanism. *) -open Persistent_cache - module MakeCache (T : sig type prover_option type coeff @@ -2054,7 +1920,7 @@ struct Hash.((hash_pair T.hash_prover_option (List.fold_left hash_cstr)) 0) end - include PHashtable (E) + include Persistent_cache.PHashtable (E) let memo_opt use_cache cache_file f = let memof = memo cache_file f in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 633cdbd735..e7c75e029e 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -690,15 +690,13 @@ let ring_lookup (f : Value.t) lH rl t = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - try (* find_ring_strucure can raise an exception *) - let rl = make_args_list sigma rl t in - let evdref = ref sigma in - let e = find_ring_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in - let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + let rl = make_args_list sigma rl t in + let evdref = ref sigma in + let e = find_ring_structure env sigma rl in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in + let lH = carg (make_hyp_list env evdref lH) in + let ring = ltac_ring_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) end (***********************************************************************) @@ -984,13 +982,11 @@ let field_lookup (f : Value.t) lH rl t = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - try - let rl = make_args_list sigma rl t in - let evdref = ref sigma in - let e = find_field_structure env sigma rl in - let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in - let lH = carg (make_hyp_list env evdref lH) in - let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) - with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e + let rl = make_args_list sigma rl t in + let evdref = ref sigma in + let e = find_field_structure env sigma rl in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in + let lH = carg (make_hyp_list env evdref lH) in + let field = ltac_field_structure e in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) end diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index e05c4c26dd..01e8daf82d 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -22,7 +22,7 @@ open Locusops open Ltac_plugin open Tacmach -open Refiner +open Tacticals open Libnames open Ssrmatching_plugin open Ssrmatching @@ -81,6 +81,9 @@ let nohint = false, [] type 'a tac_a = (goal * 'a) sigma -> (goal * 'a) list sigma +let project gl = gl.Evd.sigma +let re_sig it sigma = { Evd.it = it; Evd.sigma = sigma } + let push_ctx a gl = re_sig (sig_it gl, a) (project gl) let push_ctxs a gl = re_sig (List.map (fun x -> x,a) (sig_it gl)) (project gl) @@ -947,7 +950,7 @@ let saturate ?(beta=false) ?(bi_types=false) env sigma c ?(ty=Retyping.get_type_ let open EConstr in if n = 0 then let args = List.rev args in - (if beta then Reductionops.whd_beta sigma else fun x -> x) + (if beta then Reductionops.whd_beta env sigma else fun x -> x) (EConstr.mkApp (c, Array.of_list (List.map snd args))), ty, args, sigma else match kind_of_type sigma ty with | ProdType (_, src, tgt) -> @@ -1062,11 +1065,12 @@ end let introid ?(orig=ref Anonymous) name = let open Proofview.Notations in Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let g = Proofview.Goal.concl gl in match EConstr.kind sigma g with | App (hd, _) when EConstr.isLambda sigma hd -> - convert_concl_no_check (Reductionops.whd_beta sigma g) + convert_concl_no_check (Reductionops.whd_beta env sigma g) | _ -> Tacticals.New.tclIDTAC end <*> (fst_prod false (fun id -> orig := id; Tactics.intro_mustbe_force name)) diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ab07dd5be9..29a9c65561 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -281,7 +281,7 @@ let unfoldintac occ rdx t (kt,_) = | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) | Proj _ when same_proj sigma0 c t -> body env t c | _ -> - let c = Reductionops.whd_betaiotazeta sigma0 c in + let c = Reductionops.whd_betaiotazeta env sigma0 c in match EConstr.kind sigma0 c with | Const _ when EConstr.eq_constr sigma0 c t -> body env t t | App (f,a) when EConstr.eq_constr sigma0 f t -> EConstr.mkApp (body env f f,a) @@ -516,7 +516,7 @@ let rwprocess_rule env dir rule = let rec loop d sigma r t0 rs red = let t = if red = 1 then Tacred.hnf_constr env sigma t0 - else Reductionops.whd_betaiotazeta sigma t0 in + else Reductionops.whd_betaiotazeta env sigma t0 in ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 0307728819..60af804c1b 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -349,8 +349,8 @@ let interp_index ist gl idx = begin match Tacinterp.Value.to_constr v with | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in - begin match Notation.uninterp_prim_token rc with - | _, Constrexpr.Numeral n when NumTok.Signed.is_int n -> + begin match Notation.uninterp_prim_token rc (None, []) with + | Constrexpr.Numeral n, _ when NumTok.Signed.is_int n -> int_of_string (NumTok.Signed.to_string n) | _ -> raise Not_found end diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index adaf7c8cc1..e004613ef3 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -405,7 +405,7 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = (* p_origin can be passed to obtain a better error message *) let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let k, f, a = - let f, a = Reductionops.whd_betaiota_stack ise (EConstr.of_constr p) in + let f, a = Reductionops.whd_betaiota_stack env ise (EConstr.of_constr p) in let f = EConstr.Unsafe.to_constr f in let a = List.map EConstr.Unsafe.to_constr a in match kind f with |