Nouveau format %$. Introduction des types virtuels: step 1 sans inclusion dans Camlp4

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

24 files changed, 170 insertions, 98 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index b428b512c..e0b73efaf 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index cd65959d5..f53ef580d 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index 2d4eb5cb8..0570bc024 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -170,7 +170,7 @@ module Analyser =
     let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options 
 
     let name_comment_from_type_kind pos_start pos_end pos_limit tk =
-      match tk with
+      let rec comment_from_tkind = function
         Parsetree.Ptype_abstract ->
           (0, [])
       | Parsetree.Ptype_variant cons_core_type_list_list -> 
@@ -236,8 +236,12 @@ module Analyser =
           in
           (0, f name_mutable_type_list)
 
+      | Parsetree.Ptype_virtual tkind -> comment_from_tkind tkind in
+
+     comment_from_tkind tk
+
     let get_type_kind env name_comment_list type_kind =
-      match type_kind with
+      let rec get_tkind = function
         Types.Type_abstract ->
           Odoc_type.Type_abstract
 
@@ -276,6 +280,11 @@ module Analyser =
           in
           Odoc_type.Type_record (List.map f l)
 
+      | Types.Type_virtual tkind -> get_tkind tkind in
+
+     get_tkind type_kind
+
+
     (** Analysis of the elements of a class, from the information in the parsetree and in the class
        signature. @return the couple (inherited_class list, elements).*)
     let analyse_class_elements env current_class_name last_pos pos_limit 
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 65cbaa8bd..507219225 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -226,13 +226,14 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
             None -> false
           | Some t -> matches t
           end ||
-          begin match td.type_kind with
+          let rec search_tkind = function
             Type_abstract -> false
           | Type_variant l ->
             List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
           | Type_record(l, rep) ->
             List.exists l ~f:(fun (_, _, t) -> matches t)
-          end
+          | Type_virtual tkind -> search_tkind tkind in
+          search_tkind td.type_kind
           then [lid_of_id id, Ptype] else []
       | Tsig_exception (id, l) ->
           if List.exists l ~f:matches
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 680bb8ff0..90d95e1ae 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -165,14 +165,15 @@ let search_pos_type_decl td ~pos ~env =
       Some t -> search_pos_type t ~pos ~env
     | None -> ()
     end;
-    begin match td.ptype_kind with
+    let rec search_tkind = function
       Ptype_abstract -> ()
     | Ptype_variant dl ->
         List.iter dl
           ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
     | Ptype_record dl ->
         List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env)
-    end;
+    | Ptype_virtual tkind -> search_tkind tkind in
+    search_tkind td.ptype_kind;
     List.iter td.ptype_cstrs ~f:
       begin fun (t1, t2, _) ->
         search_pos_type t1 ~pos ~env;
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 5f3c9b489..b7356717f 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -168,6 +168,10 @@ let bigarray_set arr arg newval =
                        ["", arr; 
                         "", ghexp(Pexp_array coords);
                         "", newval]))
+
+let mktype_kind vflag kind =
+  if vflag = Virtual && kind != Ptype_abstract then Ptype_virtual kind else kind
+
 %}
 
 /* Tokens */
@@ -1120,6 +1124,7 @@ type_declarations:
     type_declaration                            { [$1] }
   | type_declarations AND type_declaration      { $3 :: $1 }
 ;
