Closing a long standing bug in the implementation of printf-like

functions: partially applied printf functions were printing material
as soon as the first argument was applied (and even before: printing
started as soon as the format string was provided).
This is the first step towards the implementation of $ formats
(i.e. formats that can access directly to any of their arguments,
using a $n notation to denote the nth argument (``a la Yacc'')). This
is supposed to be mandatory to internationalisation of messages.


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

4 files changed, 549 insertions, 448 deletions

diff --git a/stdlib/format.ml b/stdlib/format.ml
index 7a46c31ca..161cbd8ce 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -19,6 +19,11 @@
 
  **************************************************************)
 
+type size;;
+
+external size_of_int : int -> size = "%identity";;
+external int_of_size : size -> int = "%identity";;
+
 (* Tokens are one of the following : *)
 
 type pp_token =
@@ -58,7 +63,9 @@ and tblock = Pp_tbox of int list ref  (* Tabulation box *)
    elements are tuples (size, token, length), where
    size is set when the size of the block is known
    len is the declared length of the token. *)
-type pp_queue_elem = {mutable elem_size : int; token : pp_token; length : int};;
+type pp_queue_elem = {
+  mutable elem_size : size; token : pp_token; length : int
+};;
 
 (* Scan stack:
    each element is (left_total, queue element) where left_total
@@ -249,7 +256,7 @@ let pp_skip_token state =
     match take_queue state.pp_queue with
     {elem_size = size; length = len} ->
        state.pp_left_total <- state.pp_left_total - len;
-       state.pp_space_left <- state.pp_space_left + size;;
+       state.pp_space_left <- state.pp_space_left + int_of_size size;;
 
 (**************************************************************
 
@@ -379,6 +386,7 @@ let rec advance_left state =
     try
      match peek_queue state.pp_queue with
       {elem_size = size; token = tok; length = len} ->
+       let size = int_of_size size in
        if not
         (size < 0 &&
          (state.pp_right_total - state.pp_left_total < state.pp_space_left))
@@ -393,17 +401,24 @@ let rec advance_left state =
 let enqueue_advance state tok = pp_enqueue state tok; advance_left state;;
 
 (* To enqueue a string : try to advance. *)
-let enqueue_string_as state n s =
-    enqueue_advance state {elem_size = n; token = Pp_text s; length = n};;
+let make_queue_elem size tok len =
+ {elem_size = size; token = tok; length = len};;
 
-let enqueue_string state s = enqueue_string_as state (String.length s) s;;
+let enqueue_string_as state size s =
+  let len = int_of_size size in
+  enqueue_advance state (make_queue_elem size (Pp_text s) len);;
+
+let enqueue_string state s =
+  let len = String.length s in
+  enqueue_string_as state (size_of_int len) s;;
 
 (* Routines for scan stack
    determine sizes of blocks. *)
 
 (* The scan_stack is never empty. *)
 let scan_stack_bottom =
-    [Scan_elem (-1, {elem_size = (-1); token = Pp_text ""; length = 0})];;
+  let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in
+  [Scan_elem (-1, q_elem)];;
 
 (* Set size of blocks on scan stack:
    if ty = true then size of break is set else size of block is set;
@@ -416,21 +431,23 @@ let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom;;
    since scan_push is used on breaks and opening of boxes. *)
 let set_size state ty =
     match state.pp_scan_stack with
-    | Scan_elem (left_tot,
-                 ({elem_size = size; token = tok} as queue_elem)) :: t ->
+    | Scan_elem
+        (left_tot,
+         ({elem_size = size; token = tok} as queue_elem)) :: t ->
+       let size = int_of_size size in
        (* test if scan stack contains any data that is not obsolete. *)
        if left_tot < state.pp_left_total then clear_scan_stack state else
         begin match tok with
         | Pp_break (_, _) | Pp_tbreak (_, _) ->
            if ty then
             begin
-             queue_elem.elem_size <- state.pp_right_total + size;
+             queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
              state.pp_scan_stack <- t
             end
         | Pp_begin (_, _) ->
            if not ty then
             begin
-             queue_elem.elem_size <- state.pp_right_total + size;
+             queue_elem.elem_size <- size_of_int (state.pp_right_total + size);
              state.pp_scan_stack <- t
             end
         | _ -> () (* scan_push is only used for breaks and boxes. *)
@@ -450,9 +467,12 @@ let scan_push state b tok =
 let pp_open_box_gen state indent br_ty =
     state.pp_curr_depth <- state.pp_curr_depth + 1;
     if state.pp_curr_depth < state.pp_max_boxes then
-      (scan_push state false
-        {elem_size = (- state.pp_right_total);
-         token = Pp_begin (indent, br_ty); length = 0}) else
+      let elem =
+        make_queue_elem
+          (size_of_int (- state.pp_right_total))
+          (Pp_begin (indent, br_ty))
+          0 in
+      scan_push state false elem else
     if state.pp_curr_depth = state.pp_max_boxes
     then enqueue_string state state.pp_ellipsis;;
 
@@ -465,7 +485,8 @@ let pp_close_box state () =
      begin
       if state.pp_curr_depth < state.pp_max_boxes then
        begin
-        pp_enqueue state {elem_size = 0; token = Pp_end; length = 0};
+        pp_enqueue state
+          {elem_size = size_of_int 0; token = Pp_end; length = 0};
         set_size state true; set_size state false
        end;
       state.pp_curr_depth <- state.pp_curr_depth - 1;
@@ -478,12 +499,13 @@ let pp_open_tag state tag_name =
       state.pp_print_open_tag tag_name end;
     if state.pp_mark_tags then
       pp_enqueue state
-        {elem_size = 0; token = Pp_open_tag tag_name; length = 0};;
+        {elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0};;
 
 (* Close a tag, popping it from the tag stack. *)
 let pp_close_tag state () =
     if state.pp_mark_tags then
-      pp_enqueue state {elem_size = 0; token = Pp_close_tag; length = 0};
+      pp_enqueue state
+        {elem_size = size_of_int 0; token = Pp_close_tag; length = 0};
     if state.pp_print_tags then
       begin match state.pp_tag_stack with
       | tag_name :: tags ->
@@ -546,11 +568,15 @@ let pp_flush_queue state b =
  **************************************************************)
 
 (* To format a string. *)
-let pp_print_as state n s =
+let pp_print_as_size state size s =
   if state.pp_curr_depth < state.pp_max_boxes
-  then enqueue_string_as state n s;;
+  then enqueue_string_as state size s;;
 
-let pp_print_string state s = pp_print_as state (String.length s) s;;
+let pp_print_as state isize s =
+  pp_print_as_size state (size_of_int isize) s;;
+
+let pp_print_string state s =
+  pp_print_as state (String.length s) s;;
 
 (* To format an integer. *)
 let pp_print_int state i = pp_print_string state (string_of_int i);;
@@ -563,7 +589,9 @@ let pp_print_bool state b = pp_print_string state (string_of_bool b);;
 
 (* To format a char. *)
 let pp_print_char state c =
-  let s = String.create 1 in s.[0] <- c; pp_print_as state 1 s;;
+  let s = String.create 1 in
+  s.[0] <- c;
+  pp_print_as state 1 s;;
 
 (* Opening boxes. *)
 let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
@@ -583,12 +611,12 @@ and pp_print_flush state () =
 (* To get a newline when one does not want to close the current block. *)
 let pp_force_newline state () =
   if state.pp_curr_depth < state.pp_max_boxes then
-    enqueue_advance state {elem_size = 0; token = Pp_newline; length = 0};;
+    enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0);;
 
 (* To format something if the line has just been broken. *)
 let pp_print_if_newline state () =
   if state.pp_curr_depth < state.pp_max_boxes then
