From 50fc257b4c73bbc1559bd520d00a762eaca5cf5c Mon Sep 17 00:00:00 2001
From: Jacques Garrigue <garrigue at math.nagoya-u.ac.jp>
Date: Fri, 16 Nov 2001 07:26:56 +0000
Subject: [PATCH] fix PR#632 (incorrect generalization of variants in classes)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@4015 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 typing/ctype.ml    | 30 +++++++++++++++++-------------
 typing/typetexp.ml |  2 +-
 utils/config.mlp   |  2 +-
 3 files changed, 19 insertions(+), 15 deletions(-)

diff --git a/typing/ctype.ml b/typing/ctype.ml
index b67120cf8..78139055d 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -595,7 +595,12 @@ let limited_generalize ty0 ty =
       if (ty.level = generic_level) || (ty == ty0) then
         roots := ty :: !roots;
       ty.level <- !idx;
-      iter_type_expr (inverse [ty]) ty
+      let pty' =
+        match ty.desc with
+          Tvariant row -> [ty; row_more row]
+        | _ -> [ty]
+      in
+      iter_type_expr (inverse pty') ty
     end else if ty.level < lowest_level then begin
       let (_, parents) = Hashtbl.find graph ty.level in
       parents := pty @ !parents
@@ -706,10 +711,14 @@ let rec copy ty =
               (* This variant type has been already copied *)
               ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
               Tlink ty2
+          | _ when more.level <> generic_level ->
+              (* If the row variable is not generic, do nothing *)
+              Tvariant row0
           | _ ->
-              (* We shall really check the level on the row variable *)
-              if more.level <> generic_level then Tvariant row0 else
-              (* We create a new copy *)
+              (* Register new type first for recursion *)
+              save_desc more more.desc;
+              more.desc <- ty.desc;
+              (* Create a new copy *)
               let fields =
                 List.map
                   (fun (l,fi) -> l,
@@ -720,16 +729,11 @@ let rec copy ty =
                     | fi -> fi)
                   row.row_fields
               and name =
-                may_map (fun (p,l) -> p, List.map copy l) row.row_name in
-              let var =
-                Tvariant { row_fields = fields; row_more = newvar();
-                           row_bound = List.map copy row.row_bound;
-                           row_closed = row.row_closed; row_name = name }
+                may_map (fun (p,l) -> p, List.map copy l) row.row_name
               in
-              (* Remember it for other occurences *)
-              save_desc more more.desc;
-              more.desc <- ty.desc;
-              var
+              Tvariant { row_fields = fields; row_more = newvar();
+                         row_bound = List.map copy row.row_bound;
+                         row_closed = row.row_closed; row_name = name }
           end
       | Tfield (label, kind, t1, t2) ->
           begin match field_kind_repr kind with
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 64ec21687..42ce1b89a 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -375,7 +375,7 @@ let report_error ppf = function
         but is here applied to %i argument(s)@]"
        longident lid expected provided
   | Bound_type_variable name ->
-      fprintf ppf "Already bound type parameter %s" name
+      fprintf ppf "Already bound type parameter '%s" name
   | Recursive_type ->
       fprintf ppf "This type is recursive"
   | Unbound_class lid ->
diff --git a/utils/config.mlp b/utils/config.mlp
index c8411052a..7a1fc3a4c 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-let version = "3.03 ALPHA+3 (2001-11-05)"
+let version = "3.03 ALPHA+4 (2001-11-16)"
 
 let standard_library =
   try