From d13715755ccf9a4c7e305ee8ede0ac1be3550ac1 Mon Sep 17 00:00:00 2001 From: Jacques Garrigue Date: Mon, 10 Jun 2002 02:39:35 +0000 Subject: [PATCH] clean-up of universal and recursive types git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4912 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- stdlib/sys.ml | 2 +- typing/ctype.mli | 2 +- typing/printtyp.ml | 14 +++++-------- typing/typecore.ml | 2 +- typing/typetexp.ml | 52 +++++++++++++++++++++++----------------------- 5 files changed, 34 insertions(+), 38 deletions(-) diff --git a/stdlib/sys.ml b/stdlib/sys.ml index 577746fe5..3a3d3c57a 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -78,4 +78,4 @@ let catch_break on = (* OCaml version string, moved from utils/config.mlp. Must be in the format described in sys.mli. *) -let ocaml_version = "3.04+13 (2002-06-05)" +let ocaml_version = "3.04+14 (2002-06-10)" diff --git a/typing/ctype.mli b/typing/ctype.mli index 1043bb017..b4a0e5753 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -142,7 +142,7 @@ val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr (* A special case of unification (with {m : 'a; 'b}). *) val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit (* A special case of unification (with {m : 'a; 'b}), returning unit. *) -val occur: Env.t -> type_expr -> type_expr -> unit +val deep_occur: type_expr -> type_expr -> bool val filter_self_method: Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref -> type_expr -> Ident.t * type_expr diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 5447fa925..7f2f16f2e 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -534,15 +534,11 @@ let prepare_class_field ty = let rec prepare_class_type params = function | Tcty_constr (p, tyl, cty) -> let sty = Ctype.self_type cty in - begin try - if List.memq sty !visited_objects - || List.exists (fun ty -> (repr ty).desc <> Tvar) params - then raise (Unify []); - List.iter (occur Env.empty sty) tyl; - List.iter mark_loops tyl - with Unify _ -> - prepare_class_type params cty - end + if List.memq sty !visited_objects + || List.exists (fun ty -> (repr ty).desc <> Tvar) params + || List.exists (deep_occur sty) tyl + then prepare_class_type params cty + else List.iter mark_loops tyl | Tcty_signature sign -> let sty = repr sign.cty_self in (* Self may have a name *) diff --git a/typing/typecore.ml b/typing/typecore.ml index 968525a23..f97d31b36 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -695,7 +695,7 @@ let rec type_approx env sexp = (* List labels in a function type, and whether return type is a variable *) let rec list_labels_aux env visited ls ty_fun = let ty = expand_head env ty_fun in - if !Clflags.recursive_types && List.memq ty visited then + if List.memq ty visited then List.rev ls, false else match ty.desc with Tarrow (l, _, ty_res, _) -> diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 2239e0f81..f49fb0ac8 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -241,9 +241,9 @@ let rec transl_type env policy rowvar styp = present; let bound = ref row.row_bound in let fixed = rowvar <> None || policy = Univars in - let static = List.length row.row_fields = 1 in + let single = List.length row.row_fields = 1 in let fields = - if static then row.row_fields else + if single then row.row_fields else List.map (fun (l,f) -> l, if List.mem l present then f else @@ -256,22 +256,17 @@ let rec transl_type env policy rowvar styp = | _ -> f) row.row_fields in - let row = { row_closed = true; - row_fields = fields; - row_bound = !bound; - row_name = Some (path, args); - row_fixed = fixed; - row_more = match rowvar with - Some v -> - if static then - raise(Error(styp.ptyp_loc, - No_row_variable "variant ")); - v - | None -> - if static then newty Tnil else - if policy = Univars then new_pre_univar () - else newvar () } - in newty (Tvariant row) + let row = { row_closed = true; row_fields = fields; + row_bound = !bound; row_name = Some (path, args); + row_fixed = fixed; row_more = newvar () } in + let static = Btype.static_row row in + let row = + if static then row else + { row with row_more = match rowvar with Some v -> v + | None -> + if policy = Univars then new_pre_univar () + else newvar () } in + newty (Tvariant row) | Tobject (fi, _) -> let _, tv = flatten_fields fi in if policy = Univars then pre_univars := tv :: !pre_univars; @@ -335,10 +330,12 @@ let rec transl_type env policy rowvar styp = instance t end | Ptyp_variant(fields, closed, present) -> + if rowvar <> None && present = None && closed then + raise (Error(styp.ptyp_loc, No_row_variable "variant ")); let bound = ref [] and name = ref None in let fixed = rowvar <> None || policy = Univars in let mkfield l f = - newty (Tvariant {row_fields=[l,f]; row_more=newty Tnil; + newty (Tvariant {row_fields=[l,f]; row_more=newvar(); row_bound=[]; row_closed=true; row_fixed=fixed; row_name=None}) in let add_typed_field loc l f fields = @@ -429,14 +426,9 @@ let rec transl_type env policy rowvar styp = row_fixed = fixed; row_name = !name } in let static = Btype.static_row row in let row = - { row with row_more = - match rowvar with - Some v -> - if static then - raise(Error(styp.ptyp_loc, No_row_variable "variant ")); - v + if static then row else + { row with row_more = match rowvar with Some v -> v | None -> - if static then newty Tnil else if policy = Univars then new_pre_univar () else if policy = Fixed && not static then raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]")) @@ -452,6 +444,7 @@ let rec transl_type env policy rowvar styp = univars := new_univars @ !univars; let ty = transl_type env policy None st in univars := old_univars; + let ty_list = List.filter (fun tu -> deep_occur (repr tu) ty) ty_list in newty (Tpoly(ty, ty_list)) and transl_fields env policy rowvar = @@ -493,6 +486,13 @@ let transl_simple_type_univars env styp = [] !pre_univars in pre_univars := []; + (* add this code to allow reuse of variable names + Tbl.iter + (fun name ty -> + if List.exists (fun tu -> repr ty == repr tu) univs + then type_variables := Tbl.remove name !type_variables) + !type_variables; + *) instance (Btype.newgenty (Tpoly (typ, univs))) let transl_simple_type_delayed env styp =