+
 type_declaration:
     type_parameters LIDENT type_kind constraints
       { let (params, variance) = List.split $1 in
@@ -1138,18 +1143,18 @@ constraints:
 type_kind:
     /*empty*/
       { (Ptype_abstract, None) }
-  | EQUAL core_type
-      { (Ptype_abstract, Some $2) }
-  | EQUAL constructor_declarations
-      { (Ptype_variant(List.rev $2), None) }
-  | EQUAL BAR constructor_declarations
-      { (Ptype_variant(List.rev $3), None) }
-  | EQUAL LBRACE label_declarations opt_semi RBRACE
-      { (Ptype_record(List.rev $3), None) }
-  | EQUAL core_type EQUAL opt_bar constructor_declarations
-      { (Ptype_variant(List.rev $5), Some $2) }
-  | EQUAL core_type EQUAL LBRACE label_declarations opt_semi RBRACE
-      { (Ptype_record(List.rev $5), Some $2) }
+  | EQUAL virtual_flag core_type
+      { (mktype_kind $2 Ptype_abstract, Some $3) }
+  | EQUAL virtual_flag constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $3)), None) }
+  | EQUAL virtual_flag BAR constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $4)), None) }
+  | EQUAL virtual_flag LBRACE label_declarations opt_semi RBRACE
+      { (mktype_kind $2 (Ptype_record(List.rev $4)), None) }
+  | EQUAL virtual_flag core_type EQUAL opt_bar constructor_declarations
+      { (mktype_kind $2 (Ptype_variant(List.rev $6)), Some $3) }
+  | EQUAL virtual_flag core_type EQUAL LBRACE label_declarations opt_semi RBRACE
+      { (mktype_kind $2 (Ptype_record(List.rev $6)), Some $3) }
 ;
 type_parameters:
     /*empty*/                                   { [] }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 9c055afdf..652a411df 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -131,6 +131,7 @@ and type_kind =
     Ptype_abstract
   | Ptype_variant of (string * core_type list) list
   | Ptype_record of (string * mutable_flag * core_type) list
+  | Ptype_virtual of type_kind
 
 and exception_declaration = core_type list
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index 1bb957f4c..f41193586 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -318,6 +318,7 @@ and type_kind i ppf x =
   | Ptype_record (l) ->
       line i ppf "Ptype_record\n";
       list (i+1) string_x_mutable_flag_x_core_type ppf l;
+  | Ptype_virtual x -> type_kind i ppf x
 
 and exception_declaration i ppf x = list i core_type ppf x
 
diff --git a/stdlib/format.ml b/stdlib/format.ml
index 4e1b86485..eab4f575e 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -938,7 +938,7 @@ let fprintf_out str out ppf format =
     else
       match format.[i] with
       | '%' ->
-          Printf.scan_format format i cont_s cont_a cont_t
+          Printf.scan_format format i cont_s cont_a cont_t cont_f
       | '@' ->
           let i = succ i in
           if i >= limit then invalid_format format i else
@@ -998,6 +998,8 @@ let fprintf_out str out ppf format =
     else
       printer ppf;
     doprn i
+  and cont_f i =
+    pp_print_flush ppf (); doprn i
 
   and get_int i c =
    if i >= limit then invalid_integer format i else
@@ -1006,8 +1008,9 @@ let fprintf_out str out ppf format =
    | '%' ->
       let cont_s s i = c (format_int_of_string format i s) i
       and cont_a printer arg i = invalid_integer format i
-      and cont_t printer i = invalid_integer format i in
-      Printf.scan_format format i cont_s cont_a cont_t
+      and cont_t printer i = invalid_integer format i
+      and cont_f i = invalid_integer format i in
+      Printf.scan_format format i cont_s cont_a cont_t cont_f
    | _ ->
       let rec get j =
        if j >= limit then invalid_integer format j else
@@ -1064,8 +1067,10 @@ let fprintf_out str out ppf format =
          let s =
            if str then (Obj.magic printer) ()
            else exstring (fun ppf () -> printer ppf) () in
-         get (s :: s0 :: accu) i i in
-       Printf.scan_format format j cont_s cont_a cont_t
+         get (s :: s0 :: accu) i i
+       and cont_f i =
+         format_invalid_arg "bad tag name specification" format i in
+       Printf.scan_format format j cont_s cont_a cont_t cont_f
     | c -> get accu i (succ j) in
    get [] i i
 
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index e0f99ef7a..c8c336203 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -35,7 +35,7 @@ let parse_format format =
         parse true (succ i)
     | _ ->
         parse neg (succ i) in
