second part of Benoît Vaugon's format+gadts patch

To finish the bootstrap cycle, run:

  make library-cross
  make promote
  make partialclean
  make core

  make library-cross
  make promote-cross
  make partialclean
  make ocamlc ocamllex ocamltools

  make library-cross
  make promote
  make partialclean
  make core
  make compare

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

1 files changed, 105 insertions, 350 deletions

diff --git a/stdlib/format.ml b/stdlib/format.ml
index 18de7e24cf..12754903ec 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -29,6 +29,10 @@ external int_of_size : size -> int = "%identity"
 
 (* Tokens are one of the following : *)
 
+type block_type
+       = CamlinternalFormatBasics.block_type
+       = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
+
 type pp_token =
 | Pp_text of string            (* normal text *)
 | Pp_break of int * int        (* complete break *)
@@ -46,21 +50,7 @@ type pp_token =
 
 and tag = string
 
-and block_type =
-| Pp_hbox   (* Horizontal block no line breaking *)
-| Pp_vbox   (* Vertical block each break leads to a new line *)
-| Pp_hvbox  (* Horizontal-vertical block: same as vbox, except if this block
-               is small enough to fit on a single line *)
-| Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line
-               only when necessary to print the content of the block *)
-| Pp_box    (* Horizontal or Indent block: breaks lead to new line
-               only when necessary to print the content of the block, or
-               when it leads to a new indentation of the current line *)
-| Pp_fits   (* Internal usage: when a block fits on a single line *)
-
-and tblock =
-  | Pp_tbox of int list ref  (* Tabulation box *)
-;;
+and tblock = Pp_tbox of int list ref  (* Tabulation box *)
 
 (* The Queue:
    contains all formatting elements.
@@ -241,7 +231,8 @@ let pp_infinity = 1000000010;;
 let pp_output_string state s = state.pp_out_string s 0 (String.length s)
 and pp_output_newline state = state.pp_out_newline ()
 and pp_output_spaces state n = state.pp_out_spaces n
-;;
+
+let pp_output_char state c = pp_output_string state (String.make 1 c)
 
 (* To format a break, indenting a new line. *)
 let break_new_line state offset width =
@@ -1069,309 +1060,71 @@ and set_tags =
   pp_set_tags std_formatter
 ;;
 
-
-(**************************************************************
-
-  Printf implementation.
-
- **************************************************************)
-
-module Sformat = Printf.CamlinternalPr.Sformat;;
-module Tformat = Printf.CamlinternalPr.Tformat;;
-
-(* Error messages when processing formats. *)
-
-(* Trailer: giving up at character number ... *)
-let giving_up mess fmt i =
-  Printf.sprintf
-    "Format.fprintf: %s \'%s\', giving up at character number %d%s"
-    mess (Sformat.to_string fmt) i
-    (if i < Sformat.length fmt
-     then Printf.sprintf " (%c)." (Sformat.get fmt i)
-     else Printf.sprintf "%c" '.')
-;;
-
-(* When an invalid format deserves a special error explanation. *)
-let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);;
-
-(* Standard invalid format. *)
-let invalid_format fmt i = format_invalid_arg "bad format" fmt i;;
-
-(* Cannot find a valid integer into that format. *)
-let invalid_integer fmt i =
-  invalid_arg (giving_up "bad integer specification" fmt i);;
-
-(* Finding an integer size out of a sub-string of the format. *)
-let format_int_of_string fmt i s =
-  let sz =
-    try int_of_string s with
-    | Failure _ -> invalid_integer fmt i in
-  size_of_int sz
-;;
-
-(* Getting strings out of buffers. *)
-let get_buffer_out b =
-  let s = Buffer.contents b in
-  Buffer.reset b;
-  s
-;;
-
-(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]:
-   to extract the contents of [ppf] as a string we flush [ppf] and get the
-   string out of [b]. *)
-let string_out b ppf =
-  pp_flush_queue ppf false;
-  get_buffer_out b
-;;
-
-(* Applies [printer] to a formatter that outputs on a fresh buffer,
-   then returns the resulting material. *)
-let exstring printer arg =
-  let b = Buffer.create 512 in
-  let ppf = formatter_of_buffer b in
-  printer ppf arg;
-  string_out b ppf
-;;
-
-(* To turn out a character accumulator into the proper string result. *)
-let implode_rev s0 = function
-  | [] -> s0
-  | l -> String.concat "" (List.rev (s0 :: l))
-;;
-
-(* [mkprintf] is the printf-like function generator: given the
-   - [to_s] flag that tells if we are printing into a string,
-   - the [get_out] function that has to be called to get a [ppf] function to
-     output onto,
-   it generates a [kprintf] function that takes as arguments a [k]
-   continuation function to be called at the end of formatting,
-   and a printing format string to print the rest of the arguments
-   according to the format string.
-   Regular [fprintf]-like functions of this module are obtained via partial
-   applications of [mkprintf]. *)
-let mkprintf to_s get_out k fmt =
-
-  (* [out] is global to this definition of [pr], and must be shared by all its
-     recursive calls (if any). *)
-  let out = get_out fmt in
-  let print_as = ref None in
-  let outc c =
-    match !print_as with
-    | None -> pp_print_char out c
-    | Some size ->
-      pp_print_as_size out size (String.make 1 c);
-      print_as := None
-  and outs s =
-    match !print_as with
-    | None -> pp_print_string out s
-    | Some size ->
-      pp_print_as_size out size s;
-      print_as := None
-  and flush out = pp_print_flush out () in
-
-  let rec pr k n fmt v =
-
-    let len = Sformat.length fmt in
-
-    let rec doprn n i =
-      if i >= len then Obj.magic (k out) else
-      match Sformat.get fmt i with
-      | '%' ->
-        Tformat.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 Sformat.get fmt i with
-        | '[' ->
-          do_pp_open_box out n (succ i)
-        | ']' ->
-          pp_close_box out ();
-          doprn n (succ i)
-        | '{' ->
-          do_pp_open_tag out n (succ i)
-        | '}' ->
-          pp_close_tag out ();
-          doprn n (succ i)
-        | ' ' ->
-          pp_print_space out ();
-          doprn n (succ i)
-        | ',' ->
-          pp_print_cut out ();
-          doprn n (succ i)
-        | '?' ->
-          pp_print_flush out ();
-          doprn n (succ i)
-        | '.' ->
-          pp_print_newline out ();
-          doprn n (succ i)
-        | '\n' ->
-          pp_force_newline out ();
-          doprn n (succ i)
-        | ';' ->
-          do_pp_break out 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
-        | '@' ->
-          outc '@';
-          doprn n (succ i)
-        | _ -> invalid_format fmt i
-        end
-      | c -> outc c; doprn n (succ i)
-
-    and cont_s n s i =
-      outs s; doprn n i
-    and cont_a n printer arg i =
-      if to_s then
-        outs ((Obj.magic printer : unit -> _ -> string) () arg)
-      else
-        printer out arg;
-      doprn n i
-    and cont_t n printer i =
-      if to_s then
-        outs ((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 xf i =
-      let m =
-        Sformat.add_int_index
-          (Tformat.count_printing_arguments_of_format xf) n in
-      pr (Obj.magic (fun _ -> doprn m i)) n xf v
-
-    and get_int n i c =
-      if i >= len then invalid_integer fmt i else
-      match Sformat.get 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
-        Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
-      | _ ->
-        let rec get j =
-          if j >= len then invalid_integer fmt j else
-          match Sformat.get fmt j with
-          | '0' .. '9' | '-' -> get (succ j)
-          | _ ->
-            let size =
-              if j = i then size_of_int 0 else
-              let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in
-              format_int_of_string fmt j s in
-            c size n j in
-        get i
-
-    and skip_gt i =
-      if i >= len then invalid_format fmt i else
-      match Sformat.get 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 Sformat.get fmt i with
-      | 'h' ->
-         let i = succ i in
-         if i >= len then Pp_hbox, i else
-         begin match Sformat.get fmt i with
-         | 'o' ->
-           let i = succ i in
-           if i >= len then format_invalid_arg "bad box format" fmt i else
-           begin match Sformat.get 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
-         | _ -> 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
-               (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-               accu)
-            n j else
-        match Sformat.get fmt j with
-        | '>' ->
-          c (implode_rev
-               (Sformat.sub fmt (Sformat.index_of_int i) (j - i))
-               accu)
-            n j
-        | '%' ->
-          let s0 = Sformat.sub fmt (Sformat.index_of_int 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 to_s
-              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 to_s
-              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
-          Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m
-        | _ -> 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 Sformat.get 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 Sformat.get 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 Sformat.get 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 n 0 in
-
-  let kpr = pr k (Sformat.index_of_int 0) in
-
-  Tformat.kapr kpr fmt
-;;
+ (**************************************************************
+ 
+  Defining continuations to be passed as arguments of
+  CamlinternalFormat.make_printf.
+ 
+  **************************************************************)
+
+open CamlinternalFormatBasics
+open CamlinternalFormat
+
+(* Interpret a formatting entity on a formatter. *)
+let output_formatting ppf fmting = match fmting with
+  | Open_box (_, bty, indent) -> pp_open_box_gen ppf indent bty
+  | Close_box                 -> pp_close_box ppf ()
+  | Open_tag (_, name)        -> pp_open_tag ppf name
+  | Close_tag                 -> pp_close_tag ppf ()
+  | Break (_, width, offset)  -> pp_print_break ppf width offset
+  | FFlush                    -> pp_print_flush ppf ()
+  | Force_newline             -> pp_force_newline ppf ()
+  | Flush_newline             -> pp_print_newline ppf ()
+  | Magic_size (_, _)         -> ()
+  | Escaped_at                -> pp_output_char ppf '@'
+  | Escaped_percent           -> pp_output_char ppf '%'
+  | Scan_indic c              -> pp_output_char ppf '@'; pp_output_char ppf c
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in an output_stream. *)
+(* Differ from Printf.output_acc by the interpretation of formatting. *)
+(* Used as a continuation of CamlinternalFormat.make_printf. *)
+let rec output_acc ppf acc = match acc with
+  | Acc_string (Acc_formatting (p, Magic_size (_, size)), s) ->
+    output_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) s;
+  | Acc_char (Acc_formatting (p, Magic_size (_, size)), c) ->
+    output_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (String.make 1 c);
+  | Acc_formatting (p, f)    -> output_acc ppf p; output_formatting ppf f;
+  | Acc_string (p, s)        -> output_acc ppf p; pp_print_string ppf s;
+  | Acc_char (p, c)          -> output_acc ppf p; pp_print_char ppf c;
+  | Acc_delay (p, f)         -> output_acc ppf p; f ppf;
+  | Acc_flush p              -> output_acc ppf p; pp_print_flush ppf ();
+  | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg;
+  | End_of_acc               -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+   printing entities (string, char, flus, ...) in a buffer. *)
+(* Differ from Printf.bufput_acc by the interpretation of formatting. *)
+(* Used as a continuation of CamlinternalFormat.make_printf. *)
+let rec strput_acc ppf acc = match acc with
+  | Acc_string (Acc_formatting (p, Magic_size (_, size)), s) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) s;
+  | Acc_char (Acc_formatting (p, Magic_size (_, size)), c) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (String.make 1 c);
+  | Acc_delay (Acc_formatting (p, Magic_size (_, size)), f) ->
+    strput_acc ppf p;
+    pp_print_as_size ppf (size_of_int size) (f ());
+  | Acc_formatting (p, f)    -> strput_acc ppf p; output_formatting ppf f;
+  | Acc_string (p, s)        -> strput_acc ppf p; pp_print_string ppf s;
+  | Acc_char (p, c)          -> strput_acc ppf p; pp_print_char ppf c;
+  | Acc_delay (p, f)         -> strput_acc ppf p; pp_print_string ppf (f ());
+  | Acc_flush p              -> strput_acc ppf p; pp_print_flush ppf ();
+  | Acc_invalid_arg (p, msg) -> strput_acc ppf p; invalid_arg msg;
+  | End_of_acc               -> ()
 
 (**************************************************************
 
@@ -1379,30 +1132,37 @@ let mkprintf to_s get_out k fmt =
 
  **************************************************************)
 