-    enqueue_advance state {elem_size = 0; token = Pp_if_newline; length = 0};;
+    enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0);;
 
 (* Breaks: indicate where a block may be broken.
    If line is broken then offset is added to the indentation of the current
@@ -596,9 +624,12 @@ let pp_print_if_newline state () =
    To do (?) : add a maximum width and offset value. *)
 let pp_print_break state width offset =
   if state.pp_curr_depth < state.pp_max_boxes then
-    scan_push state true
-     {elem_size = (- state.pp_right_total); token = Pp_break (width, offset);
-      length = width};;
+    let elem =
+      make_queue_elem
+        (size_of_int (- state.pp_right_total))
+        (Pp_break (width, offset))
+        width in
+    scan_push state true elem;;
 
 let pp_print_space state () = pp_print_break state 1 0
 and pp_print_cut state () = pp_print_break state 0 0;;
@@ -607,29 +638,35 @@ and pp_print_cut state () = pp_print_break state 0 0;;
 let pp_open_tbox state () =
   state.pp_curr_depth <- state.pp_curr_depth + 1;
   if state.pp_curr_depth < state.pp_max_boxes then
-    enqueue_advance state
-      {elem_size = 0;
-       token = Pp_tbegin (Pp_tbox (ref [])); length = 0};;
+    let elem =
+      make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in
+    enqueue_advance state elem;;
 
 (* Close a tabulation block. *)
 let pp_close_tbox state () =
   if state.pp_curr_depth > 1 then begin
    if state.pp_curr_depth < state.pp_max_boxes then
-    enqueue_advance state {elem_size = 0; token = Pp_tend; length = 0};
-   state.pp_curr_depth <- state.pp_curr_depth - 1 end;;
+     let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in
+     enqueue_advance state elem;
+     state.pp_curr_depth <- state.pp_curr_depth - 1 end;;
 
 (* Print a tabulation break. *)
 let pp_print_tbreak state width offset =
   if state.pp_curr_depth < state.pp_max_boxes then
-    scan_push state true
-     {elem_size = (- state.pp_right_total); token = Pp_tbreak (width, offset);
-      length = width};;
+    let elem =
+      make_queue_elem
+        (size_of_int (- state.pp_right_total))
+        (Pp_tbreak (width, offset))
+        width in
+    scan_push state true elem;;
 
 let pp_print_tab state () = pp_print_tbreak state 0 0;;
 
 let pp_set_tab state () =
