Fix PR#7348

Author: garrigue

Changes

@@ -685,6 +685,9 @@ The complete list of changes is listed below.
   bytecode compiler (even when not using Flambda)
   (Mark Shinwell, Leo White, code review by Pierre Chambart)
 
+- PR#7348: Private row variables can escape their scope
+  (Jacques Garrigue, report by Leo White)
+
 - PR#7407: Two not-quite-standard C idioms rejected by SUNWSPro compilers
   (Xavier Leroy)
 

testsuite/tests/typing-modules/pr7348.ml

@@ -0,0 +1,37 @@
+module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+  let x : < foo: int; ..> = X.x
+end;;
+[%%expect{|
+module F :
+  functor (X : sig type t = private < foo : int; .. > val x : t end) ->
+    sig val x : X.t end
+|}]
+
+module M = struct
+  type t = < foo: int; bar: int>
+  let x = object
+    method foo = 0
+    method bar = 0
+  end
+end;;
+[%%expect{|
+module M :
+  sig type t = < bar : int; foo : int > val x : < bar : int; foo : int > end
+|}]
+
+module N = F(M);;
+[%%expect{|
+module N : sig val x : M.t end
+|}]
+
+module A : sig end = struct
+  module F (X : sig type t = private < foo:int; ..> val x : t end) = struct
+    let x : < foo: int; ..> = X.x
+  end
+
+  module N = F(M)                
+  let _ = (N.x = M.x)
+end;;
+[%%expect{|
+module A : sig  end
+|}]

typing/btype.ml

@@ -59,6 +59,7 @@ let newmarkedgenvar () =
 
 let is_Tvar = function {desc=Tvar _} -> true | _ -> false
 let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false
+let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false
 
 let dummy_method = "*dummy method*"
 let default_mty = function
@@ -208,27 +209,31 @@ let proxy ty =
 
 (**** Utilities for fixed row private types ****)
 
-let has_constr_row t =
+let row_of_type t = 
   match (repr t).desc with
     Tobject(t,_) ->
-      let rec check_row t =
-        match (repr t).desc with
-          Tfield(_,_,_,t) -> check_row t
-        | Tconstr _ -> true
-        | _ -> false
-      in check_row t
+      let rec get_row t =
+        let t = repr t in
+        match t.desc with
+          Tfield(_,_,_,t) -> get_row t
+        | _ -> t
+      in get_row t
   | Tvariant row ->
-      (match row_more row with {desc=Tconstr _} -> true | _ -> false)
+      row_more row
   | _ ->
-      false
+      t
+
+let has_constr_row t =
+  not (is_Tconstr t) && is_Tconstr (row_of_type t)
 
 let is_row_name s =
   let l = String.length s in
   if l < 4 then false else String.sub s (l-4) 4 = "#row"
 
-let is_constr_row t =
+let is_constr_row ~allow_ident t =
   match t.desc with
-    Tconstr (Path.Pident id, _, _) -> is_row_name (Ident.name id)
+    Tconstr (Path.Pident id, _, _) when allow_ident ->
+      is_row_name (Ident.name id)
   | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s
   | _ -> false
 

typing/btype.mli

@@ -46,6 +46,7 @@ val newmarkedgenvar: unit -> type_expr
 
 val is_Tvar: type_expr -> bool
 val is_Tunivar: type_expr -> bool
+val is_Tconstr: type_expr -> bool
 val dummy_method: label
 val default_mty: module_type option -> module_type
 
@@ -80,9 +81,10 @@ val proxy: type_expr -> type_expr
            or a row variable *)
 
 (**** Utilities for private abbreviations with fixed rows ****)
+val row_of_type: type_expr -> type_expr
 val has_constr_row: type_expr -> bool
 val is_row_name: string -> bool
-val is_constr_row: type_expr -> bool
+val is_constr_row: allow_ident:bool -> type_expr -> bool
 
 (**** Utilities for type traversal ****)
 

typing/ctype.ml

@@ -4205,7 +4205,15 @@ let rec normalize_type_rec env visited ty =
   let ty = repr ty in
   if not (TypeSet.mem ty !visited) then begin
     visited := TypeSet.add ty !visited;
-    begin match ty.desc with
+    let tm = row_of_type ty in
+    begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then
+      match tm.desc with (* PR#7348 *)
+        Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) ->
+          let i' = String.sub i 0 (String.length i - 4) in
+          log_type ty;
+          ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil)
+      | _ -> assert false
+    else match ty.desc with
     | Tvariant row ->
       let row = row_repr row in
       let fields = List.map

typing/printtyp.ml

@@ -1330,7 +1330,8 @@ let rec filter_trace keep_last = function
       []
   | (t1, t1') :: (t2, t2') :: rem ->
       let rem' = filter_trace keep_last rem in
-      if is_constr_row t1' || is_constr_row t2'
+      if is_constr_row ~allow_ident:true t1'
+      || is_constr_row ~allow_ident:true t2'
       || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])
       then rem'
       else (t1, t1') :: (t2, t2') :: rem'

typing/subst.ml

@@ -139,11 +139,20 @@ let rec typexp s ty =
   | _ ->
     let desc = ty.desc in
     save_desc ty desc;
+    let tm = row_of_type ty in
+    let has_fixed_row =
+      not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in
     (* Make a stub *)
     let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in
     ty.desc <- Tsubst ty';
     ty'.desc <-
-      begin match desc with
+      begin if has_fixed_row then
+        match tm.desc with (* PR#7348 *)
+          Tconstr (Pdot(m,i,pos), tl, _abbrev) ->
+            let i' = String.sub i 0 (String.length i - 4) in
+            Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil)
+        | _ -> assert false
+      else match desc with
       | Tconstr(p, tl, _abbrev) ->
           Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
       | Tpackage(p, n, tl) ->