rename fixed types as privatefixedtypes

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

12 files changed, 88 insertions, 56 deletions

diff --git a/parsing/parser.mly b/parsing/parser.mly
index 02f94b2202..4e2505be01 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1158,8 +1158,8 @@ type_kind:
       { (Ptype_variant(List.rev $6, $4), Some $2) }
   | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE
       { (Ptype_record(List.rev $6, $4), Some $2) }
-  | AS core_type
-      { (Ptype_fixed, Some $2) }
+  | EQUAL PRIVATE core_type
+      { (Ptype_private, Some $3) }
 ;
 type_parameters:
     /*empty*/                                   { [] }
@@ -1218,8 +1218,8 @@ with_constraint:
       { ($2, Pwith_module $4) }
 ;
 with_type_binder:
-    EQUAL { Ptype_abstract }
-  | AS    { Ptype_fixed }
+    EQUAL          { Ptype_abstract }
+  | EQUAL PRIVATE  { Ptype_private }
 ;
 
 /* Polymorphic types */
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index d2ca899c9e..33a0e655b2 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -133,7 +133,7 @@ and type_kind =
   | Ptype_variant of (string * core_type list * Location.t) list * private_flag
   | Ptype_record of
       (string * mutable_flag * core_type * Location.t) list * private_flag
-  | Ptype_fixed
+  | Ptype_private
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index ae7094e5c4..986cb0f156 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -323,8 +323,8 @@ and type_kind i ppf x =
   | Ptype_record (l, priv) ->
       line i ppf "Ptype_record %a\n" fmt_private_flag priv;
       list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
-  | Ptype_fixed ->
-      line i ppf "Ptype_fixed\n"
+  | Ptype_private ->
+      line i ppf "Ptype_private\n"
 
 and exception_declaration i ppf x = list i core_type ppf x
 
diff --git a/typing/btype.ml b/typing/btype.ml
index caa0b43f2f..c92df0ffd6 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -138,6 +138,26 @@ let proxy ty =
       in proxy_obj ty
   | _ -> ty
 
+(**** Utilities for private types ****)
+
+let has_constr_row 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
+  | Tvariant row ->
+      (match row_more row with {desc=Tconstr _} -> true | _ -> false)
+  | _ ->
+      false
+
+let is_row_name s =
+  let l = String.length s in
+  if l < 4 then false else String.sub s (l-4) 4 = "#row"
+
 
                   (**********************************)
                   (*  Utilities for type traversal  *)
diff --git a/typing/btype.mli b/typing/btype.mli
index 02a3cc1c10..251bc1ef5a 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -59,6 +59,10 @@ val proxy: type_expr -> type_expr
         (* Return the proxy representative of the type: either itself
            or a row variable *)
 
+(**** Utilities for private types ****)
+val has_constr_row: type_expr -> bool
+val is_row_name: string -> bool
+
 (**** Utilities for type traversal ****)
 
 val iter_type_expr: (type_expr -> unit) -> type_expr -> unit
diff --git a/typing/ctype.ml b/typing/ctype.ml
index a1ef0fe165..05d147af51 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -2663,19 +2663,8 @@ let find_cltype_for_path env p =
       end
   | None -> assert false
 
-let has_constr_row env t =
-  match (expand_abbrev env 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
-  | Tvariant row ->
-      (match row_more row with {desc=Tconstr _} -> true | _ -> false)
-  | _ ->
-      false
+let has_constr_row' env t =
+  has_constr_row (expand_abbrev env t)
 
 let rec build_subtype env visited loops posi level t =
   let t = repr t in
@@ -2708,7 +2697,7 @@ let rec build_subtype env visited loops posi level t =
       if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c)
       else (t, Unchanged)
   | Tconstr(p, tl, abbrev)
