re-merci Alain

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

5 files changed, 29 insertions, 25 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index 60e1c45dd8..576fea048b 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -836,16 +836,6 @@ let rec copy_sep fixed free bound visited ty =
     let copy_rec = copy_sep fixed free bound visited in
     t.desc <-
       begin match ty.desc with
-      | Tconstr (p, tl, _) ->
-          begin match find_repr p !(!abbreviations) with
-            Some ty when repr ty != t ->
-              Tlink ty
-          | _ ->
-              Tconstr (p, List.map copy_rec tl,
-                       ref (match !(!abbreviations) with
-                              Mcons _ -> Mlink !abbreviations
-                            | abbrev  -> abbrev))
-          end
       | Tvariant row0 ->
           let row = row_repr row0 in
           let more = repr row.row_more in
@@ -1379,12 +1369,24 @@ and unify3 env t1 t1' t2 t2' =
     | (Tpoly (t1, []), Tpoly (t2, [])) ->
 	unify env t1 t2
     | (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
+        if List.length tl1 <> List.length tl2 then raise (Unify []);
 	let old_univars = !univar_pairs in
 	let cl1 = List.map (fun t -> t, ref None) tl1
 	and cl2 = List.map (fun t -> t, ref None) tl2 in
 	univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
 	begin try
-	  unify env t1 t2; univar_pairs := old_univars
+	  unify env t1 t2;
+          let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
+          List.iter
+            (fun t1 ->
+              if List.memq t1 tl2 then () else
+              try
+                let t2 =
+                  List.find (fun t2 -> not (List.memq (repr t2) tl1)) tl2 in
+                t2.desc <- Tlink t1
+              with Not_found -> assert false)
+            tl1;
+          univar_pairs := old_univars
 	with exn ->
 	  univar_pairs := old_univars; raise exn
 	end
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 9ef2b7c4a4..0a63dc632e 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -380,7 +380,7 @@ let full_match tdefs force env =  match env with
         env
     in
     let row = Btype.row_repr row in
-    if force then begin
+    if force && not row.row_fixed then begin
       (* force=true, we are called from check_partial, and must close *)
       let (ok, nm) =
         List.fold_left
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 64f41806ba..ebb6a23e9b 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -219,7 +219,7 @@ let rec tree_of_typexp sch ty =
   let ty = repr ty in
   let px = proxy ty in
   if List.mem_assq px !names && not (List.memq px !delayed) then
-   let mark = if ty.desc = Tvar then is_non_gen sch px else false in
+   let mark = is_non_gen sch px in
    Otyp_var (mark, name_of_type px) else
 
   let pr_typ () =
@@ -281,7 +281,7 @@ let rec tree_of_typexp sch ty =
             Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
         end
     | Tobject (fi, nm) ->
-        tree_of_typobject sch ty fi nm
+        tree_of_typobject sch fi nm
     | Tsubst ty ->
         tree_of_typexp sch ty
     | Tlink _ | Tnil | Tfield _ ->
@@ -318,7 +318,7 @@ and tree_of_typlist sch = function
       let tr = tree_of_typexp sch ty in
       tr :: tree_of_typlist sch tyl
 
-and tree_of_typobject sch ty fi nm =
+and tree_of_typobject sch fi nm =
   begin match !nm with
   | None ->
       let pr_fields fi =
@@ -335,8 +335,8 @@ and tree_of_typobject sch ty fi nm =
         tree_of_typfields sch rest sorted_fields in
       let (fields, rest) = pr_fields fi in
       Otyp_object (fields, rest)
-  | Some (p, _ :: tyl) ->
-      let non_gen = is_non_gen sch ty in
+  | Some (p, ty :: tyl) ->
+      let non_gen = is_non_gen sch (repr ty) in
       let args = tree_of_typlist sch tyl in
       Otyp_class (non_gen, tree_of_path p, args)
   | _ ->
@@ -344,15 +344,14 @@ and tree_of_typobject sch ty fi nm =
   end
 
 and is_non_gen sch ty =
-    sch && ty.level <> generic_level
+    sch && ty.desc = Tvar && ty.level <> generic_level
 
 and tree_of_typfields sch rest = function
   | [] ->
       let rest =
         match rest.desc with
-        | Tvar -> Some (is_non_gen sch rest)
+        | Tvar | Tunivar -> Some (is_non_gen sch rest)
         | Tnil -> None
-        | Tunivar -> Some false
         | _ -> fatal_error "typfields (1)"
       in
       ([], rest)
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index d4f73964ae..1c8df9692a 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -288,11 +288,14 @@ let rec transl_type env policy rowvar styp =
             ty
         | _ ->
             raise(Error(styp.ptyp_loc, Bound_type_variable alias))
-      else if Tbl.mem alias !type_variables then
-        raise(Error(styp.ptyp_loc, Bound_type_variable alias))
       else
-        let ty' = new_global_var () in
-        type_variables := Tbl.add alias ty' !type_variables;
+        let ty' =
+          try Tbl.find alias !type_variables
+          with Not_found ->
+            let t = new_global_var () in
+            type_variables := Tbl.add alias t !type_variables;
+            t
+        in
         let ty = transl_type env policy None st in
         begin try unify_var env ty' ty with Unify trace ->
           let trace = swap_list trace in
diff --git a/utils/config.mlp b/utils/config.mlp
index 500e26b076..f67b78c20b 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "3.04+1 with explicit polymorphism (2002-02-05)"
+let version = "3.04+1 with explicit polymorphism (2002-01-07)"
 
 let standard_library =
   try