-  if state.pp_curr_depth < state.pp_max_boxes
-  then enqueue_advance state {elem_size = 0; token = Pp_stab; length=0};;
+  if state.pp_curr_depth < state.pp_max_boxes then
+    let elem =
+      make_queue_elem (size_of_int 0) Pp_stab 0 in
+    enqueue_advance state elem;;
 
 (**************************************************************
 
@@ -719,7 +756,7 @@ let pp_make_formatter f g h i =
  (* The initial state of the formatter contains a dummy box. *)
  let pp_q = make_queue () in
  let sys_tok =
-     {elem_size = (- 1); token = Pp_begin (0, Pp_hovbox); length = 0} in
+   make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in
  add_queue sys_tok pp_q;
  let sys_scan_stack =
      (Scan_elem (1, sys_tok)) :: scan_stack_bottom in
@@ -774,10 +811,8 @@ let make_formatter f g =
 let formatter_of_out_channel oc =
   make_formatter (output oc) (fun () -> flush oc);;
 
-let unit_out ppf = ();;
-
 let formatter_of_buffer b =
-  make_formatter (Buffer.add_substring b) unit_out;;
+  make_formatter (Buffer.add_substring b) ignore;;
 
 let stdbuf = Buffer.create 512;;
 
@@ -897,8 +932,10 @@ let invalid_integer fmt i =
 
 (* Finding an integer out of a sub-string of the format. *)
 let format_int_of_string fmt i s =
-  try int_of_string s with
-  | Failure s -> invalid_integer fmt i;;
+  let sz =
+    try int_of_string s with
+    | Failure s -> invalid_integer fmt i in
+  size_of_int sz;;
 
 (* Getting strings out of buffers. *)
 let get_buffer_out b =
@@ -926,6 +963,8 @@ let implode_rev s0 = function
   | [] -> s0
   | l -> String.concat "" (List.rev (s0 :: l));;
 
+external format_to_string : ('a, 'b, 'c, 'd) format4 -> string = "%identity";;
+
 (* [fprintf_out] is the printf-like function generator: given the
    - [str] flag that tells if we are printing into a string,
    - the [out] function that has to be called at the end of formatting,
@@ -934,204 +973,216 @@ let implode_rev s0 = function
    according to the format.
    Regular [fprintf]-like functions of this module are obtained via partial
    applications of [fprintf_out]. *)
-let rec fprintf_out str out ppf fmt =
-
-  let fmt = string_of_format fmt in
-  let limit = String.length fmt in
-
-  let print_as = ref None in
-
-  let pp_print_as_char c =
-      match !print_as with
-      | None -> pp_print_char ppf c
-      | Some size ->
-         pp_print_as ppf size (String.make 1 c);
-         print_as := None
-  and pp_print_as_string s =
-      match !print_as with
-      | None -> pp_print_string ppf s
-      | Some size ->
-         pp_print_as ppf size s;
-         print_as := None in
-
-  let rec doprn i =
-    if i >= limit then Obj.magic (out ppf) else
-    match fmt.[i] with
-    | '%' ->
-        Printf.scan_format fmt i cont_s cont_a cont_t cont_f cont_m
-    | '@' ->
-        let i = succ i in
-        if i >= limit then invalid_format fmt i else
-        begin match fmt.[i] with
-        | '[' ->
-           do_pp_open_box ppf (succ i)
-        | ']' ->
-           pp_close_box ppf ();
-           doprn (succ i)
-        | '{' ->
-           do_pp_open_tag ppf (succ i)
-        | '}' ->
-           pp_close_tag ppf ();
-           doprn (succ i)
-        | ' ' ->
-           pp_print_space ppf ();
-           doprn (succ i)
-        | ',' ->
-           pp_print_cut ppf ();
-           doprn (succ i)
-        | '?' ->
-           pp_print_flush ppf ();
-           doprn (succ i)
-        | '.' ->
-           pp_print_newline ppf ();
-           doprn (succ i)
-        | '\n' ->
-           pp_force_newline ppf ();
-           doprn (succ i)
-        | ';' ->
-           do_pp_break ppf (succ i)
-        | '<' ->
-           let got_size size i =
-             print_as := Some size;
-             doprn (skip_gt i) in
-           get_int (succ i) got_size
-        | '@' as c ->
+let mkprintf str get_out =
+  let rec kprintf k fmt =
+    let fmt = format_to_string fmt in
+    let len = String.length fmt in
+
+    let kpr fmt v =
+      let ppf = get_out fmt in
+      let print_as = ref None in
+      let pp_print_as_char c =
+          match !print_as with
+          | None -> pp_print_char ppf c
+          | Some size ->
+             pp_print_as_size ppf size (String.make 1 c);
+             print_as := None
+      and pp_print_as_string s =
+          match !print_as with
+          | None -> pp_print_string ppf s
+          | Some size ->
+             pp_print_as_size ppf size s;
+             print_as := None in
+
+      let rec doprn n i =
+        if i >= len then Obj.magic (k ppf) else
+        match fmt.[i] with
+        | '%' ->
+            Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+        | '@' ->
+            let i = succ i in
+            if i >= len then invalid_format fmt i else
+            begin match fmt.[i] with
+            | '[' ->
+               do_pp_open_box ppf n (succ i)
+            | ']' ->
+               pp_close_box ppf ();
+               doprn n (succ i)
+            | '{' ->
+               do_pp_open_tag ppf n (succ i)
+            | '}' ->
+               pp_close_tag ppf ();
+               doprn n (succ i)
+            | ' ' ->
+               pp_print_space ppf ();
+               doprn n (succ i)
+            | ',' ->
+               pp_print_cut ppf ();
+               doprn n (succ i)
+            | '?' ->
+               pp_print_flush ppf ();
+               doprn n (succ i)
+            | '.' ->
+               pp_print_newline ppf ();
+               doprn n (succ i)
+            | '\n' ->
+               pp_force_newline ppf ();
+               doprn n (succ i)
+            | ';' ->
+               do_pp_break ppf n (succ i)
+            | '<' ->
+               let got_size size n i =
+                 print_as := Some size;
+                 doprn n (skip_gt i) in
+               get_int n (succ i) got_size
+            | '@' as c ->
+               pp_print_as_char c;
+               doprn n (succ i)
+            | c -> invalid_format fmt i
+            end
+        | c ->
            pp_print_as_char c;
-           doprn (succ i)
-        | c -> invalid_format fmt i
-        end
-    | c ->
-       pp_print_as_char c;
-       doprn (succ i)
-
-  and cont_s s i =
-    pp_print_as_string s; doprn i
-  and cont_a printer arg i =
-    if str then
-      pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg)
-    else
-      printer ppf arg;
-    doprn i
-  and cont_t printer i =
-    if str then
-      pp_print_as_string ((Obj.magic printer : unit -> string) ())
-    else
-      printer ppf;
-    doprn i
-  and cont_f i =
-    pp_print_flush ppf (); doprn i
-
-  and cont_m sfmt i =
-    fprintf_out str (fun ppf -> Obj.magic doprn i) ppf sfmt
-
-  and get_int i c =
-   if i >= limit then invalid_integer fmt i else
-   match fmt.[i] with
-   | ' ' -> get_int (succ i) c
-   | '%' ->
-      let cont_s s i = c (format_int_of_string fmt i s) i
-      and cont_a printer arg i = invalid_integer fmt i
-      and cont_t printer i = invalid_integer fmt i
-      and cont_f i = invalid_integer fmt i in
-      Printf.scan_format fmt i cont_s cont_a cont_t cont_f cont_m
-   | _ ->
-      let rec get j =
-       if j >= limit then invalid_integer fmt j else
-       match fmt.[j] with
-       | '0' .. '9' | '-' -> get (succ j)
+           doprn n (succ i)
+
+      and cont_s n s i =
+        pp_print_as_string s; doprn n i
+      and cont_a n printer arg i =
+        if str then
+          pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg)
+        else
+          printer ppf arg;
+        doprn n i
+      and cont_t n printer i =
+        if str then
+          pp_print_as_string ((Obj.magic printer : unit -> string) ())
+        else
+          printer ppf;
+        doprn n i
+      and cont_f n i =
+        pp_print_flush ppf (); doprn n i
+
+      and cont_m n sfmt i =
+        kprintf (Obj.magic (fun _ -> doprn n i)) sfmt
+
+      and get_int n i c =
+       if i >= len then invalid_integer fmt i else
+       match fmt.[i] with
+       | ' ' -> get_int n (succ i) c
+       | '%' ->
+          let cont_s n s i = c (format_int_of_string fmt i s) n i
+          and cont_a n printer arg i = invalid_integer fmt i
+          and cont_t n printer i = invalid_integer fmt i
+          and cont_f n i = invalid_integer fmt i
+          and cont_m n sfmt i = invalid_integer fmt i in
+          Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
        | _ ->
