merge fixedtypes branch

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

24 files changed, 337 insertions, 105 deletions

diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml
index 5b1e753f0..1270de354 100644
--- a/camlp4/top/rprint.ml
+++ b/camlp4/top/rprint.ml
@@ -180,21 +180,16 @@ and print_simple_out_type ppf =
         print_ident id
   | Otyp_manifest ty1 ty2 ->
       fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2
-  | Otyp_sum constrs priv ->
-      fprintf ppf "@[<hv>%a[ %a ]@]" print_private priv
+  | Otyp_sum constrs ->
+      fprintf ppf "@[<hv>[ %a ]@]"
         (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
-  | Otyp_record lbls priv ->
-      fprintf ppf "@[<hv 2>%a{ %a }@]" print_private priv
+  | Otyp_record lbls ->
+      fprintf ppf "@[<hv 2>{ %a }@]"
         (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls
   | Otyp_abstract -> fprintf ppf "'abstract"
   | Otyp_alias _ _ | Otyp_poly _ _
   | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty ->
       fprintf ppf "@[<1>(%a)@]" print_out_type ty ]
-  and print_private ppf =
-  fun
-  [ Asttypes.Public -> ()
-  | Asttypes.Private -> fprintf ppf "private "
-  ]
   in
   print_tkind ppf
 and print_out_constr ppf (name, tyl) =
@@ -358,7 +353,7 @@ and print_out_sig_item ppf =
       fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name
         Toploop.print_out_type.val 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 constrain ppf (ty, ty') =
     fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty
       Toploop.print_out_type.val ty'
@@ -371,8 +366,14 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
     | _ ->
         fprintf ppf "%s@ %a" name
           (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ]
+  and print_private ppf =
+  fun
+  [ Asttypes.Public -> ()
+  | Asttypes.Private -> fprintf ppf " private"
+  ]
   in
-  fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =@ %a@]%a@]" kwd type_defined
+  fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@ %a@]%a@]" kwd type_defined
+    print_private priv
     Toploop.print_out_type.val ty print_constraints constraints
 ;
 
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index f3236137c..979579bbf 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -172,7 +172,7 @@ module Analyser =
 
     let name_comment_from_type_kind pos_end pos_limit tk =
       match tk with
-        Parsetree.Ptype_abstract ->
+        Parsetree.Ptype_abstract | Parsetree.Ptype_private ->
           (0, [])
       | Parsetree.Ptype_variant (cons_core_type_list_list, _) ->
           let rec f acc cons_core_type_list_list =
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 0a17d04ac..307dfabef 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -166,7 +166,7 @@ let search_pos_type_decl td ~pos ~env =
     | None -> ()
     end;
     let rec search_tkind = function
