autorise l'application d'une contrainte a un type en cours de definition

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3265 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

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