-         if j = i then c 0 j else
-         c (format_int_of_string fmt j (String.sub fmt i (j - i))) j in
-      get i
-
-  and skip_gt i =
-   if i >= limit then invalid_format fmt i else
-   match fmt.[i] with
-   | ' ' -> skip_gt (succ i)
-   | '>' -> succ i
-   | _ -> invalid_format fmt i
-
-  and get_box_kind i =
-   if i >= limit then Pp_box, i else
-   match fmt.[i] with
-   | 'h' ->
-      let i = succ i in
-      if i >= limit then Pp_hbox, i else
-      begin match fmt.[i] with
-      | 'o' ->
-         let i = succ i in
-         if i >= limit then format_invalid_arg "bad box format" fmt i else
-         begin match fmt.[i] with
-         | 'v' -> Pp_hovbox, succ i
-         | c ->
-            format_invalid_arg
-              ("bad box name ho" ^ String.make 1 c) fmt i end
-      | 'v' -> Pp_hvbox, succ i
-      | c -> Pp_hbox, i
-      end
-   | 'b' -> Pp_box, succ i
-   | 'v' -> Pp_vbox, succ i
-   | _ -> Pp_box, i
-
-  and get_tag_name i c =
-   let rec get accu i j =
-    if j >= limit
-    then c (implode_rev (String.sub fmt i (j - i)) accu) j else
-    match fmt.[j] with
-    | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) j
-    | '%' ->
-       let s0 = String.sub fmt i (j - i) in
-       let cont_s s i = get (s :: s0 :: accu) i i
-       and cont_a printer arg i =
-         let s =
-           if str then (Obj.magic printer : unit -> _ -> string) () arg
-                  else exstring printer arg in
-         get (s :: s0 :: accu) i i
-       and cont_t printer i =
-         let s =
-           if str then (Obj.magic printer : unit -> string) ()
-           else exstring (fun ppf () -> printer ppf) () in
-         get (s :: s0 :: accu) i i
-       and cont_f i =
-         format_invalid_arg "bad tag name specification" fmt i in
-       Printf.scan_format fmt j cont_s cont_a cont_t cont_f cont_m
-    | c -> get accu i (succ j) in
-   get [] i i
-
-  and do_pp_break ppf i =
-   if i >= limit then begin pp_print_space ppf (); doprn i end else
-   match fmt.[i] with
-   | '<' ->
-      let rec got_nspaces nspaces i =
-        get_int i (got_offset nspaces)
-      and got_offset nspaces offset i =
-        pp_print_break ppf nspaces offset;
-        doprn (skip_gt i) in
-      get_int (succ i) got_nspaces
-   | c -> pp_print_space ppf (); doprn i
-
-  and do_pp_open_box ppf i =
-   if i >= limit then begin pp_open_box_gen ppf 0 Pp_box; doprn i end else
-   match fmt.[i] with
-   | '<' ->
-      let kind, i = get_box_kind (succ i) in
-      let got_size size i =
-        pp_open_box_gen ppf size kind;
-        doprn (skip_gt i) in
-      get_int i got_size
-   | c -> pp_open_box_gen ppf 0 Pp_box; doprn i
-
-  and do_pp_open_tag ppf i =
-   if i >= limit then begin pp_open_tag ppf ""; doprn i end else
-   match fmt.[i] with
-   | '<' ->
-      let got_name tag_name i =
-        pp_open_tag ppf tag_name;
-        doprn (skip_gt i) in
-      get_tag_name (succ i) got_name
-   | c -> pp_open_tag ppf ""; doprn i in
-
-  doprn 0;;
+          let rec get j =
+           if j >= len then invalid_integer fmt j else
+           match fmt.[j] with
+           | '0' .. '9' | '-' -> get (succ j)
+           | _ ->
+             let size =
+             if j = i then size_of_int 0 else
+                format_int_of_string fmt j (String.sub fmt i (j - i)) in
+             c size n j in
+          get i
+
+      and skip_gt i =
+       if i >= len then invalid_format fmt i else
+       match fmt.[i] with
+       | ' ' -> skip_gt (succ i)
+       | '>' -> succ i
+       | _ -> invalid_format fmt i
+
+      and get_box_kind i =
+       if i >= len then Pp_box, i else
+       match fmt.[i] with
+       | 'h' ->
+          let i = succ i in
+          if i >= len then Pp_hbox, i else
+          begin match fmt.[i] with
+          | 'o' ->
+             let i = succ i in
+             if i >= len then format_invalid_arg "bad box format" fmt i else
+             begin match fmt.[i] with
+             | 'v' -> Pp_hovbox, succ i
+             | c ->
+                format_invalid_arg
+                  ("bad box name ho" ^ String.make 1 c) fmt i end
+          | 'v' -> Pp_hvbox, succ i
+          | c -> Pp_hbox, i
+          end
+       | 'b' -> Pp_box, succ i
+       | 'v' -> Pp_vbox, succ i
+       | _ -> Pp_box, i
+
+      and get_tag_name n i c =
+       let rec get accu n i j =
+        if j >= len
+        then c (implode_rev (String.sub fmt i (j - i)) accu) n j else
+        match fmt.[j] with
+        | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) n j
+        | '%' ->
+          let s0 = String.sub fmt i (j - i) in
+          let cont_s n s i = get (s :: s0 :: accu) n i i
+          and cont_a n printer arg i =
+            let s =
+              if str
+              then (Obj.magic printer : unit -> _ -> string) () arg
+              else exstring printer arg in
+            get (s :: s0 :: accu) n i i
+          and cont_t n printer i =
+            let s =
+              if str
+              then (Obj.magic printer : unit -> string) ()
+              else exstring (fun ppf () -> printer ppf) () in
+            get (s :: s0 :: accu) n i i
+          and cont_f n i =
+            format_invalid_arg "bad tag name specification" fmt i
+          and cont_m n sfmt i =
+            format_invalid_arg "bad tag name specification" fmt i in
+          Printf.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
+        | c -> get accu n i (succ j) in
+       get [] n i i
+
+      and do_pp_break ppf n i =
+       if i >= len then begin pp_print_space ppf (); doprn n i end else
+       match fmt.[i] with
+       | '<' ->
+          let rec got_nspaces nspaces n i =
+            get_int n i (got_offset nspaces)
+          and got_offset nspaces offset n i =
+            pp_print_break ppf (int_of_size nspaces) (int_of_size offset);
+            doprn n (skip_gt i) in
+          get_int n (succ i) got_nspaces
+       | c -> pp_print_space ppf (); doprn n i
+
+      and do_pp_open_box ppf n i =
+       if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else
+       match fmt.[i] with
+       | '<' ->
+          let kind, i = get_box_kind (succ i) in
+          let got_size size n i =
+            pp_open_box_gen ppf (int_of_size size) kind;
+            doprn n (skip_gt i) in
+          get_int n i got_size
+       | c -> pp_open_box_gen ppf 0 Pp_box; doprn n i
+
+      and do_pp_open_tag ppf n i =
+       if i >= len then begin pp_open_tag ppf ""; doprn n i end else
+       match fmt.[i] with
+       | '<' ->
+          let got_name tag_name n i =
+            pp_open_tag ppf tag_name;
+            doprn n (skip_gt i) in
+          get_tag_name n (succ i) got_name
+       | c -> pp_open_tag ppf ""; doprn n i in
+
+      doprn (Printf.sz_of_int 0) 0 in
+
+   Printf.kapr kpr fmt in
+
+  kprintf;;
 
 (**************************************************************
 
@@ -1139,22 +1190,24 @@ let rec fprintf_out str out ppf fmt =
 
  **************************************************************)
 