-let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;;
-let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf));;
-
-let fprintf ppf = kfprintf ignore ppf;;
-let ifprintf ppf = ikfprintf ignore ppf;;
-let printf fmt = fprintf std_formatter fmt;;
-let eprintf fmt = fprintf err_formatter fmt;;
-
-let ksprintf k =
+let kfprintf k o (fmt, _) =
+  make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt
+let ikfprintf k x (fmt, _) =
+  make_printf (fun _ _ -> k x) x End_of_acc fmt
+
+let fprintf ppf fmt = kfprintf ignore ppf fmt
+let ifprintf ppf fmt = ikfprintf ignore ppf fmt
+let printf fmt = fprintf std_formatter fmt
+let eprintf fmt = fprintf err_formatter fmt
+
+let ksprintf k (fmt, _) =
+  let k' () acc =
+    let b = Buffer.create 512 in
+    let ppf = formatter_of_buffer b in
+    strput_acc ppf acc;
+    pp_flush_queue ppf false;
+    k (Buffer.contents b) in
+  make_printf k' () End_of_acc fmt
+
+let sprintf fmt =
+  ksprintf (fun s -> s) fmt
+
+let asprintf (fmt, _) =
   let b = Buffer.create 512 in
-  let k ppf = k (string_out b ppf) in
-  let ppf = formatter_of_buffer b in
-  let get_out _ = ppf in
-  mkprintf true get_out k
-;;
-
-let sprintf fmt = ksprintf (fun s -> s) fmt;;
-
-let asprintf fmt =
-  let b = Buffer.create 512 in
-  let k ppf = string_out b ppf in
-  let ppf = formatter_of_buffer b in
-  let get_out _ = ppf in
-  mkprintf false get_out k fmt;;
+  let ppf = formatter_of_buffer b in  
+  let k' : (formatter -> (formatter, unit) acc -> string)
+    = fun ppf acc ->
+      output_acc ppf acc;
+      pp_flush_queue ppf false;
+      Buffer.contents b in
+  make_printf k' ppf End_of_acc fmt
 
 (**************************************************************
 
@@ -1410,15 +1170,10 @@ let asprintf fmt =
 
  **************************************************************)
 
-let kbprintf k b =
-  mkprintf false (fun _ -> formatter_of_buffer b) k
-;;
-
 (* Deprecated error prone function bprintf. *)
-let bprintf b =
-  let k ppf = pp_flush_queue ppf false in
-  kbprintf k b
-;;
+let bprintf b ((fmt, _) : ('a, formatter, unit) format) =
+  let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in
+  make_printf k (formatter_of_buffer b) End_of_acc fmt
 
 (* Deprecated alias for ksprintf. *)
 let kprintf = ksprintf;;