Introduction de printf.

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

2 files changed, 201 insertions, 12 deletions

diff --git a/stdlib/format.ml b/stdlib/format.ml
index 8302fbde0..dd949761e 100644
--- a/stdlib/format.ml
+++ b/stdlib/format.ml
@@ -358,7 +358,7 @@ let scan_push state b tok =
   the user may set the depth bound pp_max_boxes
   any text nested deeper is printed as the character the ellipsis
 *)
-let pp_open_box state indent br_ty =
+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
@@ -383,7 +383,7 @@ let pp_close_box state () =
         pp_enqueue state {elem_size = 0; token = Pp_end; length = 0};
         set_size state true; set_size state false
        end;
-      state.pp_curr_depth <- state.pp_curr_depth - 1
+      state.pp_curr_depth <- state.pp_curr_depth - 1;
      end;;
 
 (* Initialize pretty-printer. *)
@@ -434,12 +434,12 @@ let pp_print_char state c =
   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 state 0 Pp_hbox
-and pp_open_vbox state indent = pp_open_box state indent Pp_vbox
+let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox
+and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox
 
-and pp_open_hvbox state indent = pp_open_box state indent Pp_hvbox
-and pp_open_hovbox state indent = pp_open_box state indent Pp_hovbox
-and pp_open_box state indent = pp_open_box state indent Pp_box;;
+and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox
+and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox
+and pp_open_box state indent = pp_open_box_gen state indent Pp_box;;
 
 (* Print a new line after printing all queued text
    (same for print_flush but without a newline)    *)
@@ -626,5 +626,159 @@ and set_formatter_output_functions =
 and get_formatter_output_functions =
     pp_get_formatter_output_functions std_formatter;;
 
+external format_int: string -> int -> string = "format_int"
+external format_float: string -> float -> string = "format_float"
+
+let fprintf ppf format =
+  let format = (Obj.magic format : string) in
+  let limit = String.length format in
+
+  let rec doprn i =
+    if i >= limit then
+      Obj.magic ()
+    else
+      match format.[i] with
+      | '@' ->
+          let j = succ i in
+          if j >= limit then invalid_arg ("fprintf: unknown format") else
+          begin match format.[j] with
+          | '@' ->
+              pp_print_char ppf '@';
+              doprn (succ j)
+          | '[' ->
+              let j = do_pp_open ppf (i + 2) in
+              doprn j
+          | ']' ->
+              pp_close_box ppf ();
+              doprn (succ j)
+          | ' ' ->
+              pp_print_space ppf ();
+              doprn (succ j)
+          | ',' ->
+              pp_print_cut ppf ();
+              doprn (succ j)
+          | '.' ->
+              pp_print_newline ppf ();
+              doprn (succ j)
+          | ';' ->
+              pp_force_newline ppf ();
+              doprn (succ j)
+          | _ -> invalid_arg ("fprintf: unknown format") end
+      | '%' ->
+          let j = skip_args (succ i) in
+          begin match format.[j] with
+          | '%' ->
+              pp_print_char ppf '%';
+              doprn (succ j)
+          | 's' ->
+              Obj.magic(fun s ->
+                if j <= i+1 then
+                  pp_print_string ppf s
+                else begin
+                  let p =
+                    try
+                      int_of_string (String.sub format (i+1) (j-i-1))
+                    with _ ->
+                      invalid_arg "fprintf: bad %s format" in
+                  if p > 0 && String.length s < p then begin
+                    pp_print_string ppf
+                                  (String.make (p - String.length s) ' ');
+                    pp_print_string ppf s
+                  end else if p < 0 && String.length s < -p then begin
+                    pp_print_string ppf s;
+                    pp_print_string ppf
+                                  (String.make (-p - String.length s) ' ')
+                  end else
+                    pp_print_string ppf s
+                end;
+                doprn (succ j))
+          | 'c' ->
+              Obj.magic(fun c ->
+                pp_print_char ppf c;
+                doprn (succ j))
+          | 'd' | 'o' | 'x' | 'X' | 'u' ->
+              Obj.magic(fun n ->
+                pp_print_string ppf
+                                (format_int (String.sub format i (j-i+1)) n);
+                doprn (succ j))
+          | 'f' | 'e' | 'E' | 'g' | 'G' ->
+              Obj.magic(fun f ->
+                pp_print_string ppf
+                                (format_float (String.sub format i (j-i+1)) f);
+                doprn (succ j))
+          | 'b' ->
+              Obj.magic(fun b ->
+                pp_print_string ppf (string_of_bool b);
+                doprn(succ j))
+          | 'a' ->
+              Obj.magic(fun printer arg ->
+                printer ppf arg;
+                doprn(succ j))
+          | 't' ->
+              Obj.magic(fun printer ->
+                printer ppf;
+                doprn(succ j))
+          | c ->
+              invalid_arg ("fprintf: unknown format")
+          end
+       |  c  -> pp_print_char ppf c; doprn (succ i)
+
+  and skip_args j =
+    match format.[j] with
+    | '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
+    | c -> j
+
+  and get_box_size i =
+   match format.[i] with
+   | ' ' -> get_box_size (i + 1)
+   | c ->
+      let rec get_size j =
+       match format.[j] with
+       | '0' .. '9' | '-' -> get_size (succ j)
+       | '>' ->
+         if j = i then 0, succ j else
+          begin try int_of_string (String.sub format i (j-i)), succ j
+          with Failure _ -> invalid_arg "fprintf: bad box format" end
+       | c -> invalid_arg "fprintf: bad box format" in
+       get_size i
+
+  and get_box_kind j =
+   if j >= limit then Pp_box, j else
+   match format.[j] with
+   | 'h' ->
+      let j = succ j in
+      if j >= limit then Pp_hbox, j else
+      begin match format.[j] with
+      | 'o' -> 
+         let j = succ j in
+         if j >= limit
+          then invalid_arg "fprintf: bad box format" else
+         begin match format.[j] with
+         | 'v' -> Pp_hovbox, succ j
+         | _ ->  invalid_arg "fprintf: bad box format" end
+      | 'v' -> Pp_hvbox, succ j
+      | c -> Pp_hbox, j
+      end
+   | 'b' -> Pp_box, succ j
+   | 'v' -> Pp_vbox, succ j
+   | _ -> Pp_box, j
+
+  and do_pp_open ppf i =
+   if i >= limit
+   then begin pp_open_box_gen ppf 0 Pp_box; i end else
+   match format.[i] with
+   | '<' ->
+     let k,j = get_box_kind (succ i) in
+     let size,j = get_box_size j in
+     pp_open_box_gen ppf size k;
+     j
+   | c ->  pp_open_box_gen ppf 0 Pp_box; i
+
+  in doprn 0
+;;
+
+let printf f = fprintf std_formatter f;;
+let eprintf f = fprintf err_formatter f;;
+
 let _ = at_exit print_flush;;
 