-let kfprintf k = fprintf_out false k;;
-let fprintf ppf = kfprintf unit_out ppf;;
-let printf f = fprintf std_formatter f;;
-let eprintf f = fprintf err_formatter f;;
+let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;;
 
-let bprintf b =
- let ppf = formatter_of_buffer b in
- kfprintf (fun ppf -> pp_flush_queue ppf false) ppf;;
+let fprintf ppf = kfprintf ignore ppf;;
+let printf fmt = fprintf std_formatter fmt;;
+let eprintf fmt = fprintf err_formatter fmt;;
 
-let ksprintf k =
- let b = Buffer.create 512 in
- let ppf = formatter_of_buffer b in
- fprintf_out true (fun ppf -> k (string_out b ppf)) ppf;;
+let kbprintf k b =
+  mkprintf false (fun _ -> formatter_of_buffer b) k;;
 
-let sprintf f = ksprintf (fun s -> s) f;;
+let bprintf b = kbprintf ignore b;;
+
+let ksprintf k =
+  let b = Buffer.create 512 in
+  let k ppf = k (string_out b ppf) in
+  mkprintf true (fun _ -> formatter_of_buffer b) k;;
 
 let kprintf = ksprintf;;
 
+let sprintf fmt = ksprintf (fun s -> s) fmt;;
+
 at_exit print_flush;;
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index d2a829841..f18cdd098 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -2,7 +2,7 @@
 (*                                                                     *)
 (*                           Objective Caml                            *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -20,6 +20,15 @@ external format_nativeint: string -> nativeint -> string
 external format_int64: string -> int64 -> string = "caml_int64_format"
 external format_float: string -> float -> string = "caml_format_float"
 
+external format_to_string: ('a, 'b, 'c, 'd) format4 -> string = "%identity"
+
+type sz;;
+
+external sz_of_int : int -> sz = "%identity";;
+external int_of_sz : sz -> int = "%identity";;
+
+let succs sz = sz_of_int (succ (int_of_sz sz));;
+
 let bad_conversion fmt i c =
   invalid_arg
     ("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
@@ -99,66 +108,117 @@ let sub_format incomplete_format bad_conversion conv fmt i =
     let rec sub j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
-       | '%' -> sub_sub (j + 1)
-       | _ -> sub (j + 1)
+       | '%' -> sub_sub (succ j)
+       | _ -> sub (succ j)
     and sub_sub j =
        if j >= len then incomplete_format fmt else
        match fmt.[j] with
        | '(' | '{' as c ->
-         let j = sub_fmt c (j + 1) in sub (j + 1)
+         let j = sub_fmt c (succ j) in sub (succ j)
        | ')' | '}' as c ->
          if c = close then j else bad_conversion fmt i c
-       | _ -> sub (j + 1) in
+       | _ -> sub (succ j) in
     sub i in
   sub_fmt conv i;;
 
 let sub_format_for_printf = sub_format incomplete_format bad_conversion;;
 
-(* Returns a string that summarizes the typing information that a given
-   format string contains.
-   It also checks the well-formedness of the format string.
-   For instance, [summarize_format_type "A number %d\n"] is "%i". *)
-let summarize_format_type fmt =
+let iter_format_args fmt add_conv add_char =
   let len = String.length fmt in
-  let b = Buffer.create len in
-  let add i c = Buffer.add_char b c; i + 1 in
-  let add_conv i c = Buffer.add_char b '%'; add i c in
-  let rec scan_flags i =
+  let rec scan_flags skip i =
     if i >= len then incomplete_format fmt else
     match String.unsafe_get fmt i with
-    | '*' -> scan_flags (add_conv i '*')
-    | '#' | '-' | ' ' | '+' -> scan_flags (succ i)
-    | '_' -> Buffer.add_char b '_'; scan_flags (i + 1)
+    | '*' -> scan_flags skip (add_conv skip i 'i')
+    | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i)
+    | '_' -> scan_flags true (succ i)
     | '0'..'9'
-    | '.'  -> scan_flags (succ i)
-    | _ -> scan_conv i
-  and scan_conv i =
+    | '.'  -> scan_flags skip (succ i)
+    | _ -> scan_conv skip i
+  and scan_conv skip i =
     if i >= len then incomplete_format fmt else
     match String.unsafe_get fmt i with
     | '%' | '!' -> succ i
-    | 's' | 'S' | '[' -> add_conv i 's'
-    | 'c' | 'C' -> add i 'c'
-    | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> add_conv i 'i'
-    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv i 'f'
-    | 'B' | 'b' -> add_conv i 'B'
-    | 'a' | 't' as conv -> add_conv i conv
+    | 's' | 'S' | '[' -> add_conv skip i 's'
+    | 'c' | 'C' -> add_conv skip i 'c'
+    | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> add_conv skip i 'i'
+    | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f'
+    | 'B' | 'b' -> add_conv skip i 'B'
+    | 'a' | 't' as conv -> add_conv skip i conv
     | 'l' | 'n' | 'L' as conv ->
-        let j = i + 1 in
-        if j >= len then add_conv i 'i' else begin
+        let j = succ i in
+        if j >= len then add_conv skip i 'i' else begin
           match fmt.[j] with
-          | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> add (add_conv i conv) 'i'
-          | c -> add_conv i 'i' end
-    | '{' | '(' as conv -> add_conv i conv
-    | '}' | ')' as conv -> add_conv i conv
+          | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+            add_char skip (add_conv skip i conv) 'i'
+          | c -> add_conv skip i 'i' end
+    | '{' | '(' as conv -> add_conv skip i conv
+    | '}' | ')' as conv -> add_conv skip i conv
     | conv -> bad_conversion fmt i conv in
   let lim = len - 1 in
   let rec loop i =
     if i < lim then
-     if fmt.[i] = '%' then loop (scan_flags (i + 1)) else
-     loop (i + 1) in
-  loop 0;
+     if fmt.[i] = '%' then loop (scan_flags false (succ i)) else
+     loop (succ i) in
+  loop 0;;
+
+(* Returns a string that summarizes the typing information that a given
+   format string contains.
+   It also checks the well-formedness of the format string.
+   For instance, [summarize_format_type "A number %d\n"] is "%i". *)
+let summarize_format_type fmt =
+  let len = String.length fmt in
+  let b = Buffer.create len in
+  let add i c = Buffer.add_char b c; succ i in
+  let add_char skip i c =
+    if skip then succ i else add i c
+  and add_conv skip i c =
+    if skip then Buffer.add_string b "%_" else Buffer.add_char b '%';
+    add i c in
+  iter_format_args fmt add_conv add_char;
   Buffer.contents b;;
 
+(* Computes the number of arguments of a format (including flag
+   arguments if any). *)
+let nargs_of_format_type fmt =
+  let num_args = ref 0
+  and skip_args = ref 0 in
+  let add_conv skip i c =
+    let incr_args n = if c = 'a' then n := !n + 2 else n := !n + 1 in
+    if skip then incr_args skip_args else incr_args num_args;
+    succ i
+  and add_char skip i c = succ i in
+  iter_format_args fmt add_conv add_char;
+  !skip_args + !num_args;;
+
+let list_iter_i f l =
+  let rec loop i = function
+  | [] -> ()
+  | x :: xs -> f i x; loop (succ i) xs in
+  loop 0 l;;
+
+(* Abstracting version of kprintf: returns a (curried) function that
+   will print when totally applied. *)
+let kapr kpr fmt =
+
+  let nargs = nargs_of_format_type fmt in
+
+  match nargs with
+  | 0 -> kpr fmt [||]
+  | 1 -> Obj.magic (fun x -> kpr fmt [|x|])
+  | 2 -> Obj.magic (fun x y -> kpr fmt [|x; y|])
+  | 3 -> Obj.magic (fun x y z -> kpr fmt [|x; y; z|])
+  | 4 -> Obj.magic (fun x y z t -> kpr fmt [|x; y; z; t|])
+  | 5 -> Obj.magic (fun x y z t u -> kpr fmt [|x; y; z; t; u|])
+  | 6 -> Obj.magic (fun x y z t u v -> kpr fmt [|x; y; z; t; u; v|])
+  | nargs ->
+    let rec loop i args =
+      if i >= nargs then
+        let v = Array.make nargs (Obj.repr 0) in
+        list_iter_i (fun i arg -> v.(nargs - i - 1) <- arg) args;
+        kpr fmt v
+      else Obj.magic (fun x -> loop (succ i) (x :: args)) in
+    loop 0 [];;
+
 (* Decode a %format and act on it.
    [fmt] is the printf format style, and [pos] points to a [%] character.
    After consuming the appropriate number of arguments and formatting
@@ -178,166 +238,155 @@ let summarize_format_type fmt =
    caught by the [_ -> bad_conversion] clauses below.
    Don't do this at home, kids. *)
 
-let scan_format fmt pos cont_s cont_a cont_t cont_f cont_m =
-  let rec scan_flags widths i =
+let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
+
+  let get_arg args n = Obj.magic args.(int_of_sz n) in
+
+  let rec scan_flags n widths i =
     match String.unsafe_get fmt i with
     | '*' ->
-        Obj.magic(fun w -> scan_flags (w :: widths) (succ i))
-    | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags widths (succ i)
-    | _ -> scan_conv widths i
-  and scan_conv widths i =
+      let (width : int) = get_arg args n in
+      scan_flags (succs n) (width :: widths) (succ i)
+    | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i)
+    | _ -> scan_conv n widths i
+  and scan_conv n widths i =
     match String.unsafe_get fmt i with
     | '%' ->
-        cont_s "%" (succ i)
+      cont_s n "%" (succ i)
     | 's' | 'S' as conv ->
-        Obj.magic (fun (s : string) ->
-          let s = if conv = 's' then s else "\"" ^ String.escaped s ^ "\"" in
-          if i = succ pos (* optimize for common case %s *)
-          then cont_s s (succ i)
-          else cont_s (format_string (extract_format fmt pos i widths) s)
-                      (succ i))
+      let (x : string) = get_arg args n in
+      let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
+      let s =
+        (* optimize for common case %s *)
+        if i = succ pos then x else
+        format_string (extract_format fmt pos i widths) x in
+      cont_s (succs n) s (succ i)
     | 'c' | 'C' as conv ->
-        Obj.magic (fun (c : char) ->
-          if conv = 'c'
-          then cont_s (String.make 1 c) (succ i)
-          else cont_s ("'" ^ Char.escaped c ^ "'") (succ i))
+      let (x : char) = get_arg args n in
+      let s =
+        if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in
+      cont_s (succs n) s (succ i)
     | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' as conv ->
-        Obj.magic (fun (n : int) ->
-          cont_s
-            (format_int_with_conv conv (extract_format fmt pos i widths) n)
-            (succ i))
+      let (x : int) = get_arg args n in
+      let s = format_int_with_conv conv (extract_format fmt pos i widths) x in
+      cont_s (succs n) s (succ i)
     | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' as conv ->
-        Obj.magic (fun (f : float) ->
-          let s =
-            if conv = 'F' then string_of_float f else
-            format_float (extract_format fmt pos i widths) f in
-          cont_s s (succ i))
+      let (x : float) = get_arg args n in
+      let s =
+        if conv = 'F' then string_of_float x else
+        format_float (extract_format fmt pos i widths) x in
+      cont_s (succs n) s (succ i)
     | 'B' | 'b' ->
-        Obj.magic (fun (b : bool) ->
-          cont_s (string_of_bool b) (succ i))
+      let (x : bool) = get_arg args n in
+      cont_s (succs n) (string_of_bool x) (succ i)
     | 'a' ->
-        Obj.magic (fun printer arg ->
-          cont_a printer arg (succ i))
+      let printer = get_arg args n in
+      let n = succs n in
+      let arg = get_arg args n in
+      cont_a (succs n) printer arg (succ i)
     | 't' ->
-        Obj.magic (fun printer ->
-          cont_t printer (succ i))
+      let printer = get_arg args n in
+      cont_t (succs n) printer (succ i)
     | 'l' | 'n' | 'L' as conv ->
-        begin match String.unsafe_get fmt (succ i) with
-        | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
-            begin match conv with
-            | 'l' ->
-               Obj.magic (fun (n : int32) ->
-                 cont_s
-                   (format_int32 (extract_format fmt pos (succ i) widths) n)
-                   (i + 2))
-            | 'n' ->
-               Obj.magic (fun (n : nativeint) ->
-                 cont_s
-                   (format_nativeint (extract_format fmt pos (succ i) widths) n)
-                   (i + 2))
-            | _ ->
-               Obj.magic (fun (n : int64) ->
-                 cont_s
-                   (format_int64 (extract_format fmt pos (succ i) widths) n)
-                   (i + 2))
-            end
-        | _ ->
-           Obj.magic (fun (n : int) ->
-              cont_s
-                (format_int_with_conv 'n' (extract_format fmt pos i widths) n)
-                (succ i))
-        end
-    | '!' ->
-        Obj.magic (cont_f (succ i))
-    | '{' | '(' as conv ->
-        Obj.magic (fun xf ->
-          let i = succ i in
-          let j = sub_format_for_printf conv fmt i + 1 in
-          if conv = '{' then
-            (* Just print the format argument as a specification. *)
-            cont_s (summarize_format_type (string_of_format xf)) j else
-            (* Use the format argument instead of the format specification. *)
-            cont_m xf j)
+      begin match String.unsafe_get fmt (succ i) with
+      | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+        let s =
+          match conv with
+          | 'l' ->
+            let (x : int32) = get_arg args n in
+            format_int32 (extract_format fmt pos (succ i) widths) x
+          | 'n' ->
+            let (x : nativeint) = get_arg args n in
+            format_nativeint (extract_format fmt pos (succ i) widths) x
+          | _ ->
+            let (x : int64) = get_arg args n in
+            format_int64 (extract_format fmt pos (succ i) widths) x in
+        cont_s (succs n) s (i + 2)
+      | _ ->
+        let (x : int) = get_arg args n in
+        cont_s
+          (succs n)
+          (format_int_with_conv 'n' (extract_format fmt pos i widths) x)
+          (succ i)
+      end
+    | '!' -> cont_f n (succ i)
+    | '{' | '(' as conv (* ')' '}' *)->
+      let (xf : ('a, 'b, 'c, 'd) format4) = get_arg args n in
+      let i = succ i in
+      let j = sub_format_for_printf conv fmt i + 1 in
+      if conv = '{' (* '}' *) then
+        (* Just print the format argument as a specification. *)
+        cont_s (succs n) (summarize_format_type (format_to_string xf)) j else
+        (* Use the format argument instead of the format specification. *)
+        cont_m (succs n) xf j
     | ')' ->
-        Obj.magic (cont_s "" (succ i))
+      cont_s n "" (succ i)
     | conv ->
-        bad_conversion fmt i conv in
-  scan_flags [] (pos + 1)
+      bad_conversion fmt i conv in
 
-(* Application to [fprintf], etc.  See also [Format.*printf]. *)
+  scan_flags n [] (succ pos);;
 
-let rec kfprintf k chan fmt =
-  let fmt = string_of_format fmt in
-  let len = String.length fmt in
+let mkprintf str get_out outc outs flush =
+  let rec kprintf k fmt =
+    let fmt = format_to_string fmt in
+    let len = String.length fmt in
 
-  let rec doprn i =
-    if i >= len then Obj.magic (k chan) else
-    match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f cont_m
-    | c -> output_char chan c; doprn (succ i)
-  and cont_s s i =
-    output_string chan s; doprn i
-  and cont_a printer arg i =
-    printer chan arg; doprn i
-  and cont_t printer i =
-    printer chan; doprn i
-  and cont_f i =
-    flush chan; doprn i
-  and cont_m sfmt i =
-    kfprintf (Obj.magic (fun _ -> doprn i)) chan sfmt in
-
-  doprn 0
-
-let fprintf chan fmt = kfprintf (fun _ -> ()) chan fmt
+    let kpr fmt v =
+      let out = get_out fmt in
+      let rec doprn n i =
+        if i >= len then Obj.magic (k out) else
+        match String.unsafe_get fmt i with
+        | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
+        |  c  -> outc out c; doprn n (succ i)
+      and cont_s n s i =
+        outs out s; doprn n i
+      and cont_a n printer arg i =
+        if str then
+          outs out ((Obj.magic printer : unit -> _ -> string) () arg)
+        else
+          printer out arg;
+        doprn n i
+      and cont_t n printer i =
+        if str then
+          outs out ((Obj.magic printer : unit -> string) ())
+        else
+          printer out;
+        doprn n i
+      and cont_f n i =
+        flush out; doprn n i
+      and cont_m n sfmt i =
+        kprintf (Obj.magic (fun _ -> doprn n i)) sfmt in
+
+      doprn (sz_of_int 0) 0 in
+
+    kapr kpr fmt in
+
+  kprintf;;
 
+let kfprintf k oc =
+  mkprintf false (fun _ -> oc) output_char output_string flush k
+let fprintf oc = kfprintf ignore oc
 let printf fmt = fprintf stdout fmt
 let eprintf fmt = fprintf stderr fmt
 
-let rec ksprintf k fmt =
-  let fmt = string_of_format fmt in
-  let len = String.length fmt in
-  let dst = Buffer.create (len + 16) in
-  let rec doprn i =
-    if i >= len then begin
-      let res = Buffer.contents dst in
-      Buffer.clear dst; (* just in case ksprintf is partially applied *)
-      Obj.magic (k res)
-    end else
-    match String.unsafe_get fmt i with
-    | '%' -> scan_format fmt i cont_s cont_a cont_t cont_f cont_m
-    | c -> Buffer.add_char dst c; doprn (succ i)
-  and cont_s s i =
-    Buffer.add_string dst s; doprn i
-  and cont_a printer arg i =
-    Buffer.add_string dst (printer () arg); doprn i
-  and cont_t printer i =
-    Buffer.add_string dst (printer ()); doprn i
-  and cont_f i = doprn i
-  and cont_m sfmt i =
-    ksprintf (fun res -> Obj.magic (cont_s res i)) sfmt in
-
-  doprn 0
-
-let sprintf fmt = ksprintf (fun x -> x) fmt
-
-let kprintf = ksprintf
-
-let rec bprintf dst fmt =
-  let fmt = string_of_format fmt in
-  let len = String.length fmt in
-  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 cont_f cont_m
-    | c -> Buffer.add_char dst c; doprn (succ i)
-  and cont_s s i =
-    Buffer.add_string dst s; doprn i
-  and cont_a printer arg i =
-    printer dst arg; doprn i
-  and cont_t printer i =
-    printer dst; doprn i
-  and cont_f i = doprn i
-  and cont_m sfmt i =
-    bprintf dst sfmt; doprn i in
-
-  doprn 0
+let kbprintf k b =
+  mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k
+let bprintf b = kbprintf ignore b
+
+let get_buff fmt =
+  let len = 2 * String.length fmt in
+  Buffer.create len;;
+
+let get_contents b =
+  let s = Buffer.contents b in
+  Buffer.clear b;
+  s;;
+
+let get_cont k b = k (get_contents b);;
+
+let ksprintf k =
+  mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k);;
+
+let kprintf = ksprintf;;
+
+let sprintf fmt = ksprintf (fun s -> s) fmt;;
diff --git a/stdlib/printf.mli b/stdlib/printf.mli
index a4d0ba989..df0140d9a 100644
--- a/stdlib/printf.mli
+++ b/stdlib/printf.mli
@@ -2,7 +2,7 @@
 (*                                                                     *)
 (*                           Objective Caml                            *)
 (*                                                                     *)