-      Ptype_abstract -> ()
+      Ptype_abstract | Ptype_private -> ()
     | Ptype_variant (dl, _) ->
         List.iter dl
           ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index 6f8c8ca78..17c3ba584 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -400,7 +400,7 @@ class st_viewer ?(dir=Unix.getcwd()) ?on () =
   let label = Label.create tl ~anchor:`W ~padx:5 in
   let view = Frame.create tl in
   let buttons = Frame.create tl in
-  let all = Button.create buttons ~text:"Show all" ~padx:20
+  let _all = Button.create buttons ~text:"Show all" ~padx:20
   and close = Button.create buttons ~text:"Close all" ~command:close_all_views
   and detach = Button.create buttons ~text:"Detach"
   and edit = Button.create buttons ~text:"Impl"
diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common
index 483013186..7e8bfadba 100644
--- a/otherlibs/labltk/support/Makefile.common
+++ b/otherlibs/labltk/support/Makefile.common
@@ -15,7 +15,7 @@ INSTALLDIR=$(LIBDIR)/$(LIBNAME)
 CAMLRUN=$(TOPDIR)/boot/ocamlrun
 CAMLC=$(TOPDIR)/ocamlcomp.sh
 CAMLOPT=$(TOPDIR)/ocamlcompopt.sh
-CAMLCOMP=$(CAMLC) -c -warn-error Ay
+CAMLCOMP=$(CAMLC) -c -warn-error A
 CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v
 CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex
 CAMLLIBR=$(CAMLC) -a
diff --git a/parsing/parser.mly b/parsing/parser.mly
index fd7f56f76..b9723e263 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1165,6 +1165,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) }
+  | EQUAL PRIVATE core_type
+      { (Ptype_private, Some $3) }
 ;
 type_parameters:
     /*empty*/                                   { [] }
@@ -1209,11 +1211,11 @@ with_constraints:
   | with_constraints AND with_constraint        { $3 :: $1 }
 ;
 with_constraint:
-    TYPE type_parameters label_longident EQUAL core_type constraints
+    TYPE type_parameters label_longident with_type_binder core_type constraints
       { let params, variance = List.split $2 in
         ($3, Pwith_type {ptype_params = params;
                          ptype_cstrs = List.rev $6;
-                         ptype_kind = Ptype_abstract;
+                         ptype_kind = $4;
                          ptype_manifest = Some $5;
                          ptype_variance = variance;
                          ptype_loc = symbol_rloc()}) }
@@ -1222,6 +1224,10 @@ with_constraint:
   | MODULE mod_longident EQUAL mod_ext_longident
       { ($2, Pwith_module $4) }
 ;
+with_type_binder:
+    EQUAL          { Ptype_abstract }
+  | EQUAL PRIVATE  { Ptype_private }
+;
 
 /* Polymorphic types */
 
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index f53ad2cbe..33a0e655b 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -133,6 +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_private
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index db5f79dfa..986cb0f15 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -323,6 +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_private ->
+      line i ppf "Ptype_private\n"
 
 and exception_declaration i ppf x = list i core_type ppf x
 
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index b1dcc9d57..4ddfd7995 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.09+dev17 (2005-03-04)";;
+let ocaml_version = "3.09+dev18 (2005-03-23)";;
diff --git a/tools/depend.ml b/tools/depend.ml
index e3b3e64f3..5d0ad6014 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -68,7 +68,7 @@ let add_type_declaration bv td =
     td.ptype_cstrs;
   add_opt add_type bv td.ptype_manifest;
   let rec add_tkind = function
-    Ptype_abstract -> ()
+    Ptype_abstract | Ptype_private -> ()
   | Ptype_variant (cstrs, _) ->
       List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
   | Ptype_record (lbls, _) ->
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index a8bb58297..e0a51ddd2 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -148,7 +148,7 @@ let load_lambda ppf lam =
 
 (* Print the outcome of an evaluation *)
 
-let pr_item env = function
+let rec pr_item env = function
   | Tsig_value(id, decl) :: rem ->
       let tree = Printtyp.tree_of_value_description id decl in
       let valopt =
@@ -162,6 +162,8 @@ let pr_item env = function
             Some v
       in
       Some (tree, valopt, rem)
+  | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) ->
+      pr_item env rem
   | Tsig_type(id, decl, rs) :: rem ->
       let tree = Printtyp.tree_of_type_declaration id decl rs in
       Some (tree, None, rem)
diff --git a/typing/btype.ml b/typing/btype.ml
index 2e95c4d95..90e9d83b9 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -140,6 +140,26 @@ let proxy ty =
       in proxy_obj ty
   | _ -> ty0
 
+(**** 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  *)
@@ -155,7 +175,7 @@ let rec iter_row f row =
     row.row_fields;
   match (repr row.row_more).desc with
     Tvariant row -> iter_row f row
-  | Tvar | Tnil | Tunivar | Tsubst _ ->
+  | Tvar | Tunivar | Tsubst _ | Tconstr _ ->
       Misc.may (fun (_,l) -> List.iter f l) row.row_name;
       List.iter f row.row_bound
   | _ -> assert false
diff --git a/typing/btype.mli b/typing/btype.mli
index 02a3cc1c1..251bc1ef5 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 35494cc5c..47402a39d 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -225,6 +225,7 @@ let rec opened_object ty =
   | Tfield(_, _, _, t) -> opened_object t
   | Tvar               -> true
   | Tunivar            -> true
+  | Tconstr _          -> true
   | _                  -> false
 
 (**** Close an object ****)
@@ -778,10 +779,15 @@ let rec copy ty =
               (* If the row variable is not generic, we must keep it *)
               let keep = more.level <> generic_level in
               let more' =
-                match more.desc with Tsubst ty -> ty
-                | _ ->
+                match more.desc with
+		  Tsubst ty -> ty
+		| Tconstr _ ->
+		    if keep then save_desc more more.desc;
+		    copy more
+                | Tvar | Tunivar ->
                     save_desc more more.desc;
                     if keep then more else newty more.desc
+		|  _ -> assert false
               in
               (* Register new type first for recursion *)
               more.desc <- Tsubst(newgenty(Ttuple[more';t]));
@@ -931,7 +937,8 @@ let rec copy_sep fixed free bound visited ty =
           (* We shall really check the level on the row variable *)
           let keep = more.desc = Tvar && more.level <> generic_level in
           let more' = copy_rec more in
-          let row = copy_row copy_rec fixed row keep more' in
+          let fixed' = fixed && (repr more').desc = Tvar in
+          let row = copy_row copy_rec fixed' row keep more' in
           Tvariant row
       | Tpoly (t1, tl) ->
           let tl = List.map repr tl in
@@ -2256,8 +2263,13 @@ and eqtype_list rename type_pairs subst env tl1 tl2 =
   List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
 
 and eqtype_fields rename type_pairs subst env ty1 ty2 =
-  let (fields1, rest1) = flatten_fields ty1
-  and (fields2, rest2) = flatten_fields ty2 in
+  let (fields2, rest2) = flatten_fields ty2 in
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  try match try_expand_head env rest2 with
+    {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
+  | _ -> raise Cannot_expand
+  with Cannot_expand ->
+  let (fields1, rest1) = flatten_fields ty1 in
   let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
   eqtype rename type_pairs subst env rest1 rest2;
   if (miss1 <> []) || (miss2 <> []) then raise (Unify []);
@@ -2278,6 +2290,11 @@ and eqtype_kind k1 k2 =
   | _                    -> raise (Unify [])
 
 and eqtype_row rename type_pairs subst env row1 row2 =
+  (* Try expansion, needed when called from Includecore.type_manifest *)
+  try match try_expand_head env (row_more row2) with
+    {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2
+  | _ -> raise Cannot_expand
+  with Cannot_expand ->
   let row1 = row_repr row1 and row2 = row_repr row2 in
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   if row1.row_closed <> row2.row_closed
@@ -2646,6 +2663,9 @@ let find_cltype_for_path env p =
       end
   | None -> assert 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
   match t.desc with
@@ -2676,7 +2696,8 @@ let rec build_subtype env visited loops posi level t =
       let c = collect tlist' in
       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 ->
+  | Tconstr(p, tl, abbrev)
+    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
@@ -2716,7 +2737,8 @@ 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 then warn := true;
+        if level = 0 && generic_abbrev env p && not (has_constr_row' env t)
+        then warn := true;
         let tl' =
           List.map2
             (fun (co,cn,_) t ->
@@ -2762,7 +2784,7 @@ let rec build_subtype env visited loops posi level t =
           fields
       in
       let c = collect fields in
-      if posi && short && c = Unchanged then (t, Unchanged) else
+      if short && c = Unchanged then (t, Unchanged) else
       let row =
         { row_fields = List.map fst fields; row_more = newvar();
           row_bound = !bound; row_closed = posi; row_fixed = false;
@@ -2848,9 +2870,11 @@ let rec subtype_rec env trace t1 t2 cstrs =
         subtype_list env trace tl1 tl2 cstrs
     | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
         cstrs
-    | (Tconstr(p1, tl1, abbrev1), _) when generic_abbrev env p1 ->
+    | (Tconstr(p1, tl1, abbrev1), _)
+      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 ->
+    | (_, Tconstr(p2, tl2, abbrev2))
+      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
@@ -2878,7 +2902,8 @@ let rec subtype_rec env trace t1 t2 cstrs =
     | (Tvariant row1, Tvariant row2) ->
         let row1 = row_repr row1 and row2 = row_repr row2 in
         begin try
-          if not row1.row_closed then raise Exit;
+          if not row1.row_closed || row1.row_more.desc <> Tvar
+          || row2.row_more.desc <> Tvar then raise Exit;
           let r1, r2, pairs =
             merge_row_fields row1.row_fields row2.row_fields in
           if filter_row_fields false r1 <> [] then raise Exit;
@@ -2965,6 +2990,8 @@ let rec unalias_object ty =
       newty2 ty.level ty.desc
   | Tunivar ->
       ty
+  | Tconstr _ ->
+      newty2 ty.level Tvar
   | _ ->
       assert false
 
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 0c98acdd0..b81774b2c 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -40,6 +40,63 @@ let value_descriptions env vd1 vd2 =
 let private_flags priv1 priv2 =
   match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true
 
+(* Inclusion between manifest types (particularly for fixed types) *)
+
+let is_absrow env ty =
+  match ty.desc with
+    Tconstr(Pident id, _, _) ->
+      Btype.is_row_name (Ident.name id) &&
+      begin match Ctype.expand_head env ty with
+        {desc=Tobject _|Tvariant _} -> true
+      | _ -> false
+      end
+  | _ -> false
+
+let type_manifest env ty1 params1 ty2 params2 =
+  let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in
+  match ty1'.desc, ty2'.desc with
+    Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) ->
+      let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in
+      Ctype.equal env true (ty1::params1) (row2.row_more::params2) &&
+      (match row1.row_more with	{desc=Tvar|Tconstr _} -> true | _ -> false) &&
+      let r1, r2, pairs =
+	Ctype.merge_row_fields row1.row_fields row2.row_fields in
+      (not row2.row_closed ||
+       row1.row_closed && Ctype.filter_row_fields false r1 = []) &&
+      List.for_all
+	(fun (_,f) -> match Btype.row_field_repr f with
+	  Rabsent | Reither _ -> true | Rpresent _ -> false)
+	r2 &&
+      let to_equal = ref (List.combine params1 params2) in
+      List.for_all
+	(fun (_, f1, f2) ->
+	  match Btype.row_field_repr f1, Btype.row_field_repr f2 with
+	    Rpresent(Some t1),
+	    (Rpresent(Some t2) | Reither(false, [t2], _, _)) ->
+	      to_equal := (t1,t2) :: !to_equal; true
+	  | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true
+	  | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_)
+	    when List.length tl1 = List.length tl2 && c1 = c2 ->
+	      to_equal := List.combine tl1 tl2 @ !to_equal; true
+	  | Rabsent, (Reither _ | Rabsent) -> true
+	  | _ -> false)
+	pairs &&
+      let tl1, tl2 = List.split !to_equal in
+      Ctype.equal env true tl1 tl2
+  | Tobject (fi1, _), Tobject (fi2, _)
+    when is_absrow env (snd(Ctype.flatten_fields fi2)) ->
+      let (fields2,rest2) = Ctype.flatten_fields fi2 in
+      Ctype.equal env true (ty1::params1) (rest2::params2) &&
+      let (fields1,rest1) = Ctype.flatten_fields fi1 in
+      (match rest1 with {desc=Tnil|Tvar|Tconstr _} -> true | _ -> false) &&
+      let pairs, miss1, miss2 = Ctype.associate_fields fields1 fields2 in
+      miss2 = [] &&
+      let tl1, tl2 =
+	List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in
+      Ctype.equal env true (params1 @ tl1) (params2 @ tl2)
+  | _ -> 
+      Ctype.equal env true (ty1 :: params1) (ty2 :: params2)
+
 (* Inclusion between type declarations *)
 
 let type_declarations env id decl1 decl2 =
@@ -72,8 +129,7 @@ let type_declarations env id decl1 decl2 =
       (_, None) ->
         Ctype.equal env true decl1.type_params decl2.type_params
     | (Some ty1, Some ty2) ->
-        Ctype.equal env true (ty1::decl1.type_params)
-                             (ty2::decl2.type_params)
+	type_manifest env ty1 decl1.type_params ty2 decl2.type_params
     | (None, Some ty2) ->
         let ty1 =
           Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
@@ -81,11 +137,9 @@ let type_declarations env id decl1 decl2 =
         Ctype.equal env true decl1.type_params decl2.type_params &&
         Ctype.equal env false [ty1] [ty2]
   end &&
-  begin decl2.type_kind <> Type_abstract || decl2.type_manifest <> None ||
   List.for_all2
     (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2) && (not cn1 || cn2))
     decl1.type_variance decl2.type_variance
-  end
 
 (* Inclusion between exception declarations *)
 
diff --git a/typing/includemod.ml b/typing/includemod.ml
index cf89fc9d7..810c555f2 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -206,6 +206,15 @@ and signatures env subst sig1 sig2 =
         end
     | item2 :: rem ->
         let (id2, name2) = item_ident_name item2 in
+        let name2, report =
+          match name2 with
+            Field_type s when let l = String.length s in
+            l >= 4 && String.sub s (l-4) 4 = "#row" ->
+              (* Do not report in case of failure,
+                 as the main type will generate an error *)
+              Field_type (String.sub s 0 (String.length s - 4)), false
+          | _ -> name2, true
+        in
         begin try
           let (id1, item1, pos1) = Tbl.find name2 comps1 in
           let new_subst =
@@ -222,7 +231,9 @@ and signatures env subst sig1 sig2 =
           pair_components new_subst
             ((item1, item2, pos1) :: paired) unpaired rem
         with Not_found ->
-          pair_components subst paired (Missing_field id2 :: unpaired) rem
+          let unpaired =
+            if report then Missing_field id2 :: unpaired else unpaired in
+          pair_components subst paired unpaired rem
         end in
   (* Do the pairing and checking, and return the final coercion *)
   simplify_structure_coercion (pair_components subst [] [] sig2)
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 43ab1bdac..55178d89b 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) ->
@@ -390,24 +390,25 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
   let print_private ppf = function
     Asttypes.Private -> fprintf ppf "private "
   | Asttypes.Public -> () in
-  let rec print_out_tkind = function
-  | Otyp_abstract ->
-      fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
-        constraints
-  | Otyp_record (lbls, priv) ->
-      fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
+  let rec print_out_tkind ppf = function
+  | Otyp_abstract -> ()
+  | Otyp_record lbls ->
+      fprintf ppf " = %a{%a@;<1 -2>}"
         print_private priv
         (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
-        print_constraints constraints
-  | Otyp_sum (constrs, priv) ->
-      fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
+  | Otyp_sum constrs ->
+      fprintf ppf " =@;<1 2>%a%a"
         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
-  print_out_tkind ty
+      fprintf ppf " =@;<1 2>%a%a"
+        print_private priv
+        !out_type ty
+  in
+  fprintf ppf "@[<2>@[<hv 2>%t%a@]%a@]"
+    print_name_args
+    print_out_tkind ty
+    print_constraints constraints
 and print_out_constr ppf (name, tyl) =
   match tyl with
     [] -> fprintf ppf "%s" name
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 6347befdc..c7031912b 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 e6f800252..1edb8a115 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -437,6 +437,7 @@ and tree_of_typfields sch rest = function
       let rest =
         match rest.desc with
         | Tvar | Tunivar -> Some (is_non_gen sch rest)
+        | Tconstr _ -> Some false
         | Tnil -> None
         | _ -> fatal_error "typfields (1)"
       in
@@ -531,26 +532,25 @@ let rec tree_of_type_decl id decl =
     | _ -> "?"
   in
   let type_defined decl =
-    if List.exists2
-        (fun ty x -> x <> (true,true,true) &&
-          (decl.type_kind = Type_abstract && ty_manifest = None
-         || (repr ty).desc <> Tvar))
+    let abstr =
+      match decl.type_kind with
+        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
+        (fun ty (co,cn,ct) ->
+          if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
         decl.type_params decl.type_variance
-    then
-      let vari = List.map (fun (co,cn,ct) -> (co,cn)) decl.type_variance in
-      (Ident.name id,
-       List.combine
-         (List.map (fun ty -> type_param (tree_of_typexp false ty)) params)
-         vari)
-    else
-      let ty =
-        tree_of_typexp false
-          (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
-      in
-      match ty with
-      | Otyp_constr (Oide_ident id, tyl) ->
-          (id, List.map (fun ty -> (type_param ty, (true, true))) tyl)
-      | _ -> ("?", [])
+    in
+    (Ident.name id,
+     List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
+       params vari)
   in
   let tree_of_manifest ty1 =
     match ty_manifest with
@@ -559,19 +559,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)
@@ -785,6 +787,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/subst.ml b/typing/subst.ml
index 782179b6b..809393e3b 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -106,14 +106,18 @@ let rec typexp s ty =
               Tlink ty2
           | _ ->
               let dup =
-                s.for_saving || more.level = generic_level || static_row row in
+                s.for_saving || more.level = generic_level || static_row row ||
+                match more.desc with Tconstr _ -> true | _ -> false in
               (* Various cases for the row variable *)
               let more' =
-                match more.desc with Tsubst ty -> ty
-                | _ ->
+                match more.desc with
+                  Tsubst ty -> ty
+                | Tconstr _ -> typexp s more
+                | Tunivar | Tvar ->
                     save_desc more more.desc;
                     if s.for_saving then newpersty more.desc else
                     if dup && more.desc <> Tunivar then newgenvar () else more
+                | _ -> assert false
               in
               (* Register new type first for recursion *)
               more.desc <- Tsubst(newgenty(Ttuple[more';ty']));
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 869de177b..21e42eea8 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -818,6 +818,8 @@ let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
+  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
+    Printtyp.raw_type_expr expected_ty; *)
   try
     unify env exp.exp_type expected_ty
   with
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 2567eb37f..bcf86e369 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -40,6 +40,7 @@ type error =
   | Not_an_exception of Longident.t
   | Bad_variance
   | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
 
 exception Error of Location.t * error
 
@@ -76,6 +77,28 @@ let is_float env ty =
     {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
   | _ -> false
 
+(* Set the row variable in a fixed type *)
+let set_fixed_row env loc p decl =
+  let tm =
+    match decl.type_manifest with
+      None -> assert false
+    | Some t -> Ctype.expand_head env t
+  in
+  let rv =
+    match tm.desc with
+      Tvariant row ->
+	tm.desc <- Tvariant {row with row_fixed = true};
+	if Btype.static_row row then Btype.newgenty Tnil
+        else Btype.row_more row
+    | Tobject (ty, _) ->
+	snd (Ctype.flatten_fields ty)
+    | _ ->
+        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+  in
+  if rv.desc <> Tvar then
+    raise (Error (loc, Bad_fixed_type "has no row variable"));
+  rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
+
 (* Translate one type declaration *)
 
 module StringSet =
@@ -104,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_abstract | Ptype_private ->
             Type_abstract
         | Ptype_variant (cstrs, priv) ->
             let all_constrs = ref StringSet.empty in
@@ -145,7 +168,8 @@ let transl_declaration env (name, sdecl) id =
         begin match sdecl.ptype_manifest with
           None -> None
         | Some sty ->
-            let ty = transl_simple_type env true sty in
+            let ty =
+              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
@@ -160,7 +184,12 @@ let transl_declaration env (name, sdecl) id =
         raise(Error(loc, Unconsistent_constraint tr)))
     cstrs;
   Ctype.end_def ();
-
+  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
+    set_fixed_row env sdecl.ptype_loc p decl
+  end;
   (id, decl)
 
 (* Generalize a type declaration *)
@@ -218,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 -> assert false
+        | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false
       in
       let pl = find_pl sdecl.ptype_kind in
       List.iter
@@ -234,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 -> 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
@@ -464,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
@@ -540,6 +573,18 @@ let compute_variance_decls env cldecls =
 
 (* Translate a set of mutually recursive type declarations *)
 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_private) name_sdecl_list
+  in
+  let name_sdecl_list =
+    List.map
+      (fun (name,sdecl) ->
+        name^"#row",
+        {sdecl with ptype_kind = Ptype_abstract; ptype_manifest = None})
+      fixed_types
+    @ name_sdecl_list
+  in
   (* Create identifiers. *)
   let id_list =
     List.map (fun (name, _) -> Ident.create name) name_sdecl_list
@@ -637,7 +682,7 @@ let transl_value_decl env valdecl =
 
 (* Translate a "with" constraint -- much simplified version of
     transl_type_decl. *)
-let transl_with_constraint env sdecl =
+let transl_with_constraint env row_path sdecl =
   reset_type_variables();
   Ctype.begin_def();
   let params =
@@ -653,6 +698,7 @@ let transl_with_constraint env sdecl =
        with Ctype.Unify tr ->
          raise(Error(loc, Unconsistent_constraint tr)))
     sdecl.ptype_cstrs;
+  let no_row = sdecl.ptype_kind <> Ptype_private in
   let decl =
     { type_params = params;
       type_arity = List.length params;
@@ -660,11 +706,15 @@ let transl_with_constraint env sdecl =
       type_manifest =
         begin match sdecl.ptype_manifest with
           None -> None
-        | Some sty -> Some(transl_simple_type env true sty)
+        | Some sty ->
+            Some(transl_simple_type env no_row sty)
         end;
       type_variance = [];
     }
   in
+  begin match row_path with None -> ()
+  | Some p -> set_fixed_row env sdecl.ptype_loc p decl
+  end;
   if Ctype.closed_type_decl decl <> None then
     raise(Error(sdecl.ptype_loc, Unbound_type_var));
   let decl =
@@ -771,3 +821,5 @@ let report_error ppf = function
         "In this definition, expected parameter variances are not satisfied"
   | Unavailable_type_constructor p ->
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
+  | Bad_fixed_type r ->
+      fprintf ppf "This fixed type %s" r
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index cab8dc52a..a29b402e1 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -18,23 +18,23 @@ open Types
 open Format
 
 val transl_type_decl:
-        Env.t -> (string * Parsetree.type_declaration) list ->
+    Env.t -> (string * Parsetree.type_declaration) list ->
                                   (Ident.t * type_declaration) list * Env.t
 val transl_exception:
-        Env.t -> Parsetree.exception_declaration -> exception_declaration
+    Env.t -> Parsetree.exception_declaration -> exception_declaration
 
 val transl_exn_rebind:
-        Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
+    Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration
 
 val transl_value_decl:
-        Env.t -> Parsetree.value_description -> value_description
+    Env.t -> Parsetree.value_description -> value_description
 
 val transl_with_constraint:
-        Env.t -> Parsetree.type_declaration -> type_declaration
+    Env.t -> Path.t option -> Parsetree.type_declaration -> type_declaration
 
 val abstract_type_decl: int -> type_declaration
 val approx_type_decl:
-        Env.t -> (string * Parsetree.type_declaration) list ->
+    Env.t -> (string * Parsetree.type_declaration) list ->
                                   (Ident.t * type_declaration) list
 val check_recmod_typedecl:
     Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit
@@ -65,6 +65,7 @@ type error =
   | Not_an_exception of Longident.t
   | Bad_variance
   | Unavailable_type_constructor of Path.t
+  | Bad_fixed_type of string
 
 exception Error of Location.t * error
 
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 15c4c35c0..e63eb155c 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -68,16 +68,50 @@ let rm node =
 
 (* Merge one "with" constraint in a signature *)
 
+let rec add_rec_types env = function
+    Tsig_type(id, decl, Trec_next) :: rem ->
+      add_rec_types (Env.add_type id decl env) rem
+  | _ -> env
+
+let check_type_decl env id row_id newdecl decl rs rem =
+  let env = Env.add_type id newdecl env in
+  let env =
+    match row_id with None -> env | Some id -> Env.add_type id newdecl env in
+  let env = if rs = Trec_not then env else add_rec_types env rem in
+  Includemod.type_declarations env id newdecl decl
+
 let merge_constraint initial_env loc sg lid constr =
-  let rec merge env sg namelist =
+  let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
       ([], _, _) ->
         raise(Error(loc, With_no_component lid))
+    | (Tsig_type(id, decl, rs) :: rem, [s],
+       Pwith_type ({ptype_kind = Ptype_private} as sdecl))
+      when Ident.name id = s ->
+	let decl_row =
+	  { type_params =
+	      List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params;
+	    type_arity = List.length sdecl.ptype_params;
+	    type_kind = Type_abstract;
+	    type_manifest = None;
+	    type_variance =
+	      List.map (fun (c,n) -> (c,n,n)) sdecl.ptype_variance }
+	and id_row = Ident.create (s^"#row") in
+	let initial_env = Env.add_type id_row decl_row initial_env in
+        let newdecl = Typedecl.transl_with_constraint
+                        initial_env (Some(Pident id_row)) sdecl in
+        check_type_decl env id row_id newdecl decl rs rem;
+	let decl_row = {decl_row with type_params = newdecl.type_params} in
+        let rs' = if rs = Trec_first then Trec_not else rs in
+        Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem
     | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
       when Ident.name id = s ->
-        let newdecl = Typedecl.transl_with_constraint initial_env sdecl in
-        Includemod.type_declarations env id newdecl decl;
+        let newdecl = Typedecl.transl_with_constraint initial_env None sdecl in
+        check_type_decl env id row_id newdecl decl rs rem;
         Tsig_type(id, newdecl, rs) :: rem
+    | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
+      when Ident.name id = s ^ "#row" ->
+        merge env rem namelist (Some id)
     | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
       when Ident.name id = s ->
         let (path, mty') = type_module_path initial_env loc lid in
@@ -86,12 +120,12 @@ let merge_constraint initial_env loc sg lid constr =
         Tsig_module(id, newmty, rs) :: rem
     | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
       when Ident.name id = s ->
-        let newsg = merge env (extract_sig env loc mty) namelist in
+        let newsg = merge env (extract_sig env loc mty) namelist None in
         Tsig_module(id, Tmty_signature newsg, rs) :: rem
     | (item :: rem, _, _) ->
-        item :: merge (Env.add_item item env) rem namelist in
+        item :: merge (Env.add_item item env) rem namelist row_id in
   try
-    merge initial_env sg (Longident.flatten lid)
+    merge initial_env sg (Longident.flatten lid) None
   with Includemod.Error explanation ->
     raise(Error(loc, With_mismatch(lid, explanation)))
 
@@ -103,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
@@ -138,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
@@ -272,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
@@ -554,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