diff --git a/stdlib/format.mli b/stdlib/format.mli
index d49da5c22..80c3708a5 100644
--- a/stdlib/format.mli
+++ b/stdlib/format.mli
@@ -19,17 +19,22 @@
    structure. *)
 
 (* Rule of thumb for casual users:
-   use simple boxes (as obtained by [open_box 0]);
-   use simple break hints (as obtained by [print_cut ()] that outputs a
+-   use simple boxes (as obtained by [open_box 0]);
+-   use simple break hints (as obtained by [print_cut ()] that outputs a
    simple break hint, or by [print_space ()] that ouputs a space
    indicating a break hint);
-   once a box is opened, display its material with basic printing
+-   once a box is opened, display its material with basic printing
    functions (e. g. [print_int] and [print_string]);
-   when the material for a box has been printed, call [close_box ()] to
+-   when the material for a box has been printed, call [close_box ()] to
    close the box;
-   at the end of your routine, evaluate [print_newline ()] to close
+-   at the end of your routine, evaluate [print_newline ()] to close
    all remaining boxes and flush the pretty-printer. *) 
 
+(* You may alternatively consider this module as providing an extension to the
+   [printf] facility: you can simply add pretty-printing annotations to your
+   regular printf formats, as explained below in the documentation of
+   the function [fprintf]. *)
+
 (* The behaviour of pretty-printing commands is unspecified
    if there is no opened pretty-printing box. Each box opened via
    one of the [open_] functions below must be closed using [close_box]
@@ -291,3 +296,33 @@ val pp_get_formatter_output_functions :
            operating on the standard formatter are defined via partial
            evaluation of these primitives. For instance,
            [print_string] is equal to [pp_print_string std_formatter]. *)
+
+val fprintf : formatter -> ('a, formatter, unit) format -> 'a;;
+        (* [fprintf ff format arg1 ... argN] formats the arguments
+           [arg1] to [argN] according to the format string [format],
+           and outputs the resulting string on the formatter [ff].
+           The format is a character string which contains three types of
+           objects: plain characters and conversion specifications as
+           specified in the [printf] module, and pretty-printing
+           indications.
+           The pretty-printing indication characters are introduced by
+           a [@] character, and their meanings are:
+-          [\[]: open a pretty-printing box. The type and offset of the
+           box may be optionally specified with the following syntax:
+           the [<] character, followed by an optional box type indication,
+           then an optional integer offset, and the closing [>] character. 
+           Box type is one of [h], [v], [hv], or [hov],
+           which stand respectively for an horizontal, vertical,
+           ``horizontal-vertical'' and ``horizontal or vertical'' box.
+-          [\]]: close the most recently opened pretty-printing box.
+-          [,]: output a good break as with [print_cut ()].
+-          [ ]: output a space, as with [print_space ()].
+-          [;]: force a newline, as with [force_newline ()].
+-          [.]: flush the pretty printer as with [print_newline ()].
+-          [@]: a plain [@] character. *)
+
+val printf : ('a, formatter, unit) format -> 'a;;
+        (* Same as [fprintf], but output on [std_formatter]. *)
+val eprintf: ('a, formatter, unit) format -> 'a;;
+        (* Same as [fprintf], but output on [err_formatter]. *)
+