-(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*  Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt   *)
 (*                                                                     *)
 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
 (*  en Automatique.  All rights reserved.  This file is distributed    *)
@@ -43,7 +43,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    - [f]: convert a floating-point argument to decimal notation,
      in the style [dddd.ddd].
    - [F]: convert a floating-point argument to Caml syntax ([dddd.]
-     or [dddd.ddd] or [d.ddd e+-dd])
+     or [dddd.ddd] or [d.ddd e+-dd]).
    - [e] or [E]: convert a floating-point argument to decimal notation,
      in the style [d.ddd e+-dd] (mantissa and exponent).
    - [g] or [G]: convert a floating-point argument to decimal notation,
@@ -65,10 +65,12 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
      in the output of [fprintf] at the current point.
    - [t]: same as [%a], but takes only one argument (with type
      [out_channel -> unit]) and apply it to [outchan].
-   - [\{ fmt %\}]: convert a format string argument to its minimal
-     specification. The argument must have the same type as [fmt].
-   - [\( fmt %\)]: printing format substitution. Use a format string
-     argument to replace [fmt]. The argument must have the same type as [fmt].
+   - [\{ fmt %\}]: convert a format string argument. The argument
+     must have the same type as the internal format string [fmt].
+   - [\( fmt %\)]: format string substitution. This convertion takes a
+     format string argument and substitutes it to the specification
+     [fmt] to print following arguments. The format string argument
+     must have the same type as [fmt].
    - [!]: take no argument and flush the output.
    - [%]: take no argument and output one [%] character.
 