-    try parse false 1 with Failure _ -> bad_format format 0
+  try parse false 1 with Failure _ -> bad_format format 0
 
 (* Pad a (sub) string into a blank string of length [p],
    on the right if [neg] is true, on the left otherwise. *)
@@ -54,31 +54,6 @@ let format_string format s =
   let (p, neg) = parse_format format in
   pad_string ' ' p neg s 0 (String.length s)
 
-(* Format a string given a %s format, e.g. %40s or %-20s.
-   To do: ignore other flags (#, +, etc)? *)
-
-let format_string format s =
-  let rec parse_format neg i =
-    if i >= String.length format then (0, neg) else
-    match String.unsafe_get format i with
-    | '1'..'9' ->
-        (int_of_string (String.sub format i (String.length format - i - 1)),
-         neg)
-    | '-' ->
-        parse_format true (succ i)
-    | _ ->
-        parse_format neg (succ i) in
-  let (p, neg) =
-    try parse_format false 1 with Failure _ -> bad_format format 0 in
-  if String.length s < p then begin
-    let res = String.make p ' ' in
-    if neg
-    then String.blit s 0 res 0 (String.length s)
-    else String.blit s 0 res (p - String.length s) (String.length s);
-    res
-  end else
-    s
-
 (* Format a [%b] format: write a binary representation of an integer. *)
 let format_binary_int format n =
   let sharp = String.contains format '#' in
@@ -97,7 +72,7 @@ let format_binary_int format n =
     match String.unsafe_get format i with
     | '0' -> '0'
     | '1' .. '9' -> ' '
-    | _ ->  find_pad_char (i + 1) len in
+    | _ -> find_pad_char (i + 1) len in
   let add_sharp s i =
     String.unsafe_set s i '0';
     String.unsafe_set s (i + 1) 'b' in
@@ -161,7 +136,7 @@ let format_int_with_conv conv fmt i =
    caught by the [_ -> bad_format] clauses below.
    Don't do this at home, kids. *)
 
-let scan_format fmt pos cont_s cont_a cont_t =
+let scan_format fmt pos cont_s cont_a cont_t cont_f =
   let rec scan_flags widths i =
     match String.unsafe_get fmt i with
     | '*' ->
@@ -237,6 +212,8 @@ let scan_format fmt pos cont_s cont_a cont_t =
         | _ ->
             bad_format fmt pos
         end
+    | '$' ->
+        Obj.magic (cont_f (succ i))
     | _ ->
         bad_format fmt pos
   in scan_flags [] (pos + 1)
@@ -249,7 +226,7 @@ let fprintf chan fmt =
   let rec doprn i =
     if i >= len then Obj.magic () else
     match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
     |  c  -> output_char chan c; doprn (succ i)
   and cont_s s i =
     output_string chan s; doprn i
@@ -257,6 +234,8 @@ let fprintf chan fmt =
     printer chan arg; doprn i
   and cont_t printer i =
     printer chan; doprn i
+  and cont_f i =
+    flush chan; doprn i
   in doprn 0
 
 let printf fmt = fprintf stdout fmt
@@ -273,7 +252,7 @@ let kprintf kont fmt =
       Obj.magic (kont res)
     end else
     match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
     |  c  -> Buffer.add_char dest c; doprn (succ i)
   and cont_s s i =
     Buffer.add_string dest s; doprn i
@@ -281,6 +260,7 @@ let kprintf kont fmt =
     Buffer.add_string dest (printer () arg); doprn i
   and cont_t printer i =
     Buffer.add_string dest (printer ()); doprn i
+  and cont_f i = doprn i
   in doprn 0
 
 let sprintf fmt = kprintf (fun x -> x) fmt;;
@@ -291,7 +271,7 @@ let bprintf dest fmt =
   let rec doprn i =
     if i >= len then Obj.magic () else
     match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t
+    | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f
     |  c  -> Buffer.add_char dest c; doprn (succ i)
   and cont_s s i =
     Buffer.add_string dest s; doprn i
@@ -299,6 +279,7 @@ let bprintf dest fmt =
     printer dest arg; doprn i
   and cont_t printer i =
     printer dest; doprn i
+  and cont_f i = doprn i
   in doprn 0
 
 
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index fac8a9fa5..1a19081fd 100644
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -119,4 +119,4 @@ val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format -> 'b
 
 val scan_format :
   string -> int -> (string -> int -> 'a) -> ('b -> 'c -> int -> 'a) ->
-    ('e -> int -> 'a) -> 'a
+    ('e -> int -> 'a) -> (int -> 'a) -> 'a
diff --git a/tools/depend.ml b/tools/depend.ml
index 4f543a192..98772d8ec 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -67,12 +67,14 @@ let add_type_declaration bv td =
     (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
     td.ptype_cstrs;
   add_opt add_type bv td.ptype_manifest;
-  match td.ptype_kind with
+  let rec add_tkind = function
     Ptype_abstract -> ()
   | Ptype_variant cstrs ->
       List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
   | Ptype_record lbls ->
       List.iter (fun (l, mut, ty) -> add_type bv ty) lbls
+  | Ptype_virtual tkind -> add_tkind tkind in
+  add_tkind td.ptype_kind
 
 let rec add_class_type bv cty =
   match cty.pcty_desc with
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 98152421a..c5c0d9e88 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -236,7 +236,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
           | Tconstr(path, ty_list, _) ->
               begin try
                 let decl = Env.find_type path env in
-                match decl with
+                let rec tree_decl = function
                 | {type_kind = Type_abstract; type_manifest = None} ->
                     Oval_stuff "<abstr>"
                 | {type_kind = Type_abstract; type_manifest = Some body} ->
@@ -259,7 +259,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                     tree_of_constr_with_args (tree_of_constr env path)
                                            constr_name 0 depth obj ty_args
                 | {type_kind = Type_record(lbl_list, rep)} ->
-                    match check_depth depth obj ty with
+                    begin match check_depth depth obj ty with
                       Some x -> x
                     | None ->
                         let rec tree_of_fields pos = function
@@ -279,6 +279,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
                               (lid, v) :: tree_of_fields (pos + 1) remainder
                         in
                         Oval_record (tree_of_fields 0 lbl_list)
+                    end
+                | {type_kind = Type_virtual tkind} ->
+                    tree_decl {decl with type_kind = tkind} in
+                tree_decl decl
               with
                 Not_found ->                (* raised by Env.find_type *)
                   Oval_stuff "<abstr>"
diff --git a/typing/btype.ml b/typing/btype.ml
index 59093f06f..c6fa59fba 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -249,13 +249,14 @@ let rec unmark_type ty =
 
 let unmark_type_decl decl =
   List.iter unmark_type decl.type_params;
-  begin match decl.type_kind with
+  let rec unmark_tkind = function
     Type_abstract -> ()
   | Type_variant cstrs ->
       List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
   | Type_record(lbls, rep) ->
       List.iter (fun (c, mut, t) -> unmark_type t) lbls
-  end;
+  | Type_virtual tkind -> unmark_tkind tkind in
+  unmark_tkind decl.type_kind;
   begin match decl.type_manifest with
     None    -> ()
   | Some ty -> unmark_type ty
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 17c3f6e4c..42a4b71a6 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -422,14 +422,15 @@ let closed_parameterized_type params ty =
 let closed_type_decl decl =
   try
     List.iter mark_type decl.type_params;
-    begin match decl.type_kind with
+    let rec closed_tkind = function
       Type_abstract ->
         ()
     | Type_variant v ->
         List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
     | Type_record(r, rep) ->
         List.iter (fun (_, _, ty) -> closed_type ty) r
-    end;
+    | Type_virtual tkind -> closed_tkind tkind in
+    closed_tkind decl.type_kind;
     begin match decl.type_manifest with
       None    -> ()
     | Some ty -> closed_type ty
@@ -3051,7 +3052,7 @@ let nondep_type_decl env mid id is_covariant decl =
         type_arity = decl.type_arity;
         type_kind =
           begin try
-            match decl.type_kind with
+            let rec kind_of_tkind = function
               Type_abstract ->
                 Type_abstract
             | Type_variant cstrs ->
@@ -3064,6 +3065,8 @@ let nondep_type_decl env mid id is_covariant decl =
                     (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t))
                     lbls,
                   rep)
+            | Type_virtual tkind -> Type_virtual (kind_of_tkind tkind) in
+            kind_of_tkind decl.type_kind
           with Not_found when is_covariant ->
             Type_abstract
           end;
@@ -3081,13 +3084,14 @@ let nondep_type_decl env mid id is_covariant decl =
     in
     cleanup_types ();
     List.iter unmark_type decl.type_params;
-    begin match decl.type_kind with
+    let rec unmark_tkind = function
       Type_abstract -> ()
     | Type_variant cstrs ->
         List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
     | Type_record(lbls, rep) ->
         List.iter (fun (c, mut, t) -> unmark_type t) lbls
-    end;
+    | Type_virtual tkind -> unmark_tkind tkind in
+    unmark_tkind decl.type_kind;
     begin match decl.type_manifest with
       None    -> ()
     | Some ty -> unmark_type ty
diff --git a/typing/env.ml b/typing/env.ml
index 1e93b40ff..341b4c517 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -363,7 +363,7 @@ and lookup_class =
   lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
 and lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
-  
+
 (* Expand manifest module type names at the top of the given module type *)
 
 let rec scrape_modtype mty env =
@@ -379,22 +379,27 @@ let rec scrape_modtype mty env =
 (* Compute constructor descriptions *)
 
 let constructors_of_type ty_path decl =
-  match decl.type_kind with
+  let rec constructors_of_tkind = function
     Type_variant cstrs ->
       Datarepr.constructor_descrs
         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         cstrs
-  | _ -> []
+  | Type_virtual tkind -> constructors_of_tkind tkind
+  | _ -> [] in
+  constructors_of_tkind decl.type_kind
+
 
 (* Compute label descriptions *)
 
 let labels_of_type ty_path decl =
-  match decl.type_kind with
+  let rec labels_of_tkind = function
     Type_record(labels, rep) ->
       Datarepr.label_descrs
         (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
         labels rep
-  | _ -> []
+  | Type_virtual tkind -> labels_of_tkind tkind
+  | _ -> [] in
+  labels_of_tkind decl.type_kind
 
 (* Given a signature and a root path, prefix all idents in the signature
    by the root path and build the corresponding substitution. *)
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 9a8c94147..f70caba89 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -38,7 +38,7 @@ let value_descriptions env vd1 vd2 =
 
 let type_declarations env id decl1 decl2 =
   decl1.type_arity = decl2.type_arity &&
-  begin match (decl1.type_kind, decl2.type_kind) with
+  let rec incl_tkinds = function
       (_, Type_abstract) -> true
     | (Type_variant cstrs1, Type_variant cstrs2) ->
         Misc.for_all2
@@ -58,8 +58,11 @@ let type_declarations env id decl1 decl2 =
             Ctype.equal env true (ty1::decl1.type_params)
                                  (ty2::decl2.type_params))
           labels1 labels2
-    | (_, _) -> false
-  end &&
+    | (Type_virtual tkind1, Type_virtual tkind2) -> incl_tkinds (tkind1, tkind2)
+    | (tkind1, Type_virtual tkind2) -> incl_tkinds (tkind1, tkind2)
+    | (_, _) -> false in
+  incl_tkinds (decl1.type_kind, decl2.type_kind)
+  &&
   begin match (decl1.type_manifest, decl2.type_manifest) with
       (_, None) ->
         Ctype.equal env true decl1.type_params decl2.type_params
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index c9a6bb0fb..a113e1015 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -409,14 +409,15 @@ let rec tree_of_type_decl id decl =
   | None -> ()
   | Some ty -> mark_loops ty
   end;
-  begin match decl.type_kind with
+  let rec mark = function
   | Type_abstract -> ()
   | Type_variant [] -> ()
   | Type_variant cstrs ->
       List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
   | Type_record(l, rep) ->
       List.iter (fun (_, _, ty) -> mark_loops ty) l
-  end;
+  | Type_virtual tkind -> mark tkind in
+  mark decl.type_kind;
 
   let type_param =
     function
@@ -447,8 +448,7 @@ 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 =
-    match decl.type_kind with
+  let rec tree_of_tkind = function
     | Type_abstract ->
         begin match decl.type_manifest with
         | None -> Otyp_abstract
@@ -458,6 +458,8 @@ let rec tree_of_type_decl id decl =
         tree_of_manifest decl (Otyp_sum (List.map tree_of_constructor cstrs))
     | Type_record(lbls, rep) ->
         tree_of_manifest decl (Otyp_record (List.map tree_of_label lbls))
+    | Type_virtual tkind -> tree_of_tkind tkind in
+  let ty = tree_of_tkind decl.type_kind 
   in
   (name, args, ty, constraints)
 
diff --git a/typing/subst.ml b/typing/subst.ml
index 32452902b..b40079b65 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -154,7 +154,8 @@ let type_declaration s decl =
     { type_params = List.map (typexp s) decl.type_params;
       type_arity = decl.type_arity;
       type_kind =
-        begin match decl.type_kind with
+        begin
+        let rec kind_of_tkind = function
           Type_abstract -> Type_abstract
         | Type_variant cstrs ->
             Type_variant(
@@ -165,6 +166,8 @@ let type_declaration s decl =
               List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
                        lbls,
               rep)
+        | Type_virtual tkind -> Type_virtual (kind_of_tkind tkind) in
+        kind_of_tkind decl.type_kind
         end;
       type_manifest =
         begin match decl.type_manifest with
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d1a8605be..351f254bf 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -42,6 +42,8 @@ type error =
   | Undefined_inherited_method of string
   | Unbound_class of Longident.t
   | Virtual_class of Longident.t
+  | Virtual_type of string
+  | Virtual_type_setfield of Longident.t * string
   | Unbound_instance_variable of string
   | Instance_variable_not_mutable of string
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
@@ -93,20 +95,38 @@ let extract_option_type env ty =
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
-let rec extract_label_names env ty =
+let rec extract_label_names sexp env ty =
   let ty = repr ty in
   match ty.desc with
   | Tconstr (path, _, _) ->
       let td = Env.find_type path env in
-      begin match td.type_kind with
+      let rec extract = function
       | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields
       | Type_abstract when td.type_manifest <> None ->
-          extract_label_names env (expand_head env ty)
-      | _ -> assert false
-      end
+          extract_label_names sexp env (expand_head env ty)
+      | Type_virtual tkind ->
+          raise (Error(sexp.pexp_loc, Virtual_type (Path.name path)))
+      | _ -> assert false in
+      extract td.type_kind
   | _ ->
       assert false
 
+let check_virtual get_exc loc env ty =
+  let ty = repr ty in
+  match ty.desc with
+  | Tconstr (path, _, _) ->
+      let td = Env.find_type path env in
+      begin match td.type_kind with
+      | Type_virtual tkind ->
+          raise (Error(loc, get_exc (Path.name path)))
+      | _ -> () end
+  | _ ->
+      assert false
+
+let check_virtual_type = check_virtual (fun s -> Virtual_type s)
+let check_virtual_type_setfield lid =
+  check_virtual (fun s -> Virtual_type_setfield (lid, s))
+
 (* Typing of patterns *)
 
 (* Creating new conjunctive types is not allowed when typing patterns *)
@@ -632,7 +652,7 @@ let type_format loc fmt =
     and scan_conversion i j =
       if j >= len then incomplete i else
       match fmt.[j] with
-      | '%' -> scan_format (j + 1)
+      | '%' | '$' -> scan_format (j + 1)
       | 's' | 'S' | '[' -> conversion j Predef.type_string
       | 'c' | 'C' -> conversion j Predef.type_char
       | 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
@@ -913,7 +933,7 @@ let rec type_exp env sexp =
       if opt_sexp = None && List.length lid_sexp_list <> !num_fields then begin
         let present_indices =
           List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
-        let label_names = extract_label_names env ty in
+        let label_names = extract_label_names sexp env ty in
         let rec missing_labels n = function
             [] -> []
           | lbl :: rem ->
@@ -923,6 +943,7 @@ let rec type_exp env sexp =
         let missing = missing_labels 0 label_names in
         raise(Error(sexp.pexp_loc, Label_missing missing))
       end;
+      check_virtual_type sexp.pexp_loc env ty;
       { exp_desc = Texp_record(lbl_exp_list, opt_exp);
         exp_loc = sexp.pexp_loc;
         exp_type = ty;
@@ -957,6 +978,7 @@ let rec type_exp env sexp =
       if vars <> [] && not (is_nonexpansive newval) then
         generalize_expansive env newval.exp_type;
       check_univars env "field value" newval label.lbl_arg vars;
+      check_virtual_type_setfield lid sexp.pexp_loc env ty_res;
       { exp_desc = Texp_setfield(record, label, newval);
         exp_loc = sexp.pexp_loc;
         exp_type = instance Predef.type_unit;
@@ -1530,6 +1552,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
       exp_env = env } in
   unify_exp env texp ty_expected;
   let args = List.map2 (type_argument env) sargs ty_args in
+  check_virtual_type loc env ty_res;
   { texp with exp_desc = Texp_construct(constr, args) }
 
 (* Typing of an expression with an expected type.
@@ -1866,7 +1889,7 @@ let report_error ppf = function
       fprintf ppf "Unbound class %a" longident cl
   | Virtual_class cl ->
       fprintf ppf "One cannot create instances of the virtual class %a"
-      longident cl
+        longident cl
   | Unbound_instance_variable v ->
       fprintf ppf "Unbound instance variable %s" v
   | Instance_variable_not_mutable v ->
@@ -1919,6 +1942,11 @@ let report_error ppf = function
         "The instance variable %a@ \
          cannot be accessed from the definition of another instance variable"
         longident lid
+  | Virtual_type ty ->
+      fprintf ppf "One cannot create values of the virtual type %s" ty
+  | Virtual_type_setfield (lid, ty) ->
+      fprintf ppf "Cannot assign field %a of the virtual type %s"
+        longident lid ty
   | Not_a_variant_type lid ->
       fprintf ppf "The type %a@ is not a variant type" longident lid
   | Incoherent_label_order ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index c4112183a..9a5531801 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -79,6 +79,8 @@ type error =
   | Undefined_inherited_method of string
   | Unbound_class of Longident.t
   | Virtual_class of Longident.t
+  | Virtual_type of string
+  | Virtual_type_setfield of Longident.t * string
   | Unbound_instance_variable of string
   | Instance_variable_not_mutable of string
   | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index c9d351939..4993fcfb1 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -103,7 +103,7 @@ let transl_declaration env (name, sdecl) id =
     { type_params = params;
       type_arity = List.length params;
       type_kind =
-        begin match sdecl.ptype_kind with
+        begin let rec get_tkind = function
           Ptype_abstract ->
             Type_abstract
         | Ptype_variant cstrs ->
@@ -140,7 +140,9 @@ let transl_declaration env (name, sdecl) id =
               then Record_float
               else Record_regular in
             Type_record(lbls', rep)
-        end;
+        | Ptype_virtual kind -> Type_virtual (get_tkind kind) in
+        get_tkind sdecl.ptype_kind
+      end;
       type_manifest =
         begin match sdecl.ptype_manifest with
           None -> None
@@ -167,14 +169,16 @@ let transl_declaration env (name, sdecl) id =
 
 let generalize_decl decl =
   List.iter Ctype.generalize decl.type_params;
-  begin match decl.type_kind with
+  let rec gen = function
     Type_abstract ->
       ()
   | Type_variant v ->
       List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
   | Type_record(r, rep) ->
       List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
-  end;
+  | Type_virtual tkind ->
+      gen tkind in
+  gen decl.type_kind;
   begin match decl.type_manifest with
     None    -> ()
   | Some ty -> Ctype.generalize ty
@@ -216,12 +220,15 @@ let rec check_constraints_rec env loc visited ty =
 
 let check_constraints env (_, sdecl) (_, decl) =
   let visited = ref TypeSet.empty in
-  begin match decl.type_kind with
+  let rec check = function
   | Type_abstract -> ()
   | Type_variant l ->
-      let pl =
-        match sdecl.ptype_kind with Ptype_variant pl -> pl | _ -> assert false
+      let rec find_pl = function
+          Ptype_variant pl -> pl
+        | Ptype_virtual tkind -> find_pl tkind
+        | Ptype_record _ | Ptype_abstract -> assert false
       in
+      let pl = find_pl sdecl.ptype_kind in
       List.iter
         (fun (name, tyl) ->
           let styl = try List.assoc name pl with Not_found -> assert false in
@@ -230,9 +237,12 @@ let check_constraints env (_, sdecl) (_, decl) =
             styl tyl)
         l
   | Type_record (l, _) ->
-      let pl =
-        match sdecl.ptype_kind with Ptype_record pl -> pl | _ -> assert false
+      let rec find_pl = function
+          Ptype_record pl -> pl
+        | Ptype_virtual tkind -> find_pl tkind
+        | Ptype_variant _ | Ptype_abstract -> assert false
       in
+      let pl = find_pl sdecl.ptype_kind in
       let rec get_loc name = function
           [] -> assert false
         | (name', _, sty) :: tl ->
@@ -242,7 +252,8 @@ let check_constraints env (_, sdecl) (_, decl) =
         (fun (name, _, ty) ->
           check_constraints_rec env (get_loc name pl) visited ty)
         l
-  end;
+  | Type_virtual tkind -> check tkind in
+  check decl.type_kind;
   begin match decl.type_manifest with
   | None -> ()
   | Some ty ->
@@ -403,7 +414,7 @@ let compute_variance_decl env decl (required, loc) =
   else
   let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false))
       decl.type_params in
-  begin match decl.type_kind with
+  let rec variance_tkind = function
     Type_abstract ->
       begin match decl.type_manifest with
         None -> assert false
@@ -417,7 +428,8 @@ let compute_variance_decl env decl (required, loc) =
       List.iter
         (fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
         ftl
-  end;
+  | Type_virtual tkind -> variance_tkind tkind in
+  variance_tkind decl.type_kind;
   List.map2
     (fun (_, co, cn) (c, n) ->
       if c && !cn || n && !co then raise (Error(loc, Bad_variance));
diff --git a/typing/types.ml b/typing/types.ml
index 0b9c4350f..b7ddd3141 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -140,6 +140,7 @@ and type_kind =
   | Type_variant of (string * type_expr list) list
   | Type_record of (string * mutable_flag * type_expr) list
                  * record_representation
+  | Type_virtual of type_kind
 
 type exception_declaration = type_expr list
 
diff --git a/typing/types.mli b/typing/types.mli
index 096ced67a..019d8fb7c 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -141,6 +141,7 @@ and type_kind =
   | Type_variant of (string * type_expr list) list
   | Type_record of (string * mutable_flag * type_expr) list
                  * record_representation
+  | Type_virtual of type_kind
 
 type exception_declaration = type_expr list