diff options
Diffstat (limited to 'typing/subst.ml')
| -rw-r--r-- | typing/subst.ml | 61 |
1 files changed, 40 insertions, 21 deletions
diff --git a/typing/subst.ml b/typing/subst.ml index 45fe325756..66646c157c 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -22,25 +22,20 @@ open Btype type t = { types: (Ident.t, Path.t) Tbl.t; modules: (Ident.t, Path.t) Tbl.t; - modtypes: (Ident.t, module_type) Tbl.t } + modtypes: (Ident.t, module_type) Tbl.t; + for_saving: bool } let identity = - { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty } + { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty; + for_saving = false } -let add_type id p s = - { types = Tbl.add id p s.types; - modules = s.modules; - modtypes = s.modtypes } +let add_type id p s = { s with types = Tbl.add id p s.types } -let add_module id p s = - { types = s.types; - modules = Tbl.add id p s.modules; - modtypes = s.modtypes } +let add_module id p s = { s with modules = Tbl.add id p s.modules } -let add_modtype id ty s = - { types = s.types; - modules = s.modules; - modtypes = Tbl.add id ty s.modtypes } +let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes } + +let for_saving s = { s with for_saving = true } let rec module_path s = function Pident id as p -> @@ -58,12 +53,23 @@ let type_path s = function | Papply(p1, p2) -> fatal_error "Subst.type_path" +(* Special type ids for saved signatures *) + +let new_id = ref (-1) +let reset_for_saving () = new_id := -1 + +let newpersty desc = + 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 -> - ty + if s.for_saving then + let ty' = newpersty ty.desc in + save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty' + else ty | Tsubst ty -> ty (* cannot do it, since it would omit subsitution @@ -73,7 +79,8 @@ let rec typexp s ty = | _ -> let desc = ty.desc in save_desc ty desc; - let ty' = newgenvar () in (* Stub *) + (* Make a stub *) + let ty' = if s.for_saving then newpersty Tvar else newgenvar () in ty.desc <- Tsubst ty'; ty'.desc <- begin match desc with @@ -90,18 +97,27 @@ let rec typexp s ty = let more = repr row.row_more in (* We must substitute in a subtle way *) begin match more.desc with - Tsubst ty2 -> + Tsubst ({desc=Tvariant _} as ty2) -> (* This variant type has been already copied *) ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) Tlink ty2 | _ -> let static = static_row row in + (* Various cases for the row variable *) + let more' = + match more.desc with Tsubst ty -> ty + | _ -> + if s.for_saving then newpersty more.desc else + if static then newgenvar () else more + in (* Register new type first for recursion *) save_desc more more.desc; more.desc <- ty.desc; - let more' = if static then newgenvar () else more in (* Return a new copy *) - let row = copy_row (typexp s) true row true more' in + let row = + copy_row (typexp s) true row (not s.for_saving) more' in + let row = + if s.for_saving then {row with row_bound = []} else row in match row.row_name with Some (p, tl) -> Tvariant {row with row_name = Some (type_path s p, tl)} @@ -115,6 +131,7 @@ let rec typexp s ty = | Fabsent -> Tlink (typexp s t2) | Fvar _ (* {contents = None} *) as k -> + let k = if s.for_saving then Fvar(ref None) else k in Tfield(label, k, typexp s t1, typexp s t2) end | _ -> copy_type_desc (typexp s) desc @@ -183,7 +200,8 @@ let class_declaration s decl = | Some ty -> Some (typexp s ty) end } in - cleanup_types (); + (* Do not clean up if saving: next is cltype_declaration *) + if not s.for_saving then cleanup_types (); decl let cltype_declaration s decl = @@ -192,7 +210,8 @@ let cltype_declaration s decl = clty_type = class_type s decl.clty_type; clty_path = type_path s decl.clty_path } in - cleanup_types (); + (* Do not clean up if saving: next is type_declaration *) + if not s.for_saving then cleanup_types (); decl let class_type s cty = |