aboutsummaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/classops.ml34
-rw-r--r--pretyping/classops.mli2
-rw-r--r--pretyping/constr_matching.ml77
-rw-r--r--pretyping/constr_matching.mli12
-rw-r--r--pretyping/evarconv.ml4
-rw-r--r--pretyping/reductionops.ml8
-rw-r--r--pretyping/retyping.ml4
-rw-r--r--pretyping/tacred.ml4
-rw-r--r--pretyping/typeclasses.ml4
-rw-r--r--pretyping/unification.ml4
10 files changed, 58 insertions, 95 deletions
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index c36630f5d3..6d5ee504e5 100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -322,16 +322,16 @@ let coercion_value { coe_value = c; coe_type = t; coe_context = ctx;
(* pretty-print functions are now in Pretty *)
(* rajouter une coercion dans le graphe *)
-let path_printer = ref (fun _ -> str "<a class path>"
- : (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t)
+let path_printer : (env -> Evd.evar_map -> (Bijint.Index.t * Bijint.Index.t) * inheritance_path -> Pp.t) ref =
+ ref (fun _ _ _ -> str "<a class path>")
let install_path_printer f = path_printer := f
-let print_path x = !path_printer x
+let print_path env sigma x = !path_printer env sigma x
-let message_ambig l =
- (str"Ambiguous paths:" ++ spc () ++
- prlist_with_sep fnl (fun ijp -> print_path ijp) l)
+let message_ambig env sigma l =
+ str"Ambiguous paths:" ++ spc () ++
+ prlist_with_sep fnl (fun ijp -> print_path env sigma ijp) l
(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit
coercion,source,target *)
@@ -344,8 +344,8 @@ let different_class_params i =
| CL_IND i -> Global.is_polymorphic (IndRef i)
| CL_CONST c -> Global.is_polymorphic (ConstRef c)
| _ -> false
-
-let add_coercion_in_graph (ic,source,target) =
+
+let add_coercion_in_graph env sigma (ic,source,target) =
let old_inheritance_graph = !inheritance_graph in
let ambig_paths =
(ref [] : ((cl_index * cl_index) * inheritance_path) list ref) in
@@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) =
end;
let is_ambig = match !ambig_paths with [] -> false | _ -> true in
if is_ambig && not !Flags.quiet then
- Feedback.msg_info (message_ambig !ambig_paths)
+ Feedback.msg_info (message_ambig env sigma !ambig_paths)
type coercion = {
coercion_type : coe_typ;
@@ -433,13 +433,13 @@ let _ =
optread = (fun () -> !automatically_import_coercions);
optwrite = (:=) automatically_import_coercions }
-let cache_coercion (_, c) =
+let cache_coercion env sigma (_, c) =
let () = add_class c.coercion_source in
let () = add_class c.coercion_target in
let is, _ = class_info c.coercion_source in
let it, _ = class_info c.coercion_target in
- let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in
- let typ = Retyping.get_type_of (Global.env ()) Evd.empty (EConstr.of_constr value) in
+ let value, ctx = Universes.fresh_global_instance env c.coercion_type in
+ let typ = Retyping.get_type_of env sigma (EConstr.of_constr value) in
let typ = EConstr.Unsafe.to_constr typ in
let xf =
{ coe_value = value;
@@ -450,15 +450,15 @@ let cache_coercion (_, c) =
coe_is_projection = c.coercion_is_proj;
coe_param = c.coercion_params } in
let () = add_new_coercion c.coercion_type xf in
- add_coercion_in_graph (xf,is,it)
+ add_coercion_in_graph env sigma (xf,is,it)
let load_coercion _ o =
if !automatically_import_coercions then
- cache_coercion o
+ cache_coercion (Global.env ()) Evd.empty o
let open_coercion i o =
if Int.equal i 1 && not !automatically_import_coercions then
- cache_coercion o
+ cache_coercion (Global.env ()) Evd.empty o
let subst_coercion (subst, c) =
let coe = subst_coe_typ subst c.coercion_type in
@@ -497,7 +497,9 @@ let inCoercion : coercion -> obj =
declare_object {(default_object "COERCION") with
open_function = open_coercion;
load_function = load_coercion;
- cache_function = cache_coercion;
+ cache_function = (fun objn ->
+ let env = Global.env () in cache_coercion env Evd.empty objn
+ );
subst_function = subst_coercion;
classify_function = classify_coercion;
discharge_function = discharge_coercion }
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index b41d0efac5..47b41f17b2 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -96,7 +96,7 @@ val lookup_pattern_path_between :
(**/**)
(* Crade *)
val install_path_printer :
- ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit
+ (env -> evar_map -> (cl_index * cl_index) * inheritance_path -> Pp.t) -> unit
(**/**)
(** {6 This is for printing purpose } *)
diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml
index 478ba73fd5..ec7c3077fb 100644
--- a/pretyping/constr_matching.ml
+++ b/pretyping/constr_matching.ml
@@ -206,7 +206,7 @@ let merge_binding sigma allow_bound_rels ctx n cT subst =
in
constrain sigma n c subst
-let matches_core env sigma allow_partial_app allow_bound_rels
+let matches_core env sigma allow_bound_rels
(binding_vars,pat) c =
let open EConstr in
let convref ref c =
@@ -260,7 +260,7 @@ let matches_core env sigma allow_partial_app allow_bound_rels
| PApp (PApp (h, a1), a2), _ ->
sorec ctx env subst (PApp(h,Array.append a1 a2)) t
- | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app ->
+ | PApp (PMeta meta,args1), App (c2,args2) ->
(let diff = Array.length args2 - Array.length args1 in
if diff >= 0 then
let args21, args22 = Array.chop diff args2 in
@@ -373,14 +373,14 @@ let matches_core env sigma allow_partial_app allow_bound_rels
in
sorec [] env (Id.Map.empty, Id.Map.empty) pat c
-let matches_core_closed env sigma allow_partial_app pat c =
- let names, subst = matches_core env sigma allow_partial_app false pat c in
+let matches_core_closed env sigma pat c =
+ let names, subst = matches_core env sigma false pat c in
(names, Id.Map.map snd subst)
-let extended_matches env sigma = matches_core env sigma true true
+let extended_matches env sigma = matches_core env sigma true
let matches env sigma pat c =
- snd (matches_core_closed env sigma true (Id.Set.empty,pat) c)
+ snd (matches_core_closed env sigma (Id.Set.empty,pat) c)
let special_meta = (-1)
@@ -405,9 +405,9 @@ let matches_head env sigma pat c =
matches env sigma pat head
(* Tells if it is an authorized occurrence and if the instance is closed *)
-let authorized_occ env sigma partial_app closed pat c mk_ctx =
+let authorized_occ env sigma closed pat c mk_ctx =
try
- let subst = matches_core_closed env sigma partial_app pat c in
+ let subst = matches_core_closed env sigma pat c in
if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst)
then (fun next -> next ())
else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next)
@@ -416,10 +416,10 @@ let authorized_occ env sigma partial_app closed pat c mk_ctx =
let subargs env v = Array.map_to_list (fun c -> (env, c)) v
(* Tries to match a subterm of [c] with [pat] *)
-let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
+let sub_match ?(closed=true) env sigma pat c =
let open EConstr in
let rec aux env c mk_ctx next =
- let here = authorized_occ env sigma partial_app closed pat c mk_ctx in
+ let here = authorized_occ env sigma closed pat c mk_ctx in
let next () = match EConstr.kind sigma c with
| Cast (c1,k,c2) ->
let next_mk_ctx = function
@@ -449,34 +449,12 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
let env' = EConstr.push_rel (LocalDef (x,c1,t)) env in
try_aux [(env, c1); (env', c2)] next_mk_ctx next
| App (c1,lc) ->
- let topdown = true in
- if partial_app then
- if topdown then
- let lc1 = Array.sub lc 0 (Array.length lc - 1) in
- let app = mkApp (c1,lc1) in
- let mk_ctx = function
- | [app';c] -> mk_ctx (mkApp (app',[|c|]))
- | _ -> assert false in
- try_aux [(env, app); (env, Array.last lc)] mk_ctx next
- else
- let rec aux2 app args next =
- match args with
- | [] ->
- let mk_ctx le =
- mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
- let sub = (env, c1) :: subargs env lc in
- try_aux sub mk_ctx next
- | arg :: args ->
- let app = mkApp (app,[|arg|]) in
- let next () = aux2 app args next in
- let mk_ctx ce = mk_ctx (mkApp (ce, Array.of_list args)) in
- aux env app mk_ctx next in
- aux2 c1 (Array.to_list lc) next
- else
- let mk_ctx le =
- mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in
- let sub = (env, c1) :: subargs env lc in
- try_aux sub mk_ctx next
+ let lc1 = Array.sub lc 0 (Array.length lc - 1) in
+ let app = mkApp (c1,lc1) in
+ let mk_ctx = function
+ | [app';c] -> mk_ctx (mkApp (app',[|c|]))
+ | _ -> assert false in
+ try_aux [(env, app); (env, Array.last lc)] mk_ctx next
| Case (ci,hd,c1,lc) ->
let next_mk_ctx = function
| c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc))
@@ -499,14 +477,11 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
let sub = subargs env types @ subargs env bodies in
try_aux sub next_mk_ctx next
| Proj (p,c') ->
- let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in
- if partial_app then
- try
- let term = Retyping.expand_projection env sigma p c' [] in
- aux env term mk_ctx next
- with Retyping.RetypeError _ -> next ()
- else
- try_aux [env, c'] next_mk_ctx next
+ begin try
+ let term = Retyping.expand_projection env sigma p c' [] in
+ aux env term mk_ctx next
+ with Retyping.RetypeError _ -> next ()
+ end
| Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ ->
next ()
in
@@ -527,13 +502,7 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c =
let result () = aux env c (fun x -> x) lempty in
IStream.thunk result
-let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c
-
-let match_appsubterm env sigma pat c =
- sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c
-
-let match_subterm_gen env sigma app pat c =
- sub_match ~partial_app:app env sigma pat c
+let match_subterm env sigma pat c = sub_match env sigma pat c
let is_matching env sigma pat c =
try let _ = matches env sigma pat c in true
@@ -545,5 +514,5 @@ let is_matching_head env sigma pat c =
let is_matching_appsubterm ?(closed=true) env sigma pat c =
let pat = (Id.Set.empty,pat) in
- let results = sub_match ~partial_app:true ~closed env sigma pat c in
+ let results = sub_match ~closed env sigma pat c in
not (IStream.is_empty results)
diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli
index 60e1c34a15..e4d9ff9e1e 100644
--- a/pretyping/constr_matching.mli
+++ b/pretyping/constr_matching.mli
@@ -61,18 +61,10 @@ type matching_result =
{ m_sub : bound_ident_map * patvar_map;
m_ctx : EConstr.t }
-(** [match_subterm n pat c] returns the substitution and the context
- corresponding to each **closed** subterm of [c] matching [pat]. *)
-val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
-
-(** [match_appsubterm pat c] returns the substitution and the context
+(** [match_subterm pat c] returns the substitution and the context
corresponding to each **closed** subterm of [c] matching [pat],
considering application contexts as well. *)
-val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t
-
-(** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *)
-val match_subterm_gen : env -> Evd.evar_map ->
- bool (** true = with app context *) ->
+val match_subterm : env -> Evd.evar_map ->
binding_bound_vars * constr_pattern -> constr ->
matching_result IStream.t
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index e5776d2eca..cb88446236 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -1063,8 +1063,8 @@ let evar_conv_x ts = evar_conv_x (ts, true)
(* Profiling *)
let evar_conv_x =
if Flags.profile then
- let evar_conv_xkey = Profile.declare_profile "evar_conv_x" in
- Profile.profile6 evar_conv_xkey evar_conv_x
+ let evar_conv_xkey = CProfile.declare_profile "evar_conv_x" in
+ CProfile.profile6 evar_conv_xkey evar_conv_x
else evar_conv_x
let evar_conv_hook_get, evar_conv_hook_set = Hook.make ~default:evar_conv_x ()
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index 2988ce75f8..ac88468545 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -1252,11 +1252,11 @@ let nf_all env sigma =
(* Conversion *)
(********************************************************************)
(*
-let fkey = Profile.declare_profile "fhnf";;
-let fhnf info v = Profile.profile2 fkey fhnf info v;;
+let fkey = CProfile.declare_profile "fhnf";;
+let fhnf info v = CProfile.profile2 fkey fhnf info v;;
-let fakey = Profile.declare_profile "fhnf_apply";;
-let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
+let fakey = CProfile.declare_profile "fhnf_apply";;
+let fhnf_apply info k h a = CProfile.profile4 fakey fhnf_apply info k h a;;
*)
let is_transparent e k =
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index f8f086fad3..00b175c486 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -227,8 +227,8 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty =
(* let f,_,_,_ = retype ~polyprop sigma in *)
(* if lax then f env c else anomaly_on_error (f env) c *)
-(* let get_type_of_key = Profile.declare_profile "get_type_of" *)
-(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *)
+(* let get_type_of_key = CProfile.declare_profile "get_type_of" *)
+(* let get_type_of = CProfile.profile5 get_type_of_key get_type_of *)
(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *)
(* get_type_of polyprop lax env sigma c *)
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index 85383ba398..5a522e06a5 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -927,8 +927,8 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c =
let whd_simpl_stack =
if Flags.profile then
- let key = Profile.declare_profile "whd_simpl_stack" in
- Profile.profile3 key whd_simpl_stack
+ let key = CProfile.declare_profile "whd_simpl_stack" in
+ CProfile.profile3 key whd_simpl_stack
else whd_simpl_stack
(* Same as [whd_simpl] but also reduces constants that do not hide a
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 2e213a51d7..b49da57a4b 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -552,8 +552,8 @@ let solve_all_instances env evd filter unique split fail =
Hook.get get_solve_all_instances env evd filter unique split fail
(** Profiling resolution of typeclasses *)
-(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *)
-(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *)
+(* let solve_classeskey = CProfile.declare_profile "solve_typeclasses" *)
+(* let solve_problem = CProfile.profile5 solve_classeskey solve_problem *)
let resolve_typeclasses ?(fast_path = true) ?(filter=no_goals) ?(unique=get_typeclasses_unique_solutions ())
?(split=true) ?(fail=true) env evd =
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
index df545d5a46..30674fee27 100644
--- a/pretyping/unification.ml
+++ b/pretyping/unification.ml
@@ -2015,8 +2015,8 @@ let w_unify env evd cv_pb flags ty1 ty2 =
let w_unify =
if Flags.profile then
- let wunifkey = Profile.declare_profile "w_unify" in
- Profile.profile6 wunifkey w_unify
+ let wunifkey = CProfile.declare_profile "w_unify" in
+ CProfile.profile6 wunifkey w_unify
else w_unify
let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 =
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 22:57:36 +0000