-    when level > 0 && generic_abbrev env p && not (has_constr_row env t) ->
+    when level > 0 && generic_abbrev env p && not (has_constr_row' env t) ->
       let t' = repr (expand_abbrev env t) in
       let level' = pred_expand level in
       begin try match t'.desc with
@@ -2748,7 +2737,7 @@ let rec build_subtype env visited loops posi level t =
       let visited = t :: visited in
       begin try
         let decl = Env.find_type p env in
-        if level = 0 && generic_abbrev env p && not (has_constr_row env t)
+        if level = 0 && generic_abbrev env p && not (has_constr_row' env t)
         then warn := true;
         let tl' =
           List.map2
@@ -2882,10 +2871,10 @@ let rec subtype_rec env trace t1 t2 cstrs =
     | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
         cstrs
     | (Tconstr(p1, tl1, abbrev1), _)
-      when generic_abbrev env p1 && not (has_constr_row env t1) ->
+      when generic_abbrev env p1 && not (has_constr_row' env t1) ->
         subtype_rec env trace (expand_abbrev env t1) t2 cstrs
     | (_, Tconstr(p2, tl2, abbrev2))
-      when generic_abbrev env p2 && not (has_constr_row env t2) ->
+      when generic_abbrev env p2 && not (has_constr_row' env t2) ->
         subtype_rec env trace t1 (expand_abbrev env t2) cstrs
     | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
         begin try
diff --git a/typing/includecore.ml b/typing/includecore.ml
index ac09e2dbfd..b81774b2cd 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -45,9 +45,7 @@ let private_flags priv1 priv2 =
 let is_absrow env ty =
   match ty.desc with
     Tconstr(Pident id, _, _) ->
-      let s = Ident.name id in
-      let l = String.length s in
-      l >= 4 && String.sub s (l-4) 4 = "#row" &&
+      Btype.is_row_name (Ident.name id) &&
       begin match Ctype.expand_head env ty with
         {desc=Tobject _|Tvariant _} -> true
       | _ -> false
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 43ab1bdace..2ba92bef1a 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -358,7 +358,7 @@ and print_out_sig_item ppf =
       fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
         ty pr_prims prims
 
-and print_out_type_decl kwd ppf (name, args, ty, constraints) =
+and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
   let print_constraints ppf params =
     List.iter
       (fun (ty1, ty2) ->
@@ -394,19 +394,21 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
   | Otyp_abstract ->
       fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
         constraints
-  | Otyp_record (lbls, priv) ->
+  | Otyp_record lbls ->
       fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
         print_private priv
         (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
         print_constraints constraints
-  | Otyp_sum (constrs, priv) ->
+  | Otyp_sum constrs ->
       fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
         print_private priv
         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
         print_constraints constraints
   | ty ->
-      fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args !out_type
-        ty print_constraints constraints in
+      fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
+        print_private priv
+        !out_type ty
+        print_constraints constraints in
   print_out_tkind ty
 and print_out_constr ppf (name, tyl) =
   match tyl with
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 6347befdc3..c7031912be 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -52,9 +52,9 @@ type out_type =
   | Otyp_constr of out_ident * out_type list
   | Otyp_manifest of out_type * out_type
   | Otyp_object of (string * out_type) list * bool option
-  | Otyp_record of (string * bool * out_type) list * Asttypes.private_flag
+  | Otyp_record of (string * bool * out_type) list
   | Otyp_stuff of string
-  | Otyp_sum of (string * out_type list) list * Asttypes.private_flag
+  | Otyp_sum of (string * out_type list) list
   | Otyp_tuple of out_type list
   | Otyp_var of bool * string
   | Otyp_variant of
@@ -91,7 +91,7 @@ and out_sig_item =
   | Osig_type of out_type_decl * out_rec_status
   | Osig_value of string * out_type * string list
 and out_type_decl =
-  string * (string * (bool * bool)) list * out_type *
+  string * (string * (bool * bool)) list * out_type * Asttypes.private_flag *
   (out_type * out_type) list
 and out_rec_status =
   | Orec_not
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 0fc9a0b7d7..3cdf025606 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -531,9 +531,13 @@ let rec tree_of_type_decl id decl =
   let type_defined decl =
     let abstr =
       match decl.type_kind with
-        Type_abstract -> decl.type_manifest = None
-      | Type_variant(_,Private) | Type_record(_,_,Private) -> true
-      | _ -> false
+        Type_abstract ->
+          begin match decl.type_manifest with
+            None -> true
+          | Some ty -> has_constr_row ty
+          end
+      | Type_variant(_,p) | Type_record(_,_,p) ->
+          p = Private
     in
     let vari =
       List.map2
@@ -552,19 +556,21 @@ let rec tree_of_type_decl id decl =
   in
   let (name, args) = type_defined decl in
   let constraints = tree_of_constraints params in
-  let ty =
+  let ty, priv =
     match decl.type_kind with
     | Type_abstract ->
         begin match ty_manifest with
-        | None -> Otyp_abstract
-        | Some ty -> tree_of_typexp false ty
+        | None -> (Otyp_abstract, Public)
+        | Some ty ->
+            tree_of_typexp false ty, 
+            (if has_constr_row ty then Private else Public)
         end
     | Type_variant(cstrs, priv) ->
-        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs, priv))
+        tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), priv
     | Type_record(lbls, rep, priv) ->
-        tree_of_manifest (Otyp_record (List.map tree_of_label lbls, priv))
+        tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), priv
   in
-  (name, args, ty, constraints)
+  (name, args, ty, priv, constraints)
 
 and tree_of_constructor (name, args) =
   (name, tree_of_typlist false args)
@@ -778,6 +784,8 @@ and tree_of_signature = function
   | [] -> []
   | Tsig_value(id, decl) :: rem ->
       tree_of_value_description id decl :: tree_of_signature rem
+  | Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
+      tree_of_signature rem
   | Tsig_type(id, decl, rs) :: rem ->
       Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
       tree_of_signature rem
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 5550498683..bcf86e3695 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -127,7 +127,7 @@ let transl_declaration env (name, sdecl) id =
       type_arity = List.length params;
       type_kind =
         begin match sdecl.ptype_kind with
-          Ptype_abstract | Ptype_fixed ->
+          Ptype_abstract | Ptype_private ->
             Type_abstract
         | Ptype_variant (cstrs, priv) ->
             let all_constrs = ref StringSet.empty in
@@ -169,7 +169,7 @@ let transl_declaration env (name, sdecl) id =
           None -> None
         | Some sty ->
             let ty =
-              transl_simple_type env (sdecl.ptype_kind <> Ptype_fixed) sty in
+              transl_simple_type env (sdecl.ptype_kind <> Ptype_private) sty in
             if Ctype.cyclic_abbrev env id ty then
               raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
             Some ty
@@ -184,7 +184,7 @@ let transl_declaration env (name, sdecl) id =
         raise(Error(loc, Unconsistent_constraint tr)))
     cstrs;
   Ctype.end_def ();
-  if sdecl.ptype_kind = Ptype_fixed then begin
+  if sdecl.ptype_kind = Ptype_private then begin
     let (p, _) =
       try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env
       with Not_found -> assert false in
@@ -247,7 +247,7 @@ let check_constraints env (_, sdecl) (_, decl) =
   | Type_variant (l, _) ->
       let rec find_pl = function
           Ptype_variant(pl, _) -> pl
-        | Ptype_record _ | Ptype_abstract | Ptype_fixed -> assert false
+        | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false
       in
       let pl = find_pl sdecl.ptype_kind in
       List.iter
@@ -263,7 +263,7 @@ let check_constraints env (_, sdecl) (_, decl) =
   | Type_record (l, _, _) ->
       let rec find_pl = function
           Ptype_record(pl, _) -> pl
-        | Ptype_variant _ | Ptype_abstract | Ptype_fixed -> assert false
+        | Ptype_variant _ | Ptype_abstract | Ptype_private -> assert false
       in
       let pl = find_pl sdecl.ptype_kind in
       let rec get_loc name = function
@@ -493,7 +493,11 @@ let compute_variance_decl env sharp decl (required, loc) =
   end;
   let priv =
     match decl.type_kind with
-      Type_abstract -> Public
+      Type_abstract ->
+        begin match decl.type_manifest with
+          Some ty when not (Btype.has_constr_row ty) -> Public
+        | _ -> Private
+        end
     | Type_variant (_, priv) | Type_record (_, _, priv) -> priv
   in
   List.iter2
@@ -571,7 +575,8 @@ let compute_variance_decls env cldecls =
 let transl_type_decl env name_sdecl_list =
   (* Add dummy types for fixed rows *)
   let fixed_types =
-    List.filter (fun (_,sd) -> sd.ptype_kind = Ptype_fixed) name_sdecl_list in
+    List.filter (fun (_,sd) -> sd.ptype_kind = Ptype_private) name_sdecl_list
+  in
   let name_sdecl_list =
     List.map
       (fun (name,sdecl) ->
@@ -693,7 +698,7 @@ let transl_with_constraint env row_path sdecl =
        with Ctype.Unify tr ->
          raise(Error(loc, Unconsistent_constraint tr)))
     sdecl.ptype_cstrs;
-  let no_row = sdecl.ptype_kind <> Ptype_fixed in
+  let no_row = sdecl.ptype_kind <> Ptype_private in
   let decl =
     { type_params = params;
       type_arity = List.length params;
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 1ff13e5cf3..e63eb155c8 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -86,7 +86,7 @@ let merge_constraint initial_env loc sg lid constr =
       ([], _, _) ->
         raise(Error(loc, With_no_component lid))
     | (Tsig_type(id, decl, rs) :: rem, [s],
-       Pwith_type ({ptype_kind = Ptype_fixed} as sdecl))
+       Pwith_type ({ptype_kind = Ptype_private} as sdecl))
       when Ident.name id = s ->
 	let decl_row =
 	  { type_params =
@@ -137,6 +137,12 @@ let map_rec fn decls rem =
   | [] -> rem
   | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
 
+let rec map_rec' fn decls rem =
+  match decls with
+  | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) ->
+      fn Trec_not d1 :: map_rec' fn dl rem
+  | _ -> map_rec fn decls rem
+
 (* Auxiliary for translating recursively-defined module types.
    Return a module type that approximates the shape of the given module
    type AST.  Retain only module, type, and module type
@@ -172,7 +178,7 @@ let approx_modtype transl_mty init_env smty =
         | Psig_type sdecls ->
             let decls = Typedecl.approx_type_decl env sdecls in
             let rem = approx_sig env srem in
-            map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
+            map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_module(name, smty) ->
             let mty = approx_mty env smty in
             let (id, newenv) = Env.enter_module name mty env in
@@ -306,7 +312,7 @@ and transl_signature env sg =
               sdecls;
             let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
             let rem = transl_sig newenv srem in
-            map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
+            map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
         | Psig_exception(name, sarg) ->
             let arg = Typedecl.transl_exception env sarg in
             let (id, newenv) = Env.enter_exception name arg env in
@@ -588,7 +594,7 @@ and type_structure anchor env sstr =
           enrich_type_decls anchor decls env newenv in
         let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
         (Tstr_type decls :: str_rem,
-         map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
+         map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
          final_env)
     | {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
         let arg = Typedecl.transl_exception env sarg in