1657 lines
58 KiB
Diff
1657 lines
58 KiB
Diff
Index: VERSION
|
|
===================================================================
|
|
--- VERSION (リビジョン 11207)
|
|
+++ VERSION (作業コピー)
|
|
@@ -1,4 +1,4 @@
|
|
-3.13.0+dev6 (2011-07-29)
|
|
+3.13.0+dev7 (2011-09-22)
|
|
|
|
# The version string is the first line of this file.
|
|
# It must be in the format described in stdlib/sys.mli
|
|
Index: typing/typemod.ml
|
|
===================================================================
|
|
--- typing/typemod.ml (リビジョン 11207)
|
|
+++ typing/typemod.ml (作業コピー)
|
|
@@ -764,7 +764,7 @@
|
|
Location.prerr_warning smod.pmod_loc
|
|
(Warnings.Not_principal "this module unpacking");
|
|
modtype_of_package env smod.pmod_loc p nl tl
|
|
- | {desc = Tvar} ->
|
|
+ | {desc = Tvar _} ->
|
|
raise (Typecore.Error
|
|
(smod.pmod_loc, Typecore.Cannot_infer_signature))
|
|
| _ ->
|
|
Index: typing/typetexp.ml
|
|
===================================================================
|
|
--- typing/typetexp.ml (リビジョン 11207)
|
|
+++ typing/typetexp.ml (作業コピー)
|
|
@@ -150,7 +150,7 @@
|
|
if strict then raise Already_bound;
|
|
v
|
|
with Not_found ->
|
|
- let v = new_global_var() in
|
|
+ let v = new_global_var ~name () in
|
|
type_variables := Tbl.add name v !type_variables;
|
|
v
|
|
|
|
@@ -165,8 +165,8 @@
|
|
Tpoly _ -> ty
|
|
| _ -> Ctype.newty (Tpoly (ty, []))
|
|
|
|
-let new_pre_univar () =
|
|
- let v = newvar () in pre_univars := v :: !pre_univars; v
|
|
+let new_pre_univar ?name () =
|
|
+ let v = newvar ?name () in pre_univars := v :: !pre_univars; v
|
|
|
|
let rec swap_list = function
|
|
x :: y :: l -> y :: x :: swap_list l
|
|
@@ -190,7 +190,8 @@
|
|
instance (fst(Tbl.find name !used_variables))
|
|
with Not_found ->
|
|
let v =
|
|
- if policy = Univars then new_pre_univar () else newvar () in
|
|
+ if policy = Univars then new_pre_univar ~name () else newvar ~name ()
|
|
+ in
|
|
used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables;
|
|
v
|
|
end
|
|
@@ -333,7 +334,14 @@
|
|
end_def ();
|
|
generalize_structure t;
|
|
end;
|
|
- instance t
|
|
+ let t = instance t in
|
|
+ let px = Btype.proxy t in
|
|
+ begin match px.desc with
|
|
+ | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias)
|
|
+ | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias)
|
|
+ | _ -> ()
|
|
+ end;
|
|
+ t
|
|
end
|
|
| Ptyp_variant(fields, closed, present) ->
|
|
let name = ref None in
|
|
@@ -388,7 +396,7 @@
|
|
{desc=Tvariant row}, _ when Btype.static_row row ->
|
|
let row = Btype.row_repr row in
|
|
row.row_fields
|
|
- | {desc=Tvar}, Some(p, _) ->
|
|
+ | {desc=Tvar _}, Some(p, _) ->
|
|
raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p))
|
|
| _ ->
|
|
raise(Error(sty.ptyp_loc, Not_a_variant ty))
|
|
@@ -431,7 +439,7 @@
|
|
newty (Tvariant row)
|
|
| Ptyp_poly(vars, st) ->
|
|
begin_def();
|
|
- let new_univars = List.map (fun name -> name, newvar()) vars in
|
|
+ let new_univars = List.map (fun name -> name, newvar ~name ()) vars in
|
|
let old_univars = !univars in
|
|
univars := new_univars @ !univars;
|
|
let ty = transl_type env policy st in
|
|
@@ -443,10 +451,12 @@
|
|
(fun tyl (name, ty1) ->
|
|
let v = Btype.proxy ty1 in
|
|
if deep_occur v ty then begin
|
|
- if v.level <> Btype.generic_level || v.desc <> Tvar then
|
|
- raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
|
|
- v.desc <- Tunivar;
|
|
- v :: tyl
|
|
+ match v.desc with
|
|
+ Tvar name when v.level = Btype.generic_level ->
|
|
+ v.desc <- Tunivar name;
|
|
+ v :: tyl
|
|
+ | _ ->
|
|
+ raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)))
|
|
end else tyl)
|
|
[] new_univars
|
|
in
|
|
@@ -483,7 +493,7 @@
|
|
match ty.desc with
|
|
| Tvariant row ->
|
|
let row = Btype.row_repr row in
|
|
- if (Btype.row_more row).desc = Tunivar then
|
|
+ if Btype.is_Tunivar (Btype.row_more row) then
|
|
ty.desc <- Tvariant
|
|
{row with row_fixed=true;
|
|
row_fields = List.map
|
|
@@ -512,7 +522,7 @@
|
|
then try
|
|
r := (loc, v, Tbl.find name !type_variables) :: !r
|
|
with Not_found ->
|
|
- if fixed && (repr ty).desc = Tvar then
|
|
+ if fixed && Btype.is_Tvar (repr ty) then
|
|
raise(Error(loc, Unbound_type_variable ("'"^name)));
|
|
let v2 = new_global_var () in
|
|
r := (loc, v, v2) :: !r;
|
|
@@ -552,8 +562,10 @@
|
|
List.fold_left
|
|
(fun acc v ->
|
|
let v = repr v in
|
|
- if v.level <> Btype.generic_level || v.desc <> Tvar then acc
|
|
- else (v.desc <- Tunivar ; v :: acc))
|
|
+ match v.desc with
|
|
+ Tvar name when v.level = Btype.generic_level ->
|
|
+ v.desc <- Tunivar name; v :: acc
|
|
+ | _ -> acc)
|
|
[] !pre_univars
|
|
in
|
|
make_fixed_univars typ;
|
|
@@ -635,8 +647,8 @@
|
|
fprintf ppf "The type variable name %s is not allowed in programs" name
|
|
| Cannot_quantify (name, v) ->
|
|
fprintf ppf "This type scheme cannot quantify '%s :@ %s." name
|
|
- (if v.desc = Tvar then "it escapes this scope" else
|
|
- if v.desc = Tunivar then "it is aliased to another variable"
|
|
+ (if Btype.is_Tvar v then "it escapes this scope" else
|
|
+ if Btype.is_Tunivar v then "it is aliased to another variable"
|
|
else "it is not a variable")
|
|
| Multiple_constraints_on_type s ->
|
|
fprintf ppf "Multiple constraints for type %s" s
|
|
Index: typing/btype.ml
|
|
===================================================================
|
|
--- typing/btype.ml (リビジョン 11207)
|
|
+++ typing/btype.ml (作業コピー)
|
|
@@ -35,9 +35,9 @@
|
|
let new_id = ref (-1)
|
|
|
|
let newty2 level desc =
|
|
- incr new_id; { desc = desc; level = level; id = !new_id }
|
|
+ incr new_id; { desc; level; id = !new_id }
|
|
let newgenty desc = newty2 generic_level desc
|
|
-let newgenvar () = newgenty Tvar
|
|
+let newgenvar ?name () = newgenty (Tvar name)
|
|
(*
|
|
let newmarkedvar level =
|
|
incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
|
|
@@ -46,6 +46,11 @@
|
|
{ desc = Tvar; level = pivot_level - generic_level; id = !new_id }
|
|
*)
|
|
|
|
+(**** Check some types ****)
|
|
+
|
|
+let is_Tvar = function {desc=Tvar _} -> true | _ -> false
|
|
+let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
|
|
+
|
|
(**** Representative of a type ****)
|
|
|
|
let rec field_kind_repr =
|
|
@@ -139,7 +144,7 @@
|
|
let rec proxy_obj ty =
|
|
match ty.desc with
|
|
Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty
|
|
- | Tvar | Tunivar | Tconstr _ -> ty
|
|
+ | Tvar _ | Tunivar _ | Tconstr _ -> ty
|
|
| Tnil -> ty0
|
|
| _ -> assert false
|
|
in proxy_obj ty
|
|
@@ -180,13 +185,13 @@
|
|
row.row_fields;
|
|
match (repr row.row_more).desc with
|
|
Tvariant row -> iter_row f row
|
|
- | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
|
|
+ | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ ->
|
|
Misc.may (fun (_,l) -> List.iter f l) row.row_name
|
|
| _ -> assert false
|
|
|
|
let iter_type_expr f ty =
|
|
match ty.desc with
|
|
- Tvar -> ()
|
|
+ Tvar _ -> ()
|
|
| Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
|
|
| Ttuple l -> List.iter f l
|
|
| Tconstr (_, l, _) -> List.iter f l
|
|
@@ -198,7 +203,7 @@
|
|
| Tnil -> ()
|
|
| Tlink ty -> f ty
|
|
| Tsubst ty -> f ty
|
|
- | Tunivar -> ()
|
|
+ | Tunivar _ -> ()
|
|
| Tpoly (ty, tyl) -> f ty; List.iter f tyl
|
|
| Tpackage (_, _, l) -> List.iter f l
|
|
|
|
@@ -239,13 +244,13 @@
|
|
encoding during substitution *)
|
|
let rec norm_univar ty =
|
|
match ty.desc with
|
|
- Tunivar | Tsubst _ -> ty
|
|
+ Tunivar _ | Tsubst _ -> ty
|
|
| Tlink ty -> norm_univar ty
|
|
| Ttuple (ty :: _) -> norm_univar ty
|
|
| _ -> assert false
|
|
|
|
let rec copy_type_desc f = function
|
|
- Tvar -> Tvar
|
|
+ Tvar _ -> Tvar None (* forget the name *)
|
|
| Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c)
|
|
| Ttuple l -> Ttuple (List.map f l)
|
|
| Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil)
|
|
@@ -258,7 +263,7 @@
|
|
| Tnil -> Tnil
|
|
| Tlink ty -> copy_type_desc f ty.desc
|
|
| Tsubst ty -> assert false
|
|
- | Tunivar -> Tunivar
|
|
+ | Tunivar _ as ty -> ty (* keep the name *)
|
|
| Tpoly (ty, tyl) ->
|
|
let tyl = List.map (fun x -> norm_univar (f x)) tyl in
|
|
Tpoly (f ty, tyl)
|
|
@@ -447,7 +452,7 @@
|
|
| Cuniv of type_expr option ref * type_expr option
|
|
|
|
let undo_change = function
|
|
- Ctype (ty, desc) -> ty.desc <- desc
|
|
+ Ctype (ty, desc) -> ty.desc <- desc
|
|
| Clevel (ty, level) -> ty.level <- level
|
|
| Cname (r, v) -> r := v
|
|
| Crow (r, v) -> r := v
|
|
@@ -474,7 +479,22 @@
|
|
|
|
let log_type ty =
|
|
if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
|
|
-let link_type ty ty' = log_type ty; ty.desc <- Tlink ty'
|
|
+let link_type ty ty' =
|
|
+ log_type ty;
|
|
+ let desc = ty.desc in
|
|
+ ty.desc <- Tlink ty';
|
|
+ (* Name is a user-supplied name for this unification variable (obtained
|
|
+ * through a type annotation for instance). *)
|
|
+ match desc, ty'.desc with
|
|
+ Tvar name, Tvar name' ->
|
|
+ begin match name, name' with
|
|
+ | Some _, None -> log_type ty'; ty'.desc <- Tvar name
|
|
+ | None, Some _ -> ()
|
|
+ | Some _, Some _ ->
|
|
+ if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name)
|
|
+ | None, None -> ()
|
|
+ end
|
|
+ | _ -> ()
|
|
(* ; assert (check_memorized_abbrevs ()) *)
|
|
(* ; check_expans [] ty' *)
|
|
let set_level ty level =
|
|
Index: typing/typecore.ml
|
|
===================================================================
|
|
--- typing/typecore.ml (リビジョン 11207)
|
|
+++ typing/typecore.ml (作業コピー)
|
|
@@ -633,7 +633,7 @@
|
|
List.iter generalize vars;
|
|
let instantiated tv =
|
|
let tv = expand_head !env tv in
|
|
- tv.desc <> Tvar || tv.level <> generic_level in
|
|
+ not (is_Tvar tv) || tv.level <> generic_level in
|
|
if List.exists instantiated vars then
|
|
raise (Error(loc, Polymorphic_label (lid_of_label label)))
|
|
end;
|
|
@@ -1126,7 +1126,7 @@
|
|
Tarrow (l, _, ty_res, _) ->
|
|
list_labels_aux env (ty::visited) (l::ls) ty_res
|
|
| _ ->
|
|
- List.rev ls, ty.desc = Tvar
|
|
+ List.rev ls, is_Tvar ty
|
|
|
|
let list_labels env ty = list_labels_aux env [] [] ty
|
|
|
|
@@ -1142,9 +1142,10 @@
|
|
(fun t ->
|
|
let t = repr t in
|
|
generalize t;
|
|
- if t.desc = Tvar && t.level = generic_level then
|
|
- (log_type t; t.desc <- Tunivar; true)
|
|
- else false)
|
|
+ match t.desc with
|
|
+ Tvar name when t.level = generic_level ->
|
|
+ log_type t; t.desc <- Tunivar name; true
|
|
+ | _ -> false)
|
|
vars in
|
|
if List.length vars = List.length vars' then () else
|
|
let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
|
|
@@ -1158,7 +1159,7 @@
|
|
match (expand_head env exp.exp_type).desc with
|
|
| Tarrow _ ->
|
|
Location.prerr_warning exp.exp_loc Warnings.Partial_application
|
|
- | Tvar -> ()
|
|
+ | Tvar _ -> ()
|
|
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
|
|
| _ ->
|
|
if statement then
|
|
@@ -1742,7 +1743,7 @@
|
|
let (id, typ) =
|
|
filter_self_method env met Private meths privty
|
|
in
|
|
- if (repr typ).desc = Tvar then
|
|
+ if is_Tvar (repr typ) then
|
|
Location.prerr_warning loc
|
|
(Warnings.Undeclared_virtual_method met);
|
|
(Texp_send(obj, Tmeth_val id), typ)
|
|
@@ -1797,7 +1798,7 @@
|
|
Location.prerr_warning loc
|
|
(Warnings.Not_principal "this use of a polymorphic method");
|
|
snd (instance_poly false tl ty)
|
|
- | {desc = Tvar} as ty ->
|
|
+ | {desc = Tvar _} as ty ->
|
|
let ty' = newvar () in
|
|
unify env (instance ty) (newty(Tpoly(ty',[])));
|
|
(* if not !Clflags.nolabels then
|
|
@@ -1979,7 +1980,7 @@
|
|
end_def ();
|
|
check_univars env false "method" exp ty_expected vars;
|
|
re { exp with exp_type = instance ty }
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
let exp = type_exp env sbody in
|
|
let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in
|
|
unify_exp env exp ty;
|
|
@@ -2038,7 +2039,7 @@
|
|
Location.prerr_warning loc
|
|
(Warnings.Not_principal "this module packing");
|
|
(p, nl, tl)
|
|
- | {desc = Tvar} ->
|
|
+ | {desc = Tvar _} ->
|
|
raise (Error (loc, Cannot_infer_signature))
|
|
| _ ->
|
|
raise (Error (loc, Not_a_packed_module ty_expected))
|
|
@@ -2128,7 +2129,7 @@
|
|
ty_fun
|
|
| Tarrow (l,_,ty_res',_) when l = "" || !Clflags.classic ->
|
|
args, ty_fun, no_labels ty_res'
|
|
- | Tvar -> args, ty_fun, false
|
|
+ | Tvar _ -> args, ty_fun, false
|
|
| _ -> [], texp.exp_type, false
|
|
in
|
|
let args, ty_fun', simple_res = make_args [] texp.exp_type in
|
|
@@ -2192,7 +2193,7 @@
|
|
let (ty1, ty2) =
|
|
let ty_fun = expand_head env ty_fun in
|
|
match ty_fun.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
let t1 = newvar () and t2 = newvar () in
|
|
let not_identity = function
|
|
Texp_ident(_,{val_kind=Val_prim
|
|
@@ -2335,7 +2336,7 @@
|
|
begin match (expand_head env exp.exp_type).desc with
|
|
| Tarrow _ ->
|
|
Location.prerr_warning exp.exp_loc Warnings.Partial_application
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
add_delayed_check (fun () -> check_application_result env false exp)
|
|
| _ -> ()
|
|
end;
|
|
@@ -2404,9 +2405,9 @@
|
|
| Tarrow _ ->
|
|
Location.prerr_warning loc Warnings.Partial_application
|
|
| Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
|
|
- | Tvar when ty.level > tv.level ->
|
|
+ | Tvar _ when ty.level > tv.level ->
|
|
Location.prerr_warning loc Warnings.Nonreturning_statement
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
add_delayed_check (fun () -> check_application_result env true exp)
|
|
| _ ->
|
|
Location.prerr_warning loc Warnings.Statement_type
|
|
Index: typing/btype.mli
|
|
===================================================================
|
|
--- typing/btype.mli (リビジョン 11207)
|
|
+++ typing/btype.mli (作業コピー)
|
|
@@ -23,7 +23,7 @@
|
|
(* Create a type *)
|
|
val newgenty: type_desc -> type_expr
|
|
(* Create a generic type *)
|
|
-val newgenvar: unit -> type_expr
|
|
+val newgenvar: ?name:string -> unit -> type_expr
|
|
(* Return a fresh generic variable *)
|
|
|
|
(* Use Tsubst instead
|
|
@@ -33,6 +33,9 @@
|
|
(* Return a fresh marked generic variable *)
|
|
*)
|
|
|
|
+val is_Tvar: type_expr -> bool
|
|
+val is_Tunivar: type_expr -> bool
|
|
+
|
|
val repr: type_expr -> type_expr
|
|
(* Return the canonical representative of a type. *)
|
|
|
|
Index: typing/ctype.mli
|
|
===================================================================
|
|
--- typing/ctype.mli (リビジョン 11207)
|
|
+++ typing/ctype.mli (作業コピー)
|
|
@@ -41,9 +41,10 @@
|
|
(* This pair of functions is only used in Typetexp *)
|
|
|
|
val newty: type_desc -> type_expr
|
|
-val newvar: unit -> type_expr
|
|
+val newvar: ?name:string -> unit -> type_expr
|
|
+val newvar2: ?name:string -> int -> type_expr
|
|
(* Return a fresh variable *)
|
|
-val new_global_var: unit -> type_expr
|
|
+val new_global_var: ?name:string -> unit -> type_expr
|
|
(* Return a fresh variable, bound at toplevel
|
|
(as type variables ['a] in type constraints). *)
|
|
val newobj: type_expr -> type_expr
|
|
Index: typing/datarepr.ml
|
|
===================================================================
|
|
--- typing/datarepr.ml (リビジョン 11207)
|
|
+++ typing/datarepr.ml (作業コピー)
|
|
@@ -28,7 +28,7 @@
|
|
if ty.level >= lowest_level then begin
|
|
ty.level <- pivot_level - ty.level;
|
|
match ty.desc with
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
ret := TypeSet.add ty !ret
|
|
| Tvariant row ->
|
|
let row = row_repr row in
|
|
Index: typing/typeclass.ml
|
|
===================================================================
|
|
--- typing/typeclass.ml (リビジョン 11207)
|
|
+++ typing/typeclass.ml (作業コピー)
|
|
@@ -532,7 +532,7 @@
|
|
(Typetexp.transl_simple_type val_env false sty) ty
|
|
end;
|
|
begin match (Ctype.repr ty).desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
let ty' = Ctype.newvar () in
|
|
Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty;
|
|
Ctype.unify val_env (type_approx val_env sbody) ty'
|
|
Index: typing/typedecl.ml
|
|
===================================================================
|
|
--- typing/typedecl.ml (リビジョン 11207)
|
|
+++ typing/typedecl.ml (作業コピー)
|
|
@@ -111,7 +111,7 @@
|
|
| _ ->
|
|
raise (Error (loc, Bad_fixed_type "is not an object or variant"))
|
|
in
|
|
- if rv.desc <> Tvar then
|
|
+ if not (Btype.is_Tvar rv) then
|
|
raise (Error (loc, Bad_fixed_type "has no row variable"));
|
|
rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
|
|
|
|
@@ -503,7 +503,7 @@
|
|
compute_same row.row_more
|
|
| Tpoly (ty, _) ->
|
|
compute_same ty
|
|
- | Tvar | Tnil | Tlink _ | Tunivar -> ()
|
|
+ | Tvar _ | Tnil | Tlink _ | Tunivar _ -> ()
|
|
| Tpackage (_, _, tyl) ->
|
|
List.iter (compute_variance_rec true true true) tyl
|
|
end
|
|
@@ -546,7 +546,7 @@
|
|
in
|
|
List.iter2
|
|
(fun (ty, co, cn, ct) (c, n) ->
|
|
- if ty.desc <> Tvar then begin
|
|
+ if not (Btype.is_Tvar ty) then begin
|
|
co := c; cn := n; ct := n;
|
|
compute_variance env tvl2 c n n ty
|
|
end)
|
|
@@ -571,7 +571,7 @@
|
|
|
|
let rec anonymous env ty =
|
|
match (Ctype.expand_head env ty).desc with
|
|
- | Tvar -> false
|
|
+ | Tvar _ -> false
|
|
| Tobject (fi, _) ->
|
|
let _, rv = Ctype.flatten_fields fi in anonymous env rv
|
|
| Tvariant row ->
|
|
Index: typing/types.mli
|
|
===================================================================
|
|
--- typing/types.mli (リビジョン 11207)
|
|
+++ typing/types.mli (作業コピー)
|
|
@@ -24,7 +24,7 @@
|
|
mutable id: int }
|
|
|
|
and type_desc =
|
|
- Tvar
|
|
+ Tvar of string option
|
|
| Tarrow of label * type_expr * type_expr * commutable
|
|
| Ttuple of type_expr list
|
|
| Tconstr of Path.t * type_expr list * abbrev_memo ref
|
|
@@ -34,7 +34,7 @@
|
|
| Tlink of type_expr
|
|
| Tsubst of type_expr (* for copying *)
|
|
| Tvariant of row_desc
|
|
- | Tunivar
|
|
+ | Tunivar of string option
|
|
| Tpoly of type_expr * type_expr list
|
|
| Tpackage of Path.t * string list * type_expr list
|
|
|
|
Index: typing/ctype.ml
|
|
===================================================================
|
|
--- typing/ctype.ml (リビジョン 11207)
|
|
+++ typing/ctype.ml (作業コピー)
|
|
@@ -153,9 +153,9 @@
|
|
let newty desc = newty2 !current_level desc
|
|
let new_global_ty desc = newty2 !global_level desc
|
|
|
|
-let newvar () = newty2 !current_level Tvar
|
|
-let newvar2 level = newty2 level Tvar
|
|
-let new_global_var () = newty2 !global_level Tvar
|
|
+let newvar ?name () = newty2 !current_level (Tvar name)
|
|
+let newvar2 ?name level = newty2 level (Tvar name)
|
|
+let new_global_var ?name () = newty2 !global_level (Tvar name)
|
|
|
|
let newobj fields = newty (Tobject (fields, ref None))
|
|
|
|
@@ -297,14 +297,12 @@
|
|
|
|
let opened_object ty =
|
|
match (object_row ty).desc with
|
|
- | Tvar -> true
|
|
- | Tunivar -> true
|
|
- | Tconstr _ -> true
|
|
- | _ -> false
|
|
+ | Tvar _ | Tunivar _ | Tconstr _ -> true
|
|
+ | _ -> false
|
|
|
|
let concrete_object ty =
|
|
match (object_row ty).desc with
|
|
- | Tvar -> false
|
|
+ | Tvar _ -> false
|
|
| _ -> true
|
|
|
|
(**** Close an object ****)
|
|
@@ -313,7 +311,7 @@
|
|
let rec close ty =
|
|
let ty = repr ty in
|
|
match ty.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
link_type ty (newty2 ty.level Tnil)
|
|
| Tfield(_, _, _, ty') -> close ty'
|
|
| _ -> assert false
|
|
@@ -329,7 +327,7 @@
|
|
let ty = repr ty in
|
|
match ty.desc with
|
|
Tfield (_, _, _, ty) -> find ty
|
|
- | Tvar -> ty
|
|
+ | Tvar _ -> ty
|
|
| _ -> assert false
|
|
in
|
|
match (repr ty).desc with
|
|
@@ -434,7 +432,7 @@
|
|
let level = ty.level in
|
|
ty.level <- pivot_level - level;
|
|
match ty.desc with
|
|
- Tvar when level <> generic_level ->
|
|
+ Tvar _ when level <> generic_level ->
|
|
raise Non_closed
|
|
| Tfield(_, kind, t1, t2) ->
|
|
if field_kind_repr kind = Fpresent then
|
|
@@ -468,7 +466,7 @@
|
|
if ty.level >= lowest_level then begin
|
|
ty.level <- pivot_level - ty.level;
|
|
begin match ty.desc, !really_closed with
|
|
- Tvar, _ ->
|
|
+ Tvar _, _ ->
|
|
free_variables := (ty, real) :: !free_variables
|
|
| Tconstr (path, tl, _), Some env ->
|
|
begin try
|
|
@@ -639,7 +637,7 @@
|
|
let rec generalize_structure var_level ty =
|
|
let ty = repr ty in
|
|
if ty.level <> generic_level then begin
|
|
- if ty.desc = Tvar && ty.level > var_level then
|
|
+ if is_Tvar ty && ty.level > var_level then
|
|
set_level ty var_level
|
|
else if ty.level > !current_level then begin
|
|
set_level ty generic_level;
|
|
@@ -858,7 +856,7 @@
|
|
TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
|
|
List.iter (add_univar univ) inv.inv_parents
|
|
in
|
|
- TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
|
|
+ TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv)
|
|
inverted;
|
|
fun ty ->
|
|
try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
|
|
@@ -913,7 +911,7 @@
|
|
if keep then ty.level else !current_level
|
|
else generic_level
|
|
in
|
|
- if forget <> generic_level then newty2 forget Tvar else
|
|
+ if forget <> generic_level then newty2 forget (Tvar None) else
|
|
let desc = ty.desc in
|
|
save_desc ty desc;
|
|
let t = newvar() in (* Stub *)
|
|
@@ -959,7 +957,7 @@
|
|
| Tconstr _ ->
|
|
if keep then save_desc more more.desc;
|
|
copy more
|
|
- | Tvar | Tunivar ->
|
|
+ | Tvar _ | Tunivar _ ->
|
|
save_desc more more.desc;
|
|
if keep then more else newty more.desc
|
|
| _ -> assert false
|
|
@@ -1117,7 +1115,7 @@
|
|
t
|
|
else try
|
|
let t, bound_t = List.assq ty visited in
|
|
- let dl = if ty.desc = Tunivar then [] else diff_list bound bound_t in
|
|
+ let dl = if is_Tunivar ty then [] else diff_list bound bound_t in
|
|
if dl <> [] && conflicts univars dl then raise Not_found;
|
|
t
|
|
with Not_found -> begin
|
|
@@ -1134,14 +1132,14 @@
|
|
let row = row_repr row0 in
|
|
let more = repr row.row_more in
|
|
(* We shall really check the level on the row variable *)
|
|
- let keep = more.desc = Tvar && more.level <> generic_level in
|
|
+ let keep = is_Tvar more && more.level <> generic_level in
|
|
let more' = copy_rec more in
|
|
- let fixed' = fixed && (repr more').desc = Tvar in
|
|
+ let fixed' = fixed && is_Tvar (repr more') in
|
|
let row = copy_row copy_rec fixed' row keep more' in
|
|
Tvariant row
|
|
| Tpoly (t1, tl) ->
|
|
let tl = List.map repr tl in
|
|
- let tl' = List.map (fun t -> newty Tunivar) tl in
|
|
+ let tl' = List.map (fun t -> newty t.desc) tl in
|
|
let bound = tl @ bound in
|
|
let visited =
|
|
List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
|
|
@@ -1395,7 +1393,7 @@
|
|
let rec full_expand env ty =
|
|
let ty = repr (expand_head env ty) in
|
|
match ty.desc with
|
|
- Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
|
|
+ Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) ->
|
|
newty2 ty.level (Tobject (fi, ref None))
|
|
| _ ->
|
|
ty
|
|
@@ -1570,8 +1568,8 @@
|
|
true
|
|
then
|
|
match ty.desc with
|
|
- Tunivar ->
|
|
- if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar()])
|
|
+ Tunivar _ ->
|
|
+ if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()])
|
|
| Tpoly (ty, tyl) ->
|
|
let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
|
|
occur_rec bound ty
|
|
@@ -1620,7 +1618,7 @@
|
|
Tpoly (t, tl) ->
|
|
if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
|
|
else occur t
|
|
- | Tunivar ->
|
|
+ | Tunivar _ ->
|
|
if TypeSet.mem t family then raise Occur
|
|
| Tconstr (_, [], _) -> ()
|
|
| Tconstr (p, tl, _) ->
|
|
@@ -1784,7 +1782,7 @@
|
|
t
|
|
end;
|
|
iter_type_expr (iterator visited) ty
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
let t = create_fresh_constr ty.level false in
|
|
link_type ty t
|
|
| _ ->
|
|
@@ -1862,8 +1860,8 @@
|
|
let t2 = repr t2 in
|
|
if t1 == t2 then () else
|
|
match (t1.desc, t2.desc) with
|
|
- | (Tvar, _)
|
|
- | (_, Tvar) ->
|
|
+ | (Tvar _, _)
|
|
+ | (_, Tvar _) ->
|
|
fatal_error "types should not include variables"
|
|
| (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
|
|
()
|
|
@@ -1877,7 +1875,7 @@
|
|
with Not_found ->
|
|
TypePairs.add type_pairs (t1', t2') ();
|
|
match (t1'.desc, t2'.desc) with
|
|
- (Tvar, Tvar) ->
|
|
+ (Tvar _, Tvar _) ->
|
|
fatal_error "types should not include variables"
|
|
| (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
|
|
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
|
|
@@ -1903,7 +1901,7 @@
|
|
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
|
|
enter_poly env univar_pairs t1 tl1 t2 tl2
|
|
(mcomp type_pairs subst env)
|
|
- | (Tunivar, Tunivar) ->
|
|
+ | (Tunivar _, Tunivar _) ->
|
|
unify_univar t1' t2' !univar_pairs
|
|
| (_, _) ->
|
|
raise (Unify [])
|
|
@@ -2048,21 +2046,21 @@
|
|
try
|
|
type_changed := true;
|
|
match (t1.desc, t2.desc) with
|
|
- (Tvar, Tconstr _) when deep_occur t1 t2 ->
|
|
+ (Tvar _, Tconstr _) when deep_occur t1 t2 ->
|
|
unify2 env t1 t2
|
|
- | (Tconstr _, Tvar) when deep_occur t2 t1 ->
|
|
+ | (Tconstr _, Tvar _) when deep_occur t2 t1 ->
|
|
unify2 env t1 t2
|
|
- | (Tvar, _) ->
|
|
+ | (Tvar _, _) ->
|
|
occur !env t1 t2;
|
|
occur_univar !env t2;
|
|
link_type t1 t2;
|
|
update_level !env t1.level t2
|
|
- | (_, Tvar) ->
|
|
+ | (_, Tvar _) ->
|
|
occur !env t2 t1;
|
|
occur_univar !env t1;
|
|
link_type t2 t1;
|
|
update_level !env t2.level t1
|
|
- | (Tunivar, Tunivar) ->
|
|
+ | (Tunivar _, Tunivar _) ->
|
|
unify_univar t1 t2 !univar_pairs;
|
|
update_level !env t1.level t2;
|
|
link_type t1 t2
|
|
@@ -2104,7 +2102,7 @@
|
|
(* Assumes either [t1 == t1'] or [t2 != t2'] *)
|
|
let d1 = t1'.desc and d2 = t2'.desc in
|
|
match (d1, d2) with (* handle univars specially *)
|
|
- (Tunivar, Tunivar) ->
|
|
+ (Tunivar _, Tunivar _) ->
|
|
unify_univar t1' t2' !univar_pairs;
|
|
update_level !env t1'.level t2';
|
|
link_type t1' t2'
|
|
@@ -2127,12 +2125,12 @@
|
|
| Old -> f () (* old_link was already called *)
|
|
in
|
|
match d1, d2 with
|
|
- | Tvar,_ ->
|
|
+ | Tvar _, _ ->
|
|
occur !env t1 t2';
|
|
occur_univar !env t2;
|
|
update_level !env t1'.level t2;
|
|
link_type t1' t2;
|
|
- | _, Tvar ->
|
|
+ | _, Tvar _ ->
|
|
occur !env t2 t1';
|
|
occur_univar !env t1;
|
|
update_level !env t2'.level t1;
|
|
@@ -2149,8 +2147,8 @@
|
|
add_type_equality t1' t2' end;
|
|
try
|
|
begin match (d1, d2) with
|
|
- | (Tvar, _)
|
|
- | (_, Tvar) ->
|
|
+ | (Tvar _, _)
|
|
+ | (_, Tvar _) ->
|
|
(* cases taken care of *)
|
|
assert false
|
|
| (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
|
|
@@ -2214,8 +2212,9 @@
|
|
(* Type [t2'] may have been instantiated by [unify_fields] *)
|
|
(* XXX One should do some kind of unification... *)
|
|
begin match (repr t2').desc with
|
|
- Tobject (_, {contents = Some (_, va::_)})
|
|
- when let va = repr va in List.mem va.desc [Tvar; Tunivar; Tnil] ->
|
|
+ Tobject (_, {contents = Some (_, va::_)}) when
|
|
+ (match (repr va).desc with
|
|
+ Tvar _|Tunivar _|Tnil -> true | _ -> false) ->
|
|
()
|
|
| Tobject (_, nm2) ->
|
|
set_name nm2 !nm1
|
|
@@ -2290,16 +2289,32 @@
|
|
raise (Unify []);
|
|
List.iter2 (unify env) tl1 tl2
|
|
|
|
+(* Build a fresh row variable for unification *)
|
|
+and make_rowvar level use1 rest1 use2 rest2 =
|
|
+ let set_name ty name =
|
|
+ match ty.desc with
|
|
+ Tvar None -> log_type ty; ty.desc <- Tvar name
|
|
+ | _ -> ()
|
|
+ in
|
|
+ let name =
|
|
+ match rest1.desc, rest2.desc with
|
|
+ Tvar (Some _ as name1), Tvar (Some _ as name2) ->
|
|
+ if rest1.level <= rest2.level then name1 else name2
|
|
+ | Tvar (Some _ as name), _ ->
|
|
+ if use2 then set_name rest2 name; name
|
|
+ | _, Tvar (Some _ as name) ->
|
|
+ if use1 then set_name rest2 name; name
|
|
+ | _ -> None
|
|
+ in
|
|
+ if use1 then rest1 else
|
|
+ if use2 then rest2 else newvar2 ?name level
|
|
+
|
|
and unify_fields env ty1 ty2 = (* Optimization *)
|
|
let (fields1, rest1) = flatten_fields ty1
|
|
and (fields2, rest2) = flatten_fields ty2 in
|
|
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
|
|
let l1 = (repr ty1).level and l2 = (repr ty2).level in
|
|
- let va =
|
|
- if miss1 = [] then rest2
|
|
- else if miss2 = [] then rest1
|
|
- else newty2 (min l1 l2) Tvar
|
|
- in
|
|
+ let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in
|
|
let d1 = rest1.desc and d2 = rest2.desc in
|
|
try
|
|
unify env (build_fields l1 miss1 va) rest2;
|
|
@@ -2390,7 +2405,7 @@
|
|
let rm = row_more row in
|
|
if row.row_fixed then
|
|
if row0.row_more == rm then () else
|
|
- if rm.desc = Tvar then link_type rm row0.row_more else
|
|
+ if is_Tvar rm then link_type rm row0.row_more else
|
|
unify env rm row0.row_more
|
|
else
|
|
let ty = newty2 generic_level (Tvariant {row0 with row_fields = rest}) in
|
|
@@ -2489,7 +2504,7 @@
|
|
let t1 = repr t1 and t2 = repr t2 in
|
|
if t1 == t2 then () else
|
|
match t1.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
begin try
|
|
occur env t1 t2;
|
|
update_level env t1.level t2;
|
|
@@ -2527,7 +2542,7 @@
|
|
let rec filter_arrow env t l =
|
|
let t = expand_head_unif env t in
|
|
match t.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
let lv = t.level in
|
|
let t1 = newvar2 lv and t2 = newvar2 lv in
|
|
let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in
|
|
@@ -2543,7 +2558,7 @@
|
|
let rec filter_method_field env name priv ty =
|
|
let ty = repr ty in
|
|
match ty.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
let level = ty.level in
|
|
let ty1 = newvar2 level and ty2 = newvar2 level in
|
|
let ty' = newty2 level (Tfield (name,
|
|
@@ -2570,7 +2585,7 @@
|
|
let rec filter_method env name priv ty =
|
|
let ty = expand_head_unif env ty in
|
|
match ty.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
let ty1 = newvar () in
|
|
let ty' = newobj ty1 in
|
|
update_level env ty.level ty';
|
|
@@ -2606,7 +2621,7 @@
|
|
let rec occur ty =
|
|
let ty = repr ty in
|
|
if ty.level > level then begin
|
|
- if ty.desc = Tvar && ty.level >= generic_level - 1 then raise Occur;
|
|
+ if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur;
|
|
ty.level <- pivot_level - ty.level;
|
|
match ty.desc with
|
|
Tvariant row when static_row row ->
|
|
@@ -2636,7 +2651,7 @@
|
|
|
|
try
|
|
match (t1.desc, t2.desc) with
|
|
- (Tvar, _) when may_instantiate inst_nongen t1 ->
|
|
+ (Tvar _, _) when may_instantiate inst_nongen t1 ->
|
|
moregen_occur env t1.level t2;
|
|
occur env t1 t2;
|
|
link_type t1 t2
|
|
@@ -2653,7 +2668,7 @@
|
|
with Not_found ->
|
|
TypePairs.add type_pairs (t1', t2') ();
|
|
match (t1'.desc, t2'.desc) with
|
|
- (Tvar, _) when may_instantiate inst_nongen t1' ->
|
|
+ (Tvar _, _) when may_instantiate inst_nongen t1' ->
|
|
moregen_occur env t1'.level t2;
|
|
link_type t1' t2
|
|
| (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2
|
|
@@ -2684,7 +2699,7 @@
|
|
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
|
|
enter_poly env univar_pairs t1 tl1 t2 tl2
|
|
(moregen inst_nongen type_pairs env)
|
|
- | (Tunivar, Tunivar) ->
|
|
+ | (Tunivar _, Tunivar _) ->
|
|
unify_univar t1' t2' !univar_pairs
|
|
| (_, _) ->
|
|
raise (Unify [])
|
|
@@ -2725,7 +2740,7 @@
|
|
let row1 = row_repr row1 and row2 = row_repr row2 in
|
|
let rm1 = repr row1.row_more and rm2 = repr row2.row_more in
|
|
if rm1 == rm2 then () else
|
|
- let may_inst = rm1.desc = Tvar && may_instantiate inst_nongen rm1 in
|
|
+ let may_inst = is_Tvar rm1 && may_instantiate inst_nongen rm1 in
|
|
let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
|
|
let r1, r2 =
|
|
if row2.row_closed then
|
|
@@ -2735,9 +2750,9 @@
|
|
if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> [])
|
|
then raise (Unify []);
|
|
begin match rm1.desc, rm2.desc with
|
|
- Tunivar, Tunivar ->
|
|
+ Tunivar _, Tunivar _ ->
|
|
unify_univar rm1 rm2 !univar_pairs
|
|
- | Tunivar, _ | _, Tunivar ->
|
|
+ | Tunivar _, _ | _, Tunivar _ ->
|
|
raise (Unify [])
|
|
| _ when static_row row1 -> ()
|
|
| _ when may_inst ->
|
|
@@ -2828,13 +2843,13 @@
|
|
if ty.level >= lowest_level then begin
|
|
ty.level <- pivot_level - ty.level;
|
|
match ty.desc with
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
if not (List.memq ty !vars) then vars := ty :: !vars
|
|
| Tvariant row ->
|
|
let row = row_repr row in
|
|
let more = repr row.row_more in
|
|
- if more.desc = Tvar && not row.row_fixed then begin
|
|
- let more' = newty2 more.level Tvar in
|
|
+ if is_Tvar more && not row.row_fixed then begin
|
|
+ let more' = newty2 more.level more.desc in
|
|
let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
|
|
in link_type more (newty2 ty.level (Tvariant row'))
|
|
end;
|
|
@@ -2857,7 +2872,7 @@
|
|
(fun ty ->
|
|
let ty = expand_head env ty in
|
|
if List.memq ty !tyl then false else
|
|
- (tyl := ty :: !tyl; ty.desc = Tvar))
|
|
+ (tyl := ty :: !tyl; is_Tvar ty))
|
|
vars
|
|
|
|
let matches env ty ty' =
|
|
@@ -2901,7 +2916,7 @@
|
|
|
|
try
|
|
match (t1.desc, t2.desc) with
|
|
- (Tvar, Tvar) when rename ->
|
|
+ (Tvar _, Tvar _) when rename ->
|
|
begin try
|
|
normalize_subst subst;
|
|
if List.assq t1 !subst != t2 then raise (Unify [])
|
|
@@ -2922,7 +2937,7 @@
|
|
with Not_found ->
|
|
TypePairs.add type_pairs (t1', t2') ();
|
|
match (t1'.desc, t2'.desc) with
|
|
- (Tvar, Tvar) when rename ->
|
|
+ (Tvar _, Tvar _) when rename ->
|
|
begin try
|
|
normalize_subst subst;
|
|
if List.assq t1' !subst != t2' then raise (Unify [])
|
|
@@ -2956,7 +2971,7 @@
|
|
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
|
|
enter_poly env univar_pairs t1 tl1 t2 tl2
|
|
(eqtype rename type_pairs subst env)
|
|
- | (Tunivar, Tunivar) ->
|
|
+ | (Tunivar _, Tunivar _) ->
|
|
unify_univar t1' t2' !univar_pairs
|
|
| (_, _) ->
|
|
raise (Unify [])
|
|
@@ -3405,7 +3420,7 @@
|
|
let rec build_subtype env visited loops posi level t =
|
|
let t = repr t in
|
|
match t.desc with
|
|
- Tvar ->
|
|
+ Tvar _ ->
|
|
if posi then
|
|
try
|
|
let t' = List.assq t loops in
|
|
@@ -3454,13 +3469,13 @@
|
|
as this occurence might break the occur check.
|
|
XXX not clear whether this correct anyway... *)
|
|
if List.exists (deep_occur ty) tl1 then raise Not_found;
|
|
- ty.desc <- Tvar;
|
|
+ ty.desc <- Tvar None;
|
|
let t'' = newvar () in
|
|
let loops = (ty, t'') :: loops in
|
|
(* May discard [visited] as level is going down *)
|
|
let (ty1', c) =
|
|
build_subtype env [t'] loops posi (pred_enlarge level') ty1 in
|
|
- assert (t''.desc = Tvar);
|
|
+ assert (is_Tvar t'');
|
|
let nm =
|
|
if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in
|
|
t''.desc <- Tobject (ty1', ref nm);
|
|
@@ -3559,7 +3574,7 @@
|
|
let (t1', c) = build_subtype env visited loops posi level t1 in
|
|
if c > Unchanged then (newty (Tpoly(t1', tl)), c)
|
|
else (t, Unchanged)
|
|
- | Tunivar | Tpackage _ ->
|
|
+ | Tunivar _ | Tpackage _ ->
|
|
(t, Unchanged)
|
|
|
|
let enlarge_type env ty =
|
|
@@ -3623,7 +3638,7 @@
|
|
with Not_found ->
|
|
TypePairs.add subtypes (t1, t2) ();
|
|
match (t1.desc, t2.desc) with
|
|
- (Tvar, _) | (_, Tvar) ->
|
|
+ (Tvar _, _) | (_, Tvar _) ->
|
|
(trace, t1, t2, !univar_pairs)::cstrs
|
|
| (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when l1 = l2
|
|
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
|
|
@@ -3659,7 +3674,7 @@
|
|
| (Tconstr(p1, tl1, _), _) when private_abbrev env p1 ->
|
|
subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs
|
|
| (Tobject (f1, _), Tobject (f2, _))
|
|
- when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar ->
|
|
+ when is_Tvar (object_row f1) && is_Tvar (object_row f2) ->
|
|
(* Same row variable implies same object. *)
|
|
(trace, t1, t2, !univar_pairs)::cstrs
|
|
| (Tobject (f1, _), Tobject (f2, _)) ->
|
|
@@ -3731,7 +3746,7 @@
|
|
match more1.desc, more2.desc with
|
|
Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 ->
|
|
subtype_rec env ((more1,more2)::trace) more1 more2 cstrs
|
|
- | (Tvar|Tconstr _), (Tvar|Tconstr _)
|
|
+ | (Tvar _|Tconstr _), (Tvar _|Tconstr _)
|
|
when row1.row_closed && r1 = [] ->
|
|
List.fold_left
|
|
(fun cstrs (_,f1,f2) ->
|
|
@@ -3745,7 +3760,7 @@
|
|
| Rabsent, _ -> cstrs
|
|
| _ -> raise Exit)
|
|
cstrs pairs
|
|
- | Tunivar, Tunivar
|
|
+ | Tunivar _, Tunivar _
|
|
when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] ->
|
|
let cstrs =
|
|
subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in
|
|
@@ -3789,19 +3804,19 @@
|
|
match ty.desc with
|
|
Tfield (s, k, t1, t2) ->
|
|
newty2 ty.level (Tfield (s, k, t1, unalias_object t2))
|
|
- | Tvar | Tnil ->
|
|
+ | Tvar _ | Tnil ->
|
|
newty2 ty.level ty.desc
|
|
- | Tunivar ->
|
|
+ | Tunivar _ ->
|
|
ty
|
|
| Tconstr _ ->
|
|
- newty2 ty.level Tvar
|
|
+ newvar2 ty.level
|
|
| _ ->
|
|
assert false
|
|
|
|
let unalias ty =
|
|
let ty = repr ty in
|
|
match ty.desc with
|
|
- Tvar | Tunivar ->
|
|
+ Tvar _ | Tunivar _ ->
|
|
ty
|
|
| Tvariant row ->
|
|
let row = row_repr row in
|
|
@@ -3875,7 +3890,7 @@
|
|
set_name nm None
|
|
else let v' = repr v in
|
|
begin match v'.desc with
|
|
- | Tvar|Tunivar ->
|
|
+ | Tvar _ | Tunivar _ ->
|
|
if v' != v then set_name nm (Some (n, v' :: l))
|
|
| Tnil ->
|
|
log_type ty; ty.desc <- Tconstr (n, l, ref Mnil)
|
|
@@ -3917,7 +3932,7 @@
|
|
|
|
let rec nondep_type_rec env id ty =
|
|
match ty.desc with
|
|
- Tvar | Tunivar -> ty
|
|
+ Tvar _ | Tunivar _ -> ty
|
|
| Tlink ty -> nondep_type_rec env id ty
|
|
| _ -> try TypeHash.find nondep_hash ty
|
|
with Not_found ->
|
|
@@ -3987,7 +4002,7 @@
|
|
|
|
let unroll_abbrev id tl ty =
|
|
let ty = repr ty and path = Path.Pident id in
|
|
- if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl)
|
|
+ if is_Tvar ty || (List.exists (deep_occur ty) tl)
|
|
|| is_object_type path then
|
|
ty
|
|
else
|
|
Index: typing/printtyp.ml
|
|
===================================================================
|
|
--- typing/printtyp.ml (リビジョン 11207)
|
|
+++ typing/printtyp.ml (作業コピー)
|
|
@@ -109,6 +109,10 @@
|
|
| Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
|
|
| Mlink rem -> list_of_memo !rem
|
|
|
|
+let print_name ppf = function
|
|
+ None -> fprintf ppf "None"
|
|
+ | Some name -> fprintf ppf "\"%s\"" name
|
|
+
|
|
let visited = ref []
|
|
let rec raw_type ppf ty =
|
|
let ty = safe_repr [] ty in
|
|
@@ -119,7 +123,7 @@
|
|
end
|
|
and raw_type_list tl = raw_list raw_type tl
|
|
and raw_type_desc ppf = function
|
|
- Tvar -> fprintf ppf "Tvar"
|
|
+ Tvar name -> fprintf ppf "Tvar %a" print_name name
|
|
| Tarrow(l,t1,t2,c) ->
|
|
fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
|
|
l raw_type t1 raw_type t2
|
|
@@ -143,7 +147,7 @@
|
|
| Tnil -> fprintf ppf "Tnil"
|
|
| Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
|
|
| Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
|
|
- | Tunivar -> fprintf ppf "Tunivar"
|
|
+ | Tunivar name -> fprintf ppf "Tunivar %a" print_name name
|
|
| Tpoly (t, tl) ->
|
|
fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
|
|
raw_type t
|
|
@@ -189,28 +193,61 @@
|
|
|
|
let names = ref ([] : (type_expr * string) list)
|
|
let name_counter = ref 0
|
|
+let named_vars = ref ([] : string list)
|
|
|
|
-let reset_names () = names := []; name_counter := 0
|
|
+let reset_names () = names := []; name_counter := 0; named_vars := []
|
|
+let add_named_var ty =
|
|
+ match ty.desc with
|
|
+ Tvar (Some name) | Tunivar (Some name) ->
|
|
+ if List.mem name !named_vars then () else
|
|
+ named_vars := name :: !named_vars
|
|
+ | _ -> ()
|
|
|
|
-let new_name () =
|
|
+let rec new_name () =
|
|
let name =
|
|
if !name_counter < 26
|
|
then String.make 1 (Char.chr(97 + !name_counter))
|
|
else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
|
|
string_of_int(!name_counter / 26) in
|
|
incr name_counter;
|
|
- name
|
|
+ if List.mem name !named_vars
|
|
+ || List.exists (fun (_, name') -> name = name') !names
|
|
+ then new_name ()
|
|
+ else name
|
|
|
|
let name_of_type t =
|
|
+ (* We've already been through repr at this stage, so t is our representative
|
|
+ of the union-find class. *)
|
|
try List.assq t !names with Not_found ->
|
|
- let name = new_name () in
|
|
+ let name =
|
|
+ match t.desc with
|
|
+ Tvar (Some name) | Tunivar (Some name) ->
|
|
+ (* Some part of the type we've already printed has assigned another
|
|
+ * unification variable to that name. We want to keep the name, so try
|
|
+ * adding a number until we find a name that's not taken. *)
|
|
+ let current_name = ref name in
|
|
+ let i = ref 0 in
|
|
+ while List.exists (fun (_, name') -> !current_name = name') !names do
|
|
+ current_name := name ^ (string_of_int !i);
|
|
+ i := !i + 1;
|
|
+ done;
|
|
+ !current_name
|
|
+ | _ ->
|
|
+ (* No name available, create a new one *)
|
|
+ new_name ()
|
|
+ in
|
|
names := (t, name) :: !names;
|
|
name
|
|
|
|
let check_name_of_type t = ignore(name_of_type t)
|
|
|
|
+let remove_names tyl =
|
|
+ let tyl = List.map repr tyl in
|
|
+ names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names
|
|
+
|
|
+
|
|
let non_gen_mark sch ty =
|
|
- if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
|
|
+ if sch && is_Tvar ty && ty.level <> generic_level then "_" else ""
|
|
|
|
let print_name_of_type sch ppf t =
|
|
fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
|
|
@@ -225,9 +262,13 @@
|
|
let is_aliased ty = List.memq (proxy ty) !aliased
|
|
let add_alias ty =
|
|
let px = proxy ty in
|
|
- if not (is_aliased px) then aliased := px :: !aliased
|
|
+ if not (is_aliased px) then begin
|
|
+ aliased := px :: !aliased;
|
|
+ add_named_var px
|
|
+ end
|
|
+
|
|
let aliasable ty =
|
|
- match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
|
|
+ match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true
|
|
|
|
let namable_row row =
|
|
row.row_name <> None &&
|
|
@@ -245,7 +286,7 @@
|
|
if List.memq px visited && aliasable ty then add_alias px else
|
|
let visited = px :: visited in
|
|
match ty.desc with
|
|
- | Tvar -> ()
|
|
+ | Tvar _ -> add_named_var ty
|
|
| Tarrow(_, ty1, ty2, _) ->
|
|
mark_loops_rec visited ty1; mark_loops_rec visited ty2
|
|
| Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
|
|
@@ -290,7 +331,7 @@
|
|
| Tpoly (ty, tyl) ->
|
|
List.iter (fun t -> add_alias t) tyl;
|
|
mark_loops_rec visited ty
|
|
- | Tunivar -> ()
|
|
+ | Tunivar _ -> add_named_var ty
|
|
|
|
let mark_loops ty =
|
|
normalize_type Env.empty ty;
|
|
@@ -322,7 +363,7 @@
|
|
|
|
let pr_typ () =
|
|
match ty.desc with
|
|
- | Tvar ->
|
|
+ | Tvar _ ->
|
|
Otyp_var (is_non_gen sch ty, name_of_type ty)
|
|
| Tarrow(l, ty1, ty2, _) ->
|
|
let pr_arrow l ty1 ty2 =
|
|
@@ -387,16 +428,22 @@
|
|
| Tpoly (ty, []) ->
|
|
tree_of_typexp sch ty
|
|
| Tpoly (ty, tyl) ->
|
|
+ (*let print_names () =
|
|
+ List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names;
|
|
+ prerr_string "; " in *)
|
|
let tyl = List.map repr tyl in
|
|
- (* let tyl = List.filter is_aliased tyl in *)
|
|
if tyl = [] then tree_of_typexp sch ty else begin
|
|
let old_delayed = !delayed in
|
|
+ (* Make the names delayed, so that the real type is
|
|
+ printed once when used as proxy *)
|
|
List.iter add_delayed tyl;
|
|
let tl = List.map name_of_type tyl in
|
|
let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
|
|
+ (* Forget names when we leave scope *)
|
|
+ remove_names tyl;
|
|
delayed := old_delayed; tr
|
|
end
|
|
- | Tunivar ->
|
|
+ | Tunivar _ ->
|
|
Otyp_var (false, name_of_type ty)
|
|
| Tpackage (p, n, tyl) ->
|
|
Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
|
|
@@ -446,13 +493,13 @@
|
|
end
|
|
|
|
and is_non_gen sch ty =
|
|
- sch && ty.desc = Tvar && ty.level <> generic_level
|
|
+ sch && is_Tvar ty && ty.level <> generic_level
|
|
|
|
and tree_of_typfields sch rest = function
|
|
| [] ->
|
|
let rest =
|
|
match rest.desc with
|
|
- | Tvar | Tunivar -> Some (is_non_gen sch rest)
|
|
+ | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest)
|
|
| Tconstr _ -> Some false
|
|
| Tnil -> None
|
|
| _ -> fatal_error "typfields (1)"
|
|
@@ -564,7 +611,7 @@
|
|
let vari =
|
|
List.map2
|
|
(fun ty (co,cn,ct) ->
|
|
- if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
|
|
+ if abstr || not (is_Tvar (repr ty)) then (co,cn) else (true,true))
|
|
decl.type_params decl.type_variance
|
|
in
|
|
(Ident.name id,
|
|
@@ -645,16 +692,18 @@
|
|
|
|
let method_type (_, kind, ty) =
|
|
match field_kind_repr kind, repr ty with
|
|
- Fpresent, {desc=Tpoly(ty, _)} -> ty
|
|
- | _ , ty -> ty
|
|
+ Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl)
|
|
+ | _ , ty -> (ty, [])
|
|
|
|
let tree_of_metho sch concrete csil (lab, kind, ty) =
|
|
if lab <> dummy_method then begin
|
|
let kind = field_kind_repr kind in
|
|
let priv = kind <> Fpresent in
|
|
let virt = not (Concr.mem lab concrete) in
|
|
- let ty = method_type (lab, kind, ty) in
|
|
- Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
|
|
+ let (ty, tyl) = method_type (lab, kind, ty) in
|
|
+ let tty = tree_of_typexp sch ty in
|
|
+ remove_names tyl;
|
|
+ Ocsg_method (lab, priv, virt, tty) :: csil
|
|
end
|
|
else csil
|
|
|
|
@@ -662,7 +711,7 @@
|
|
| Tcty_constr (p, tyl, cty) ->
|
|
let sty = Ctype.self_type cty in
|
|
if List.memq (proxy sty) !visited_objects
|
|
- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
|
|
+ || not (List.for_all is_Tvar params)
|
|
|| List.exists (deep_occur sty) tyl
|
|
then prepare_class_type params cty
|
|
else List.iter mark_loops tyl
|
|
@@ -675,7 +724,7 @@
|
|
let (fields, _) =
|
|
Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
|
|
in
|
|
- List.iter (fun met -> mark_loops (method_type met)) fields;
|
|
+ List.iter (fun met -> mark_loops (fst (method_type met))) fields;
|
|
Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
|
|
| Tcty_fun (_, ty, cty) ->
|
|
mark_loops ty;
|
|
@@ -686,7 +735,7 @@
|
|
| Tcty_constr (p', tyl, cty) ->
|
|
let sty = Ctype.self_type cty in
|
|
if List.memq (proxy sty) !visited_objects
|
|
- || List.exists (fun ty -> (repr ty).desc <> Tvar) params
|
|
+ || not (List.for_all is_Tvar params)
|
|
then
|
|
tree_of_class_type sch params cty
|
|
else
|
|
@@ -743,7 +792,7 @@
|
|
(match tree_of_typexp true param with
|
|
Otyp_var (_, s) -> s
|
|
| _ -> "?"),
|
|
- if (repr param).desc = Tvar then (true, true) else variance
|
|
+ if is_Tvar (repr param) then (true, true) else variance
|
|
|
|
let tree_of_class_params params =
|
|
let tyl = tree_of_typlist true params in
|
|
@@ -890,7 +939,7 @@
|
|
| {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
|
|
newty2 t.level
|
|
(Tvariant {(row_repr row) with row_name = None;
|
|
- row_more = newty2 (row_more row).level Tvar})
|
|
+ row_more = newvar2 (row_more row).level})
|
|
| _ -> t
|
|
|
|
let prepare_expansion (t, t') =
|
|
@@ -913,9 +962,9 @@
|
|
let has_explanation unif t3 t4 =
|
|
match t3.desc, t4.desc with
|
|
Tfield _, _ | _, Tfield _
|
|
- | Tunivar, Tvar | Tvar, Tunivar
|
|
+ | Tunivar _, Tvar _ | Tvar _, Tunivar _
|
|
| Tvariant _, Tvariant _ -> true
|
|
- | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
|
|
+ | Tconstr (p, _, _), Tvar _ | Tvar _, Tconstr (p, _, _) ->
|
|
unif && min t3.level t4.level < Path.binding_time p
|
|
| _ -> false
|
|
|
|
@@ -931,21 +980,21 @@
|
|
|
|
let explanation unif t3 t4 ppf =
|
|
match t3.desc, t4.desc with
|
|
- | Tfield _, Tvar | Tvar, Tfield _ ->
|
|
+ | Tfield _, Tvar _ | Tvar _, Tfield _ ->
|
|
fprintf ppf "@,Self type cannot escape its class"
|
|
- | Tconstr (p, tl, _), Tvar
|
|
+ | Tconstr (p, tl, _), Tvar _
|
|
when unif && (tl = [] || t4.level < Path.binding_time p) ->
|
|
fprintf ppf
|
|
"@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
|
|
path p
|
|
- | Tvar, Tconstr (p, tl, _)
|
|
+ | Tvar _, Tconstr (p, tl, _)
|
|
when unif && (tl = [] || t3.level < Path.binding_time p) ->
|
|
fprintf ppf
|
|
"@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
|
|
path p
|
|
- | Tvar, Tunivar | Tunivar, Tvar ->
|
|
+ | Tvar _, Tunivar _ | Tunivar _, Tvar _ ->
|
|
fprintf ppf "@,The universal variable %a would escape its scope"
|
|
- type_expr (if t3.desc = Tunivar then t3 else t4)
|
|
+ type_expr (if is_Tunivar t3 then t3 else t4)
|
|
| Tfield (lab, _, _, _), _
|
|
| _, Tfield (lab, _, _, _) when lab = dummy_method ->
|
|
fprintf ppf
|
|
Index: typing/includecore.ml
|
|
===================================================================
|
|
--- typing/includecore.ml (リビジョン 11207)
|
|
+++ typing/includecore.ml (作業コピー)
|
|
@@ -61,7 +61,7 @@
|
|
Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
|
|
let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
|
|
Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
|
|
- (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) &&
|
|
+ (match row1.row_more with {desc=Tvar _|Tconstr _} -> true | _ -> false) &&
|
|
let r1, r2, pairs =
|
|
Ctype.merge_row_fields row1.row_fields row2.row_fields in
|
|
(not row2.row_closed ||
|
|
@@ -91,7 +91,7 @@
|
|
let (fields2,rest2) = Ctype.flatten_fields fi2 in
|
|
Ctype.equal env true (ty1::params1) (rest2::params2) &&
|
|
let (fields1,rest1) = Ctype.flatten_fields fi1 in
|
|
- (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
|
|
+ (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) &&
|
|
let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
|
|
miss2 = [] &&
|
|
let tl1, tl2 =
|
|
@@ -251,7 +251,7 @@
|
|
let encode_val (mut, ty) rem =
|
|
begin match mut with
|
|
Asttypes.Mutable -> Predef.type_unit
|
|
- | Asttypes.Immutable -> Btype.newgenty Tvar
|
|
+ | Asttypes.Immutable -> Btype.newgenvar ()
|
|
end
|
|
::ty::rem
|
|
|
|
Index: typing/subst.ml
|
|
===================================================================
|
|
--- typing/subst.ml (リビジョン 11207)
|
|
+++ typing/subst.ml (作業コピー)
|
|
@@ -71,16 +71,19 @@
|
|
let reset_for_saving () = new_id := -1
|
|
|
|
let newpersty desc =
|
|
- decr new_id; { desc = desc; level = generic_level; id = !new_id }
|
|
+ decr new_id;
|
|
+ { desc = desc; level = generic_level; id = !new_id }
|
|
|
|
(* Similar to [Ctype.nondep_type_rec]. *)
|
|
let rec typexp s ty =
|
|
let ty = repr ty in
|
|
match ty.desc with
|
|
- Tvar | Tunivar ->
|
|
+ Tvar _ | Tunivar _ ->
|
|
if s.for_saving || ty.id < 0 then
|
|
+ let desc = match ty.desc with (* Tvar _ -> Tvar None *) | d -> d in
|
|
let ty' =
|
|
- if s.for_saving then newpersty ty.desc else newty2 ty.level ty.desc
|
|
+ if s.for_saving then newpersty desc
|
|
+ else newty2 ty.level desc
|
|
in
|
|
save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty'
|
|
else ty
|
|
@@ -94,7 +97,7 @@
|
|
let desc = ty.desc in
|
|
save_desc ty desc;
|
|
(* Make a stub *)
|
|
- let ty' = if s.for_saving then newpersty Tvar else newgenvar () in
|
|
+ let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
|
|
ty.desc <- Tsubst ty';
|
|
ty'.desc <-
|
|
begin match desc with
|
|
@@ -127,10 +130,10 @@
|
|
match more.desc with
|
|
Tsubst ty -> ty
|
|
| Tconstr _ -> typexp s more
|
|
- | Tunivar | Tvar ->
|
|
+ | Tunivar _ | Tvar _ ->
|
|
save_desc more more.desc;
|
|
if s.for_saving then newpersty more.desc else
|
|
- if dup && more.desc <> Tunivar then newgenvar () else more
|
|
+ if dup && is_Tvar more then newgenty more.desc else more
|
|
| _ -> assert false
|
|
in
|
|
(* Register new type first for recursion *)
|
|
Index: typing/types.ml
|
|
===================================================================
|
|
--- typing/types.ml (リビジョン 11207)
|
|
+++ typing/types.ml (作業コピー)
|
|
@@ -25,7 +25,7 @@
|
|
mutable id: int }
|
|
|
|
and type_desc =
|
|
- Tvar
|
|
+ Tvar of string option
|
|
| Tarrow of label * type_expr * type_expr * commutable
|
|
| Ttuple of type_expr list
|
|
| Tconstr of Path.t * type_expr list * abbrev_memo ref
|
|
@@ -35,7 +35,7 @@
|
|
| Tlink of type_expr
|
|
| Tsubst of type_expr (* for copying *)
|
|
| Tvariant of row_desc
|
|
- | Tunivar
|
|
+ | Tunivar of string option
|
|
| Tpoly of type_expr * type_expr list
|
|
| Tpackage of Path.t * string list * type_expr list
|
|
|
|
Index: ocamldoc/odoc_str.ml
|
|
===================================================================
|
|
--- ocamldoc/odoc_str.ml (リビジョン 11207)
|
|
+++ ocamldoc/odoc_str.ml (作業コピー)
|
|
@@ -31,7 +31,7 @@
|
|
| Types.Tlink t2 | Types.Tsubst t2 -> is_arrow_type t2
|
|
| Types.Ttuple _
|
|
| Types.Tconstr _
|
|
- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
|
|
+ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
|
|
| Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
|
|
|
|
let raw_string_of_type_list sep type_list =
|
|
@@ -43,7 +43,7 @@
|
|
| Types.Tlink t2 | Types.Tsubst t2 -> need_parent t2
|
|
| Types.Tconstr _ ->
|
|
false
|
|
- | Types.Tvar | Types.Tunivar | Types.Tobject _ | Types.Tpoly _
|
|
+ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _
|
|
| Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false
|
|
in
|
|
let print_one_type variance t =
|
|
Index: ocamldoc/odoc_value.ml
|
|
===================================================================
|
|
--- ocamldoc/odoc_value.ml (リビジョン 11207)
|
|
+++ ocamldoc/odoc_value.ml (作業コピー)
|
|
@@ -77,13 +77,13 @@
|
|
| Types.Tsubst texp ->
|
|
iter texp
|
|
| Types.Tpoly (texp, _) -> iter texp
|
|
- | Types.Tvar
|
|
+ | Types.Tvar _
|
|
| Types.Ttuple _
|
|
| Types.Tconstr _
|
|
| Types.Tobject _
|
|
| Types.Tfield _
|
|
| Types.Tnil
|
|
- | Types.Tunivar
|
|
+ | Types.Tunivar _
|
|
| Types.Tpackage _
|
|
| Types.Tvariant _ ->
|
|
[]
|
|
Index: ocamldoc/odoc_misc.ml
|
|
===================================================================
|
|
--- ocamldoc/odoc_misc.ml (リビジョン 11207)
|
|
+++ ocamldoc/odoc_misc.ml (作業コピー)
|
|
@@ -478,8 +478,8 @@
|
|
match t with
|
|
| Types.Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty.Types.desc
|
|
| Types.Tconstr _
|
|
- | Types.Tvar
|
|
- | Types.Tunivar
|
|
+ | Types.Tvar _
|
|
+ | Types.Tunivar _
|
|
| Types.Tpoly _
|
|
| Types.Tarrow _
|
|
| Types.Ttuple _
|
|
Index: bytecomp/typeopt.ml
|
|
===================================================================
|
|
--- bytecomp/typeopt.ml (リビジョン 11207)
|
|
+++ bytecomp/typeopt.ml (作業コピー)
|
|
@@ -50,7 +50,7 @@
|
|
|
|
let array_element_kind env ty =
|
|
match scrape env ty with
|
|
- | Tvar | Tunivar ->
|
|
+ | Tvar _ | Tunivar _ ->
|
|
Pgenarray
|
|
| Tconstr(p, args, abbrev) ->
|
|
if Path.same p Predef.path_int || Path.same p Predef.path_char then
|
|
Index: bytecomp/translcore.ml
|
|
===================================================================
|
|
--- bytecomp/translcore.ml (リビジョン 11207)
|
|
+++ bytecomp/translcore.ml (作業コピー)
|
|
@@ -780,12 +780,13 @@
|
|
begin match e.exp_type.desc with
|
|
(* the following may represent a float/forward/lazy: need a
|
|
forward_tag *)
|
|
- | Tvar | Tlink _ | Tsubst _ | Tunivar
|
|
+ | Tvar _ | Tlink _ | Tsubst _ | Tunivar _
|
|
| Tpoly(_,_) | Tfield(_,_,_,_) ->
|
|
Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
|
|
(* the following cannot be represented as float/forward/lazy:
|
|
optimize *)
|
|
- | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil | Tvariant _
|
|
+ | Tarrow(_,_,_,_) | Ttuple _ | Tpackage _ | Tobject(_,_) | Tnil
|
|
+ | Tvariant _
|
|
-> transl_exp e
|
|
(* optimize predefined types (excepted float) *)
|
|
| Tconstr(_,_,_) ->
|
|
Index: testsuite/tests/lib-hashtbl/htbl.ml
|
|
===================================================================
|
|
--- testsuite/tests/lib-hashtbl/htbl.ml (リビジョン 11207)
|
|
+++ testsuite/tests/lib-hashtbl/htbl.ml (作業コピー)
|
|
@@ -76,7 +76,7 @@
|
|
struct
|
|
type key = M.key
|
|
type 'a t = (key, 'a) Hashtbl.t
|
|
- let create = Hashtbl.create
|
|
+ let create s = Hashtbl.create s
|
|
let clear = Hashtbl.clear
|
|
let copy = Hashtbl.copy
|
|
let add = Hashtbl.add
|
|
Index: toplevel/genprintval.ml
|
|
===================================================================
|
|
--- toplevel/genprintval.ml (リビジョン 11207)
|
|
+++ toplevel/genprintval.ml (作業コピー)
|
|
@@ -180,7 +180,7 @@
|
|
find_printer env ty obj
|
|
with Not_found ->
|
|
match (Ctype.repr ty).desc with
|
|
- | Tvar ->
|
|
+ | Tvar _ | Tunivar _ ->
|
|
Oval_stuff "<poly>"
|
|
| Tarrow(_, ty1, ty2, _) ->
|
|
Oval_stuff "<fun>"
|
|
@@ -327,8 +327,6 @@
|
|
fatal_error "Printval.outval_of_value"
|
|
| Tpoly (ty, _) ->
|
|
tree_of_val (depth - 1) obj ty
|
|
- | Tunivar ->
|
|
- Oval_stuff "<poly>"
|
|
| Tpackage _ ->
|
|
Oval_stuff "<module>"
|
|
end
|
|
Index: otherlibs/labltk/browser/searchid.ml
|
|
===================================================================
|
|
--- otherlibs/labltk/browser/searchid.ml (リビジョン 11207)
|
|
+++ otherlibs/labltk/browser/searchid.ml (作業コピー)
|
|
@@ -101,7 +101,7 @@
|
|
|
|
let rec equal ~prefix t1 t2 =
|
|
match (repr t1).desc, (repr t2).desc with
|
|
- Tvar, Tvar -> true
|
|
+ Tvar _, Tvar _ -> true
|
|
| Tvariant row1, Tvariant row2 ->
|
|
let row1 = row_repr row1 and row2 = row_repr row2 in
|
|
let fields1 = filter_row_fields false row1.row_fields
|
|
@@ -144,7 +144,7 @@
|
|
|
|
let rec included ~prefix t1 t2 =
|
|
match (repr t1).desc, (repr t2).desc with
|
|
- Tvar, _ -> true
|
|
+ Tvar _, _ -> true
|
|
| Tvariant row1, Tvariant row2 ->
|
|
let row1 = row_repr row1 and row2 = row_repr row2 in
|
|
let fields1 = filter_row_fields false row1.row_fields
|