@@ -87,17 +89,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a
    fill at least 6 characters; and [%.4f] prints a float with 4
    fractional digits.  Each or both of the integer literals can also be
    specified as a [*], in which case an extra integer argument is taken
-   to specify the corresponding width or precision.
-   
-   Warning: if too few arguments are provided,
-   for instance because the [printf] function is partially
-   applied, the format is immediately printed up to
-   the conversion of the first missing argument; printing
-   will then resume when the missing arguments are provided.
-   For example, [List.iter (printf "x=%d y=%d " 1) [2;3]]
-   prints [x=1 y=2 3] instead of the expected
-   [x=1 y=2 x=1 y=3].  To get the expected behavior, do
-   [List.iter (fun y -> printf "x=%d y=%d " 1 y) [2;3]]. *)
+   to specify the corresponding width or precision. *)
 
 val printf : ('a, out_channel, unit) format -> 'a
 (** Same as {!Printf.fprintf}, but output on [stdout]. *)
@@ -130,13 +122,20 @@ val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;;
 (**/**)
 
 (* For system use only.  Don't call directly. *)
+type sz;;
+
+external sz_of_int : int -> sz = "%identity";;
+external int_of_sz : sz -> int = "%identity";;
 
-val scan_format :
-  string -> int -> (string -> int -> 'a) -> ('b -> 'c -> int -> 'd) ->
-  ('e -> int -> 'f) -> (int -> 'g) ->
-  (('h, 'i, 'j, 'k) format4 -> int -> 'a) -> 'a
+val scan_format : string -> 'a array -> sz -> int ->
+  (sz -> string -> int -> 'b) ->
+  (sz -> 'c -> 'd -> int -> 'b) ->
+  (sz -> 'e -> int -> 'b) ->
+  (sz -> int -> 'b) ->
+  (sz -> ('h, 'i, 'j, 'k) format4 -> int -> 'b) -> 'b
 
 val sub_format :
   (string -> int) -> (string -> int -> char -> int) ->
   char -> string -> int -> int
 val summarize_format_type : string -> string
+val kapr : (string -> Obj.t array -> 'a) -> string -> 'a
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 360a19c57..aef1060ba 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+dev30 (2005-08-25)";;
+let ocaml_version = "3.09+dev31 (2005-09-20)";;