diff options
| -rw-r--r-- | typing/ctype.ml | 15 | ||||
| -rw-r--r-- | typing/typedecl.ml | 28 | ||||
| -rw-r--r-- | utils/config.mlp | 2 |
3 files changed, 30 insertions, 15 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml index 5d32b989e..3e0c39c9e 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -988,31 +988,32 @@ exception Occur (* The marks are already used by [expand_abbrev]... *) let visited = ref [] -let rec non_recursive_abbrev env ty = +let rec non_recursive_abbrev env ty0 ty = let ty = repr ty in - if ty == none then raise Recursive_abbrev; + if ty == repr ty0 then raise Recursive_abbrev; if not (List.memq ty !visited) then begin let level = ty.level in visited := ty :: !visited; match ty.desc with Tconstr(p, args, abbrev) -> begin try - non_recursive_abbrev env (try_expand_head env ty) + non_recursive_abbrev env ty0 (try_expand_head env ty) with Cannot_expand -> - iter_type_expr (non_recursive_abbrev env) ty + iter_type_expr (non_recursive_abbrev env ty0) ty end | Tobject _ | Tvariant _ -> () | _ -> - iter_type_expr (non_recursive_abbrev env) ty + iter_type_expr (non_recursive_abbrev env ty0) ty end let correct_abbrev env ident params ty = if not !Clflags.recursive_types then begin + let ty0 = newgenvar () in visited := []; - non_recursive_abbrev env + non_recursive_abbrev env ty0 (subst env generic_level - (ref (Mcons (Path.Pident ident, none, none, Mnil))) None + (ref (Mcons (Path.Pident ident, ty0, ty0, Mnil))) None [] [] ty); visited := [] end diff --git a/typing/typedecl.ml b/typing/typedecl.ml index d69d44cf8..984bab486 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -48,10 +48,22 @@ let enter_type env (name, sdecl) id = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; - type_manifest = None } + type_manifest = + match sdecl.ptype_manifest with None -> None + | Some _ -> Some(Ctype.newvar ()) } in Env.add_type id decl env +let update_type temp_env env id loc = + let path = Path.Pident id in + let decl = Env.find_type path temp_env in + match decl.type_manifest with None -> () + | Some ty -> + let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + try Ctype.unify env (Ctype.newconstr path params) ty + with Ctype.Unify trace -> + raise (Error(loc, Type_clash trace)) + (* Determine if a type is (an abbreviation for) the type "float" *) let is_float env ty = @@ -178,9 +190,7 @@ let rec check_constraints_rec env loc visited ty = end; Ctype.end_def (); Ctype.generalize ty'; - let targs = Btype.newgenty (Ttuple args) - and targs' = Btype.newgenty (Ttuple args') in - if not (Ctype.moregeneral env false targs' targs) then + if not (List.for_all2 (Ctype.moregeneral env false) args' args) then raise (Error(loc, Constraint_failed (ty, ty'))); List.iter (check_constraints_rec env loc visited) args | _ -> @@ -321,15 +331,19 @@ let transl_type_decl env name_sdecl_list = (* Translate each declaration. *) let decls = List.map2 (transl_declaration temp_env) name_sdecl_list id_list in - (* Generalize type declarations. *) - Ctype.end_def(); - List.iter (function (_, decl) -> generalize_decl decl) decls; (* Build the final env. *) let newenv = List.fold_right (fun (id, decl) env -> Env.add_type id decl env) decls env in + (* Update stubs *) + List.iter2 + (fun id (_, sdecl) -> update_type temp_env newenv id sdecl.ptype_loc) + id_list name_sdecl_list; + (* Generalize type declarations. *) + Ctype.end_def(); + List.iter (fun (_, decl) -> generalize_decl decl) decls; (* Check for recursive abbrevs *) List.iter2 (check_recursive_abbrev newenv) name_sdecl_list decls; (* Check that all type variable are closed *) diff --git a/utils/config.mlp b/utils/config.mlp index b6627692f..fcc7854c9 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,7 +12,7 @@ (* $Id$ *) -let version = "3.00+9 (2000-07-08)" +let version = "3.00+10 (2000-08-04)" let standard_library = try |