From 9c79ec9120f1de6bed2128fdcc6a62118cd0b2ee Mon Sep 17 00:00:00 2001
From: Jacques Garrigue <garrigue at math.nagoya-u.ac.jp>
Date: Fri, 21 May 2010 01:26:16 +0000
Subject: [PATCH] fix PR#5057, must adjust levels in row fields

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@10446 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
---
 Changes                                            |  1 +
 .../tests/typing-polyvariants-bugs/pr5057_ok.ml    | 14 ++++++++++++++
 .../tests/typing-polyvariants-bugs/pr5057a_bad.ml  |  7 +++++++
 typing/ctype.ml                                    |  8 +++++---
 4 files changed, 27 insertions(+), 3 deletions(-)
 create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml
 create mode 100644 testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml

diff --git a/Changes b/Changes
index 525ad8e46..44d56bf9f 100644
--- a/Changes
+++ b/Changes
@@ -93,6 +93,7 @@ All tools:
 - PR#4857: add a -vnum option to display the version number and nothing else
 
 Bug Fixes:
+- PR#5057: fatal typing error with local module + functor + polymorphic variant
 - PR#4742: finalisation function raising an exception blocks other finalisations
 - PR#4775: compiler crash on crazy types (temporary fix)
 - PR#4970: better error message for instance variables
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml
new file mode 100644
index 000000000..38df77058
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml
@@ -0,0 +1,14 @@
+(* PR5057 *)
+
+module TT = struct
+  module IntSet = Set.Make(struct type t = int let compare = compare end)
+end
+
+let () =
+  let f flag = 
+    let module T = TT in
+    let _ = match flag with `A -> 0 | `B r -> r in
+    let _ = match flag with `A -> T.IntSet.mem | `B r -> r in
+    ()
+  in
+  f `A
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml
new file mode 100644
index 000000000..35cc33863
--- /dev/null
+++ b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml
@@ -0,0 +1,7 @@
+(* This one should fail *)
+
+let f flag = 
+  let module T = Set.Make(struct type t = int let compare = compare end) in
+  let _ = match flag with `A -> 0 | `B r -> r in
+  let _ = match flag with `A -> T.mem | `B r -> r in
+  ()
diff --git a/typing/ctype.ml b/typing/ctype.ml
index fb4cc62b4..2186d47a2 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -1821,7 +1821,7 @@ and unify_row env row1 row2 =
     set_more row1 r2;
     List.iter
       (fun (l,f1,f2) ->
-        try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2
+        try unify_row_field env row1.row_fixed row2.row_fixed more l f1 f2
         with Unify trace ->
           raise (Unify ((mkvariant [l,f1] true,
                          mkvariant [l,f2] true) :: trace)))
@@ -1830,7 +1830,7 @@ and unify_row env row1 row2 =
     log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
   end
 
-and unify_row_field env fixed1 fixed2 l f1 f2 =
+and unify_row_field env fixed1 fixed2 more l f1 f2 =
   let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
   if f1 == f2 then () else
   match f1, f2 with
@@ -1847,13 +1847,15 @@ and unify_row_field env fixed1 fixed2 l f1 f2 =
             List.iter (unify env t1) tl;
             !e1 <> None || !e2 <> None
         end in
-      if redo then unify_row_field env fixed1 fixed2 l f1 f2 else
+      if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else
       let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
       let rec remq tl = function [] -> []
         | ty :: tl' ->
             if List.memq ty tl then remq tl tl' else ty :: remq tl tl'
       in
       let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in
+      (* Is this handling of levels really principal? *)
+      List.iter (update_level env (repr more).level) (tl1' @ tl2');
       let e = ref None in
       let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
       and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in