From e5d0fb17867953602577f56c8cb5cbed528ed500 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Sat, 23 Jul 2011 11:24:31 +0000 Subject: [PATCH] patch for keeping variable names git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11145 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- .../garrigue/variable-names-Tvar.diffs | 1614 +++++++++++++++++ experimental/garrigue/variable-names.ml | 4 + 2 files changed, 1618 insertions(+) create mode 100644 experimental/garrigue/variable-names-Tvar.diffs create mode 100644 experimental/garrigue/variable-names.ml diff --git a/experimental/garrigue/variable-names-Tvar.diffs b/experimental/garrigue/variable-names-Tvar.diffs new file mode 100644 index 000000000..1c1675a5a --- /dev/null +++ b/experimental/garrigue/variable-names-Tvar.diffs @@ -0,0 +1,1614 @@ +Index: boot/ocamlc +=================================================================== +Cannot display: file marked as a binary type. +svn:mime-type = application/octet-stream +Index: typing/typemod.ml +=================================================================== +--- typing/typemod.ml (revision 11143) ++++ typing/typemod.ml (working copy) +@@ -761,7 +761,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 (revision 11143) ++++ typing/typetexp.ml (working copy) +@@ -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 (revision 11143) ++++ typing/btype.ml (working copy) +@@ -30,9 +30,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 } +@@ -41,6 +41,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 = +@@ -134,7 +139,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 +@@ -175,13 +180,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 +@@ -193,7 +198,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 + +@@ -234,13 +239,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) +@@ -253,7 +258,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) +@@ -438,7 +443,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 +@@ -465,7 +470,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 (revision 11143) ++++ typing/typecore.ml (working copy) +@@ -534,7 +534,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)) + end; +@@ -975,7 +975,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 + +@@ -991,9 +991,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')) +@@ -1007,7 +1008,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 +@@ -1438,7 +1439,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) +@@ -1493,7 +1494,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 +@@ -1650,7 +1651,7 @@ + } + in + +- let ty = newvar () in ++ let ty = newvar ~name () in + Ident.set_current_time ty.level; + let (id, new_env) = Env.enter_type name decl env in + Ctype.init_def(Ident.current_time()); +@@ -1745,7 +1746,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 +@@ -1807,7 +1808,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 +@@ -1946,7 +1947,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; +@@ -2187,7 +2188,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)) +@@ -2223,9 +2224,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 (revision 11143) ++++ typing/btype.mli (working copy) +@@ -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 (revision 11143) ++++ typing/ctype.mli (working copy) +@@ -40,9 +40,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/typeclass.ml +=================================================================== +--- typing/typeclass.ml (revision 11143) ++++ typing/typeclass.ml (working copy) +@@ -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 (revision 11143) ++++ typing/typedecl.ml (working copy) +@@ -109,7 +109,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) + +@@ -463,7 +463,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 +@@ -526,7 +526,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) +Index: typing/types.mli +=================================================================== +--- typing/types.mli (revision 11143) ++++ typing/types.mli (working copy) +@@ -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 (revision 11143) ++++ typing/ctype.ml (working copy) +@@ -145,17 +145,17 @@ + + (* Re-export generic type creators *) + +-let newty2 = Btype.newty2 +-let newty desc = newty2 !current_level desc +-let new_global_ty desc = newty2 !global_level desc ++let newty2 = Btype.newty2 ++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)) ++let newobj fields = newty (Tobject (fields, ref None)) + +-let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) ++let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) + + let none = newty (Ttuple []) (* Clearly ill-formed type *) + +@@ -236,10 +236,8 @@ + + let opened_object ty = + match (object_row ty).desc with +- | Tvar -> true +- | Tunivar -> true +- | Tconstr _ -> true +- | _ -> false ++ | Tvar _ | Tunivar _ | Tconstr _ -> true ++ | _ -> false + + (**** Close an object ****) + +@@ -247,7 +245,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 +@@ -263,7 +261,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 +@@ -368,7 +366,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 +@@ -402,7 +400,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 +@@ -567,7 +565,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; +@@ -818,7 +816,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 +@@ -943,7 +941,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 +@@ -974,7 +972,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 +@@ -991,14 +989,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 +@@ -1238,7 +1236,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 +@@ -1393,8 +1391,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 +@@ -1443,7 +1441,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, _) -> +@@ -1530,29 +1528,30 @@ + with Occur -> + unmark_type ty; true + ++ + (* +- 1. When unifying two non-abbreviated types, one type is made a link +- to the other. When unifying an abbreviated type with a +- non-abbreviated type, the non-abbreviated type is made a link to +- the other one. When unifying to abbreviated types, these two +- types are kept distincts, but they are made to (temporally) +- expand to the same type. +- 2. Abbreviations with at least one parameter are systematically +- expanded. The overhead does not seem to high, and that way +- abbreviations where some parameters does not appear in the +- expansion, such as ['a t = int], are correctly handled. In +- particular, for this example, unifying ['a t] with ['b t] keeps +- ['a] and ['b] distincts. (Is it really important ?) +- 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield +- ['a t as 'a]. Indeed, the type variable would otherwise be lost. +- This problem occurs for abbreviations expanding to a type +- variable, but also to many other constrained abbreviations (for +- instance, [(< x : 'a > -> unit) t = ]). The solution is +- that, if an abbreviation is unified with some subpart of its +- parameters, then the parameter actually does not get +- abbreviated. It would be possible to check whether some +- information is indeed lost, but it probably does not worth it. +-*) ++ 1. When unifying two non-abbreviated types, one type is made a link ++ to the other. When unifying an abbreviated type with a ++ non-abbreviated type, the non-abbreviated type is made a link to ++ the other one. When unifying to abbreviated types, these two ++ types are kept distincts, but they are made to (temporally) ++ expand to the same type. ++ 2. Abbreviations with at least one parameter are systematically ++ expanded. The overhead does not seem to high, and that way ++ abbreviations where some parameters does not appear in the ++ expansion, such as ['a t = int], are correctly handled. In ++ particular, for this example, unifying ['a t] with ['b t] keeps ++ ['a] and ['b] distincts. (Is it really important ?) ++ 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield ++ ['a t as 'a]. Indeed, the type variable would otherwise be lost. ++ This problem occurs for abbreviations expanding to a type ++ variable, but also to many other constrained abbreviations (for ++ instance, [(< x : 'a > -> unit) t = ]). The solution is ++ that, if an abbreviation is unified with some subpart of its ++ parameters, then the parameter actually does not get ++ abbreviated. It would be possible to check whether some ++ information is indeed lost, but it probably does not worth it. ++ *) + let rec unify env t1 t2 = + (* First step: special cases (optimizations) *) + if t1 == t2 then () else +@@ -1563,19 +1562,19 @@ + 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; + 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; + link_type t2 t1 +- | (Tunivar, Tunivar) -> ++ | (Tunivar _, Tunivar _) -> + unify_univar t1 t2 !univar_pairs; + update_level env t1.level t2; + link_type t1 t2 +@@ -1624,9 +1623,9 @@ + + try + begin match (d1, d2) with +- (Tvar, _) -> ++ (Tvar _, _) -> + occur_univar env t2 +- | (_, Tvar) -> ++ | (_, Tvar _) -> + let td1 = newgenty d1 in + occur env t2' td1; + occur_univar env td1; +@@ -1659,7 +1658,8 @@ + (* 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] -> ++ when (match (repr va).desc with Tvar _|Tunivar _|Tnil -> true ++ | _ -> false) -> + () + | Tobject (_, nm2) -> + set_name nm2 !nm1 +@@ -1732,16 +1732,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; +@@ -1785,11 +1801,9 @@ + with Not_found -> ()) + r2 + end; +- let more = +- if row1.row_fixed then rm1 else +- if row2.row_fixed then rm2 else +- newgenvar () +- in update_level env (min rm1.level rm2.level) more; ++ let level = min rm1.level rm2.level in ++ let more = make_rowvar level row1.row_fixed rm1 row2.row_fixed rm2 in ++ update_level env level more; + let fixed = row1.row_fixed || row2.row_fixed + and closed = row1.row_closed || row2.row_closed in + let keep switch = +@@ -1832,7 +1846,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 +@@ -1912,7 +1926,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; +@@ -1945,7 +1959,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 +@@ -1961,7 +1975,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, +@@ -1988,7 +2002,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'; +@@ -2024,7 +2038,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 -> +@@ -2054,9 +2068,9 @@ + + try + match (t1.desc, t2.desc) with +- (Tunivar, Tunivar) -> ++ (Tunivar _, Tunivar _) -> + unify_univar t1 t2 !univar_pairs +- | (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 +@@ -2073,7 +2087,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 +@@ -2139,7 +2153,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 +@@ -2149,9 +2163,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 -> +@@ -2242,13 +2256,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; +@@ -2271,7 +2285,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' = +@@ -2310,7 +2324,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 []) +@@ -2331,7 +2345,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 []) +@@ -2363,7 +2377,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 []) +@@ -2806,7 +2820,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 +@@ -2855,13 +2869,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); +@@ -2960,7 +2974,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 = +@@ -3024,7 +3038,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) -> +@@ -3060,7 +3074,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, _)) -> +@@ -3132,7 +3146,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) -> +@@ -3146,7 +3160,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 +@@ -3190,19 +3204,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 +@@ -3276,7 +3290,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) +@@ -3318,7 +3332,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 -> +@@ -3388,7 +3402,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 (revision 11143) ++++ typing/printtyp.ml (working copy) +@@ -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 "@[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 "@[Tpoly(@,%a,@,%a)@]" + raw_type t +@@ -187,28 +191,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) +@@ -223,9 +260,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 && +@@ -243,7 +284,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 +@@ -288,7 +329,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; +@@ -320,7 +361,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 = +@@ -385,16 +426,25 @@ + | Tpoly (ty, []) -> + tree_of_typexp sch ty + | Tpoly (ty, tyl) -> ++ let print_names () = ++ List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; ++ prerr_string "; " in ++ print_names (); + 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 *) ++ print_names (); ++ remove_names tyl; ++ print_names (); prerr_endline ""; + 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) +@@ -444,13 +494,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)" +@@ -556,7 +606,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, +@@ -632,16 +682,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 + +@@ -649,7 +701,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 +@@ -662,7 +714,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; +@@ -673,7 +725,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 +@@ -730,7 +782,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 +@@ -877,7 +929,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') = +@@ -900,9 +952,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 + +@@ -918,21 +970,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, _, _), Tvar ++ | Tconstr (p, _, _), Tvar _ + when unif && t4.level < Path.binding_time p -> + fprintf ppf + "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p +- | Tvar, Tconstr (p, _, _) ++ | Tvar _, Tconstr (p, _, _) + when unif && 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 (revision 11143) ++++ typing/includecore.ml (working copy) +@@ -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 = +@@ -243,7 +243,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 (revision 11143) ++++ typing/subst.ml (working copy) +@@ -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 (revision 11143) ++++ typing/types.ml (working copy) +@@ -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 (revision 11143) ++++ ocamldoc/odoc_str.ml (working copy) +@@ -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 (revision 11143) ++++ ocamldoc/odoc_value.ml (working copy) +@@ -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 (revision 11143) ++++ ocamldoc/odoc_misc.ml (working copy) +@@ -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 (revision 11143) ++++ bytecomp/typeopt.ml (working copy) +@@ -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 (revision 11143) ++++ bytecomp/translcore.ml (working copy) +@@ -787,12 +787,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: toplevel/genprintval.ml +=================================================================== +--- toplevel/genprintval.ml (revision 11143) ++++ toplevel/genprintval.ml (working copy) +@@ -180,7 +180,7 @@ + find_printer env ty obj + with Not_found -> + match (Ctype.repr ty).desc with +- | Tvar -> ++ | Tvar _ | Tunivar _ -> + Oval_stuff "" + | Tarrow(_, ty1, ty2, _) -> + Oval_stuff "" +@@ -318,8 +318,6 @@ + fatal_error "Printval.outval_of_value" + | Tpoly (ty, _) -> + tree_of_val (depth - 1) obj ty +- | Tunivar -> +- Oval_stuff "" + | Tpackage _ -> + Oval_stuff "" + end +Index: otherlibs/labltk/browser/searchid.ml +=================================================================== +--- otherlibs/labltk/browser/searchid.ml (revision 11143) ++++ otherlibs/labltk/browser/searchid.ml (working copy) +@@ -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 diff --git a/experimental/garrigue/variable-names.ml b/experimental/garrigue/variable-names.ml new file mode 100644 index 000000000..f3c7771a7 --- /dev/null +++ b/experimental/garrigue/variable-names.ml @@ -0,0 +1,4 @@ +let f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);; +let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);; +let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);; +let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);;