aboutsummaryrefslogtreecommitdiffhomepage
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml10
-rw-r--r--pretyping/coercion.ml8
-rw-r--r--pretyping/detyping.ml3
-rw-r--r--pretyping/evarconv.ml6
-rw-r--r--pretyping/glob_ops.ml193
-rw-r--r--pretyping/glob_ops.mli3
-rw-r--r--pretyping/patternops.ml8
-rw-r--r--pretyping/pretyping.ml16
8 files changed, 130 insertions, 117 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 56f5d521a..80680e408 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -731,7 +731,7 @@ let get_names env sigma sign eqns =
(fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid))
d na
in
- (na::l,(out_name na)::avoid))
+ (na::l,(Name.get_id na)::avoid))
([],allvars) (List.rev sign) names2 in
names3,aliasname
@@ -2064,8 +2064,8 @@ let mk_JMeq evdref typ x typ' y =
let mk_JMeq_refl evdref typ x =
papp evdref coq_JMeq_refl [| typ; x |]
-let hole = CAst.make @@
- GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false),
+let hole na = CAst.make @@
+ GHole (Evar_kinds.QuestionMark (Evar_kinds.Define false,na),
Misctypes.IntroAnonymous, None)
let constr_of_pat env evdref arsign pat avoid =
@@ -2168,7 +2168,7 @@ let vars_of_ctx sigma ctx =
prev,
(CAst.make @@ GApp (
(CAst.make @@ GRef (delayed_force coq_eq_refl_ref, None)),
- [hole; CAst.make @@ GVar prev])) :: vars
+ [hole na; CAst.make @@ GVar prev])) :: vars
| _ ->
match RelDecl.get_name decl with
Anonymous -> invalid_arg "vars_of_ctx"
@@ -2301,7 +2301,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity =
| l -> CAst.make @@ GApp (bref, l)
in
let branch = match ineqs with
- Some _ -> CAst.make @@ GApp (branch, [ hole ])
+ Some _ -> CAst.make @@ GApp (branch, [ hole Anonymous ])
| None -> branch
in
incr i;
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index 3ef17912f..83c26058a 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -90,8 +90,8 @@ let inh_pattern_coerce_to ?loc env pat ind1 ind2 =
open Program
-let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) env evdref c =
- let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in
+let make_existential ?loc ?(opaque = not (get_proofs_transparency ())) na env evdref c =
+ let src = Loc.tag ?loc (Evar_kinds.QuestionMark (Evar_kinds.Define opaque,na)) in
Evarutil.e_new_evar env evdref ~src c
let app_opt env evdref f t =
@@ -181,7 +181,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in
let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in
let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in
- let evar = make_existential ?loc env evdref eq in
+ let evar = make_existential ?loc n env evdref eq in
let eq_app x = papp evdref coq_eq_rect
[| eqT; hdx; pred; x; hdy; evar|]
in
@@ -324,7 +324,7 @@ and coerce ?loc env evdref (x : EConstr.constr) (y : EConstr.constr)
Some
(fun x ->
let cx = app_opt env evdref c x in
- let evar = make_existential ?loc env evdref (mkApp (p, [| cx |]))
+ let evar = make_existential ?loc Anonymous env evdref (mkApp (p, [| cx |]))
in
(papp evdref sig_intro [| u; p; cx; evar |]))
| None ->
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 752819aa3..6f099c8df 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -907,8 +907,7 @@ let simple_cases_matrix_of_branches ind brs =
let nal,c = it_destRLambda_or_LetIn_names n b in
let mkPatVar na = CAst.make @@ PatVar na in
let p = CAst.make @@ PatCstr ((ind,i+1),List.map mkPatVar nal,Anonymous) in
- let map name = try Some (Nameops.out_name name) with Failure _ -> None in
- let ids = List.map_filter map nal in
+ let ids = List.map_filter Nameops.Name.to_option nal in
Loc.tag @@ (ids,[p],c))
brs
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index bf62cea6b..630f80ad2 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -638,7 +638,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
(fun i ->
let b = nf_evar i b1 in
let t = nf_evar i t1 in
- let na = Nameops.name_max na1 na2 in
+ let na = Nameops.Name.pick na1 na2 in
evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2);
(fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)]
and f2 i =
@@ -755,7 +755,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
[(fun i -> evar_conv_x ts env i CONV c1 c2);
(fun i ->
let c = nf_evar i c1 in
- let na = Nameops.name_max na1 na2 in
+ let na = Nameops.Name.pick na1 na2 in
evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)]
| Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2
@@ -816,7 +816,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty
[(fun i -> evar_conv_x ts env i CONV c1 c2);
(fun i ->
let c = nf_evar i c1 in
- let na = Nameops.name_max n1 n2 in
+ let na = Nameops.Name.pick n1 n2 in
evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)]
| Rel x1, Rel x2 ->
diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml
index 923d7d938..6fb1b6089 100644
--- a/pretyping/glob_ops.ml
+++ b/pretyping/glob_ops.ml
@@ -33,109 +33,104 @@ let map_glob_decl_left_to_right f (na,k,obd,ty) =
(na,k,comp1,comp2)
let binding_kind_eq bk1 bk2 = match bk1, bk2 with
-| Decl_kinds.Explicit, Decl_kinds.Explicit -> true
-| Decl_kinds.Implicit, Decl_kinds.Implicit -> true
-| _ -> false
+ | Decl_kinds.Explicit, Decl_kinds.Explicit -> true
+ | Decl_kinds.Implicit, Decl_kinds.Implicit -> true
+ | (Decl_kinds.Explicit | Decl_kinds.Implicit), _ -> false
let case_style_eq s1 s2 = match s1, s2 with
-| LetStyle, LetStyle -> true
-| IfStyle, IfStyle -> true
-| LetPatternStyle, LetPatternStyle -> true
-| MatchStyle, MatchStyle -> true
-| RegularStyle, RegularStyle -> true
-| _ -> false
+ | LetStyle, LetStyle -> true
+ | IfStyle, IfStyle -> true
+ | LetPatternStyle, LetPatternStyle -> true
+ | MatchStyle, MatchStyle -> true
+ | RegularStyle, RegularStyle -> true
+ | (LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle), _ -> false
let rec cases_pattern_eq { CAst.v = p1} { CAst.v = p2 } = match p1, p2 with
-| PatVar na1, PatVar na2 -> Name.equal na1 na2
-| PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) ->
- eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
- Name.equal na1 na2
-| _ -> false
+ | PatVar na1, PatVar na2 -> Name.equal na1 na2
+ | PatCstr (c1, pl1, na1), PatCstr (c2, pl2, na2) ->
+ eq_constructor c1 c2 && List.equal cases_pattern_eq pl1 pl2 &&
+ Name.equal na1 na2
+ | (PatVar _ | PatCstr _), _ -> false
let cast_type_eq eq t1 t2 = match t1, t2 with
-| CastConv t1, CastConv t2 -> eq t1 t2
-| CastVM t1, CastVM t2 -> eq t1 t2
-| CastCoerce, CastCoerce -> true
-| CastNative t1, CastNative t2 -> eq t1 t2
-| _ -> false
-
-let rec glob_constr_eq { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
-| GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2
-| GVar id1, GVar id2 -> Id.equal id1 id2
-| GEvar (id1, arg1), GEvar (id2, arg2) ->
- Id.equal id1 id2 &&
- List.equal instance_eq arg1 arg2
-| GPatVar (b1, pat1), GPatVar (b2, pat2) ->
- (b1 : bool) == b2 && Id.equal pat1 pat2
-| GApp (f1, arg1), GApp (f2, arg2) ->
- glob_constr_eq f1 f2 && List.equal glob_constr_eq arg1 arg2
-| GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) ->
- Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) ->
- Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) ->
- Name.equal na1 na2 && glob_constr_eq b1 b2 && Option.equal glob_constr_eq t1 t2 && glob_constr_eq c1 c2
-| GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) ->
- case_style_eq st1 st2 && Option.equal glob_constr_eq c1 c2 &&
- List.equal tomatch_tuple_eq tp1 tp2 &&
- List.equal cases_clause_eq cl1 cl2
-| GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) ->
- List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
- Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-| GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) ->
- glob_constr_eq m1 m2 && Name.equal pat1 pat2 &&
- Option.equal glob_constr_eq p1 p2 && glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-| GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) ->
- fix_kind_eq kn1 kn2 && Array.equal Id.equal id1 id2 &&
- Array.equal (fun l1 l2 -> List.equal glob_decl_eq l1 l2) decl1 decl2 &&
- Array.equal glob_constr_eq c1 c2 &&
- Array.equal glob_constr_eq t1 t2
-| GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2
-| GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) ->
- Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
- Miscops.intro_pattern_naming_eq nam1 nam2
-| GCast (c1, t1), GCast (c2, t2) ->
- glob_constr_eq c1 c2 && cast_type_eq glob_constr_eq t1 t2
-| _ -> false
-
-and tomatch_tuple_eq (c1, p1) (c2, p2) =
+ | CastConv t1, CastConv t2 -> eq t1 t2
+ | CastVM t1, CastVM t2 -> eq t1 t2
+ | CastCoerce, CastCoerce -> true
+ | CastNative t1, CastNative t2 -> eq t1 t2
+ | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> false
+
+let tomatch_tuple_eq f (c1, p1) (c2, p2) =
let eqp (_, (i1, na1)) (_, (i2, na2)) =
eq_ind i1 i2 && List.equal Name.equal na1 na2
in
let eq_pred (n1, o1) (n2, o2) = Name.equal n1 n2 && Option.equal eqp o1 o2 in
- glob_constr_eq c1 c2 && eq_pred p1 p2
+ f c1 c2 && eq_pred p1 p2
-and cases_clause_eq (_, (id1, p1, c1)) (_, (id2, p2, c2)) =
- List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 &&
- glob_constr_eq c1 c2
+and cases_clause_eq f (_, (id1, p1, c1)) (_, (id2, p2, c2)) =
+ List.equal Id.equal id1 id2 && List.equal cases_pattern_eq p1 p2 && f c1 c2
-and glob_decl_eq (na1, bk1, c1, t1) (na2, bk2, c2, t2) =
+let glob_decl_eq f (na1, bk1, c1, t1) (na2, bk2, c2, t2) =
Name.equal na1 na2 && binding_kind_eq bk1 bk2 &&
- Option.equal glob_constr_eq c1 c2 &&
- glob_constr_eq t1 t2
-
-and fix_kind_eq k1 k2 = match k1, k2 with
-| GFix (a1, i1), GFix (a2, i2) ->
- let eq (i1, o1) (i2, o2) =
- Option.equal Int.equal i1 i2 && fix_recursion_order_eq o1 o2
- in
- Int.equal i1 i2 && Array.equal eq a1 a1
-| GCoFix i1, GCoFix i2 -> Int.equal i1 i2
-| _ -> false
-
-and fix_recursion_order_eq o1 o2 = match o1, o2 with
-| GStructRec, GStructRec -> true
-| GWfRec c1, GWfRec c2 -> glob_constr_eq c1 c2
-| GMeasureRec (c1, o1), GMeasureRec (c2, o2) ->
- glob_constr_eq c1 c2 && Option.equal glob_constr_eq o1 o2
-| _ -> false
-
-and instance_eq (x1,c1) (x2,c2) =
- Id.equal x1 x2 && glob_constr_eq c1 c2
+ Option.equal f c1 c2 && f t1 t2
+
+let fix_recursion_order_eq f o1 o2 = match o1, o2 with
+ | GStructRec, GStructRec -> true
+ | GWfRec c1, GWfRec c2 -> f c1 c2
+ | GMeasureRec (c1, o1), GMeasureRec (c2, o2) ->
+ f c1 c2 && Option.equal f o1 o2
+ | (GStructRec | GWfRec _ | GMeasureRec _), _ -> false
+
+let fix_kind_eq f k1 k2 = match k1, k2 with
+ | GFix (a1, i1), GFix (a2, i2) ->
+ let eq (i1, o1) (i2, o2) =
+ Option.equal Int.equal i1 i2 && fix_recursion_order_eq f o1 o2
+ in
+ Int.equal i1 i2 && Array.equal eq a1 a1
+ | GCoFix i1, GCoFix i2 -> Int.equal i1 i2
+ | (GFix _ | GCoFix _), _ -> false
+
+let instance_eq f (x1,c1) (x2,c2) =
+ Id.equal x1 x2 && f c1 c2
+
+let mk_glob_constr_eq f { CAst.v = c1 } { CAst.v = c2 } = match c1, c2 with
+ | GRef (gr1, _), GRef (gr2, _) -> eq_gr gr1 gr2
+ | GVar id1, GVar id2 -> Id.equal id1 id2
+ | GEvar (id1, arg1), GEvar (id2, arg2) ->
+ Id.equal id1 id2 && List.equal (instance_eq f) arg1 arg2
+ | GPatVar (b1, pat1), GPatVar (b2, pat2) ->
+ (b1 : bool) == b2 && Id.equal pat1 pat2
+ | GApp (f1, arg1), GApp (f2, arg2) ->
+ f f1 f2 && List.equal f arg1 arg2
+ | GLambda (na1, bk1, t1, c1), GLambda (na2, bk2, t2, c2) ->
+ Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2
+ | GProd (na1, bk1, t1, c1), GProd (na2, bk2, t2, c2) ->
+ Name.equal na1 na2 && binding_kind_eq bk1 bk2 && f t1 t2 && f c1 c2
+ | GLetIn (na1, b1, t1, c1), GLetIn (na2, b2, t2, c2) ->
+ Name.equal na1 na2 && f b1 b2 && Option.equal f t1 t2 && f c1 c2
+ | GCases (st1, c1, tp1, cl1), GCases (st2, c2, tp2, cl2) ->
+ case_style_eq st1 st2 && Option.equal f c1 c2 &&
+ List.equal (tomatch_tuple_eq f) tp1 tp2 &&
+ List.equal (cases_clause_eq f) cl1 cl2
+ | GLetTuple (na1, (n1, p1), c1, t1), GLetTuple (na2, (n2, p2), c2, t2) ->
+ List.equal Name.equal na1 na2 && Name.equal n1 n2 &&
+ Option.equal f p1 p2 && f c1 c2 && f t1 t2
+ | GIf (m1, (pat1, p1), c1, t1), GIf (m2, (pat2, p2), c2, t2) ->
+ f m1 m2 && Name.equal pat1 pat2 &&
+ Option.equal f p1 p2 && f c1 c2 && f t1 t2
+ | GRec (kn1, id1, decl1, c1, t1), GRec (kn2, id2, decl2, c2, t2) ->
+ fix_kind_eq f kn1 kn2 && Array.equal Id.equal id1 id2 &&
+ Array.equal (fun l1 l2 -> List.equal (glob_decl_eq f) l1 l2) decl1 decl2 &&
+ Array.equal f c1 c2 && Array.equal f t1 t2
+ | GSort s1, GSort s2 -> Miscops.glob_sort_eq s1 s2
+ | GHole (kn1, nam1, gn1), GHole (kn2, nam2, gn2) ->
+ Option.equal (==) gn1 gn2 (** Only thing sensible *) &&
+ Miscops.intro_pattern_naming_eq nam1 nam2
+ | GCast (c1, t1), GCast (c2, t2) ->
+ f c1 c2 && cast_type_eq f t1 t2
+ | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ |
+ GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _), _ -> false
+
+let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c
let map_glob_constr_left_to_right f = CAst.map (function
| GApp (g,args) ->
@@ -215,20 +210,20 @@ let fold_glob_constr f acc = CAst.with_val (function
)
let fold_return_type_with_binders f g v acc (na,tyopt) =
- Option.fold_left (f (name_fold g na v)) acc tyopt
+ Option.fold_left (f (Name.fold_right g na v)) acc tyopt
let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function
| GVar _ -> acc
| GApp (c,args) -> List.fold_left (f v) (f v acc c) args
| GLambda (na,_,b,c) | GProd (na,_,b,c) ->
- f (name_fold g na v) (f v acc b) c
+ f (Name.fold_right g na v) (f v acc b) c
| GLetIn (na,b,t,c) ->
- f (name_fold g na v) (Option.fold_left (f v) (f v acc b) t) c
+ f (Name.fold_right g na v) (Option.fold_left (f v) (f v acc b) t) c
| GCases (_,rtntypopt,tml,pl) ->
let fold_pattern acc (_,(idl,p,c)) = f (List.fold_right g idl v) acc c in
let fold_tomatch (v',acc) (tm,(na,onal)) =
- (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (name_fold g) nal v'')
- (name_fold g na v') onal,
+ (Option.fold_left (fun v'' (_,(_,nal)) -> List.fold_right (Name.fold_right g) nal v'')
+ (Name.fold_right g na v') onal,
f v acc tm) in
let (v',acc) = List.fold_left fold_tomatch (v,acc) tml in
let acc = Option.fold_left (f v') acc rtntypopt in
@@ -242,7 +237,7 @@ let fold_glob_constr_with_binders g f v acc = CAst.(with_val (function
let v,acc =
List.fold_left
(fun (v,acc) (na,k,bbd,bty) ->
- (name_fold g na v, f v (Option.fold_left (f v) acc bbd) bty))
+ (Name.fold_right g na v, f v (Option.fold_left (f v) acc bbd) bty))
(v,acc)
bll.(i) in
f (Array.fold_right g idl v) (f v acc tyl.(i)) (bv.(i)) in
@@ -371,12 +366,12 @@ let loc_of_glob_constr c = c.CAst.loc
let collide_id l id = List.exists (fun (id',id'') -> Id.equal id id' || Id.equal id id'') l
let test_id l id = if collide_id l id then raise Not_found
-let test_na l na = name_iter (test_id l) na
+let test_na l na = Name.iter (test_id l) na
let update_subst na l =
let in_range id l = List.exists (fun (_,id') -> Id.equal id id') l in
- let l' = name_fold Id.List.remove_assoc na l in
- name_fold
+ let l' = Name.fold_right Id.List.remove_assoc na l in
+ Name.fold_right
(fun id _ ->
if in_range id l' then
let id' = Namegen.next_ident_away_from id (fun id' -> in_range id' l') in
diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli
index aa48516af..f7cc08ca2 100644
--- a/pretyping/glob_ops.mli
+++ b/pretyping/glob_ops.mli
@@ -36,6 +36,9 @@ val map_glob_constr_left_to_right :
val warn_variable_collision : ?loc:Loc.t -> Id.t -> unit
+val mk_glob_constr_eq : (glob_constr -> glob_constr -> bool) ->
+ glob_constr -> glob_constr -> bool
+
val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a
val fold_glob_constr_with_binders : (Id.t -> 'a -> 'a) -> ('a -> 'b -> glob_constr -> 'b) -> 'a -> 'b -> glob_constr -> 'b
val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit
diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml
index 1c8ad0cdd..0818a5525 100644
--- a/pretyping/patternops.ml
+++ b/pretyping/patternops.ml
@@ -340,15 +340,15 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
PApp (pat_of_raw metas vars c,
Array.of_list (List.map (pat_of_raw metas vars) cl))
| GLambda (na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PLambda (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
| GProd (na,bk,c1,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PProd (na, pat_of_raw metas vars c1,
pat_of_raw metas (na::vars) c2)
| GLetIn (na,c1,t,c2) ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
PLetIn (na, pat_of_raw metas vars c1,
Option.map (pat_of_raw metas vars) t,
pat_of_raw metas (na::vars) c2)
@@ -411,7 +411,7 @@ let rec pat_of_raw metas vars = CAst.with_loc_val (fun ?loc -> function
and pats_of_glob_branches loc metas vars ind brs =
let get_arg = function
| { CAst.v = PatVar na } ->
- name_iter (fun n -> metas := n::!metas) na;
+ Name.iter (fun n -> metas := n::!metas) na;
na
| { CAst.v = PatCstr(_,_,_) ; loc } -> err ?loc (Pp.str "Non supported pattern.")
in
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index e72394fa2..b0663af70 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -383,6 +383,21 @@ let process_inference_flags flags env initial_sigma (sigma,c) =
let c = if flags.expand_evars then nf_evar sigma c else c in
sigma,c
+let adjust_evar_source evdref na c =
+ match na, kind !evdref c with
+ | Name id, Evar (evk,args) ->
+ let evi = Evd.find !evdref evk in
+ begin match evi.evar_source with
+ | loc, Evar_kinds.QuestionMark (b,Anonymous) ->
+ let src = (loc,Evar_kinds.QuestionMark (b,na)) in
+ let sigma = Sigma.Unsafe.of_evar_map !evdref in
+ let Sigma (evk', evd, _) = restrict_evar sigma evk (evar_filter evi) ~src None in
+ evdref := Sigma.to_evar_map evd;
+ mkEvar (evk',args)
+ | _ -> c
+ end
+ | _, _ -> c
+
(* Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *)
let allow_anonymous_refs = ref false
@@ -785,6 +800,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre
args, nf_evar !evdref (j_val hj)
else [], j_val hj
in
+ let ujval = adjust_evar_source evdref na ujval in
let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in
let j = { uj_val = value; uj_type = typ } in
apply_rec env (n+1) j candargs rest
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-29 13:57:46 +0000