1995-08-09 08:06:35 -07:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
2011-07-27 07:17:02 -07:00
|
|
|
(* OCaml *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
2005-09-20 10:18:03 -07:00
|
|
|
(* Xavier Leroy and Pierre Weis, projet Cristal, INRIA Rocquencourt *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
1996-04-30 07:53:58 -07:00
|
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
1999-11-17 10:59:06 -08:00
|
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
2001-12-07 05:41:02 -08:00
|
|
|
(* under the terms of the GNU Library General Public License, with *)
|
|
|
|
(* the special exception on linking described in file ../LICENSE. *)
|
1995-08-09 08:06:35 -07:00
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
external format_float: string -> float -> string
|
|
|
|
= "caml_format_float"
|
|
|
|
external format_int: string -> int -> string
|
|
|
|
= "caml_format_int"
|
|
|
|
external format_int32: string -> int32 -> string
|
|
|
|
= "caml_int32_format"
|
2004-01-01 08:42:43 -08:00
|
|
|
external format_nativeint: string -> nativeint -> string
|
2006-04-05 04:49:07 -07:00
|
|
|
= "caml_nativeint_format"
|
|
|
|
external format_int64: string -> int64 -> string
|
|
|
|
= "caml_int64_format"
|
|
|
|
|
|
|
|
module Sformat = struct
|
2006-11-17 00:34:05 -08:00
|
|
|
|
|
|
|
type index;;
|
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
external unsafe_index_of_int : int -> index = "%identity"
|
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
let index_of_int i =
|
|
|
|
if i >= 0 then unsafe_index_of_int i
|
2008-07-01 02:55:52 -07:00
|
|
|
else failwith ("Sformat.index_of_int: negative argument " ^ string_of_int i)
|
|
|
|
;;
|
|
|
|
external int_of_index : index -> int = "%identity"
|
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
|
|
|
|
let add_int_index i idx = index_of_int (i + int_of_index idx);;
|
|
|
|
let succ_index = add_int_index 1;;
|
2009-03-28 07:24:53 -07:00
|
|
|
(* Literal position are one-based (hence pred p instead of p). *)
|
|
|
|
let index_of_literal_position p = index_of_int (pred p);;
|
2006-11-17 00:34:05 -08:00
|
|
|
|
2006-10-24 14:11:48 -07:00
|
|
|
external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int
|
2008-07-01 02:55:52 -07:00
|
|
|
= "%string_length"
|
|
|
|
;;
|
2006-10-24 14:11:48 -07:00
|
|
|
external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char
|
2008-07-01 02:55:52 -07:00
|
|
|
= "%string_safe_get"
|
|
|
|
;;
|
2006-10-24 14:11:48 -07:00
|
|
|
external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char
|
2008-07-01 02:55:52 -07:00
|
|
|
= "%string_unsafe_get"
|
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string
|
2008-07-01 02:55:52 -07:00
|
|
|
= "%identity"
|
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
let sub fmt idx len =
|
2008-07-01 02:55:52 -07:00
|
|
|
String.sub (unsafe_to_string fmt) (int_of_index idx) len
|
|
|
|
;;
|
|
|
|
let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt)
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
end
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
let bad_conversion sfmt i c =
|
2001-10-28 06:21:27 -08:00
|
|
|
invalid_arg
|
2008-07-01 02:55:52 -07:00
|
|
|
("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
|
|
|
|
string_of_int i ^ " in format string ``" ^ sfmt ^ "''")
|
|
|
|
;;
|
2006-04-05 04:49:07 -07:00
|
|
|
|
|
|
|
let bad_conversion_format fmt i c =
|
2008-07-01 02:55:52 -07:00
|
|
|
bad_conversion (Sformat.to_string fmt) i c
|
|
|
|
;;
|
2004-12-06 22:17:12 -08:00
|
|
|
|
|
|
|
let incomplete_format fmt =
|
|
|
|
invalid_arg
|
2008-07-01 02:55:52 -07:00
|
|
|
("Printf: premature end of format string ``" ^
|
|
|
|
Sformat.to_string fmt ^ "''")
|
|
|
|
;;
|
2001-10-28 06:21:27 -08:00
|
|
|
|
2006-11-17 00:34:05 -08:00
|
|
|
(* Parses a string conversion to return the specified length and the padding direction. *)
|
|
|
|
let parse_string_conversion sfmt =
|
2002-10-07 05:15:17 -07:00
|
|
|
let rec parse neg i =
|
2006-04-05 04:49:07 -07:00
|
|
|
if i >= String.length sfmt then (0, neg) else
|
|
|
|
match String.unsafe_get sfmt i with
|
2002-10-07 05:15:17 -07:00
|
|
|
| '1'..'9' ->
|
2006-11-17 00:34:05 -08:00
|
|
|
(int_of_string
|
|
|
|
(String.sub sfmt i (String.length sfmt - i - 1)),
|
|
|
|
neg)
|
2002-10-07 05:15:17 -07:00
|
|
|
| '-' ->
|
2006-11-17 00:34:05 -08:00
|
|
|
parse true (succ i)
|
2002-10-07 05:15:17 -07:00
|
|
|
| _ ->
|
2006-11-17 00:34:05 -08:00
|
|
|
parse neg (succ i) in
|
2008-07-01 02:55:52 -07:00
|
|
|
try parse false 1 with
|
|
|
|
| Failure _ -> bad_conversion sfmt 0 's'
|
|
|
|
;;
|
2002-10-07 05:15:17 -07:00
|
|
|
|
|
|
|
(* Pad a (sub) string into a blank string of length [p],
|
|
|
|
on the right if [neg] is true, on the left otherwise. *)
|
|
|
|
let pad_string pad_char p neg s i len =
|
|
|
|
if p = len && i = 0 then s else
|
2003-03-12 08:40:35 -08:00
|
|
|
if p <= len then String.sub s i len else
|
2002-10-07 05:15:17 -07:00
|
|
|
let res = String.make p pad_char in
|
|
|
|
if neg
|
|
|
|
then String.blit s i res 0 len
|
|
|
|
else String.blit s i res (p - len) len;
|
|
|
|
res
|
2011-07-20 02:17:07 -07:00
|
|
|
;;
|
2002-10-07 05:15:17 -07:00
|
|
|
|
|
|
|
(* Format a string given a %s format, e.g. %40s or %-20s.
|
2008-07-01 02:55:52 -07:00
|
|
|
To do ?: ignore other flags (#, +, etc). *)
|
2006-04-05 04:49:07 -07:00
|
|
|
let format_string sfmt s =
|
2006-11-17 00:34:05 -08:00
|
|
|
let (p, neg) = parse_string_conversion sfmt in
|
2008-07-01 02:55:52 -07:00
|
|
|
pad_string ' ' p neg s 0 (String.length s)
|
|
|
|
;;
|
2002-10-07 05:15:17 -07:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
(* Extract a format string out of [fmt] between [start] and [stop] inclusive.
|
2008-07-01 05:47:39 -07:00
|
|
|
['*'] in the format are replaced by integers taken from the [widths] list.
|
2008-07-01 02:55:52 -07:00
|
|
|
[extract_format] returns a string which is the string representation of
|
|
|
|
the resulting format string. *)
|
2001-10-28 06:21:27 -08:00
|
|
|
let extract_format fmt start stop widths =
|
2005-09-26 03:12:01 -07:00
|
|
|
let skip_positional_spec start =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt start with
|
2005-09-26 03:12:01 -07:00
|
|
|
| '0'..'9' ->
|
2009-03-28 07:24:53 -07:00
|
|
|
let rec skip_int_literal i =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2009-03-28 07:24:53 -07:00
|
|
|
| '0'..'9' -> skip_int_literal (succ i)
|
2005-09-26 03:12:01 -07:00
|
|
|
| '$' -> succ i
|
|
|
|
| _ -> start in
|
2009-03-28 07:24:53 -07:00
|
|
|
skip_int_literal (succ start)
|
2005-09-26 03:12:01 -07:00
|
|
|
| _ -> start in
|
|
|
|
let start = skip_positional_spec (succ start) in
|
|
|
|
let b = Buffer.create (stop - start + 10) in
|
|
|
|
Buffer.add_char b '%';
|
|
|
|
let rec fill_format i widths =
|
|
|
|
if i <= stop then
|
2006-04-05 04:49:07 -07:00
|
|
|
match (Sformat.unsafe_get fmt i, widths) with
|
2005-09-26 03:12:01 -07:00
|
|
|
| ('*', h :: t) ->
|
|
|
|
Buffer.add_string b (string_of_int h);
|
|
|
|
let i = skip_positional_spec (succ i) in
|
|
|
|
fill_format i t
|
|
|
|
| ('*', []) ->
|
2009-09-23 04:18:23 -07:00
|
|
|
assert false (* Should not happen since this is ill-typed. *)
|
2005-09-26 03:12:01 -07:00
|
|
|
| (c, _) ->
|
2009-05-20 04:52:42 -07:00
|
|
|
Buffer.add_char b c;
|
|
|
|
fill_format (succ i) widths in
|
2005-09-26 03:12:01 -07:00
|
|
|
fill_format start (List.rev widths);
|
2008-07-01 02:55:52 -07:00
|
|
|
Buffer.contents b
|
|
|
|
;;
|
2001-10-28 06:21:27 -08:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
let extract_format_int conv fmt start stop widths =
|
|
|
|
let sfmt = extract_format fmt start stop widths in
|
2002-12-08 05:52:02 -08:00
|
|
|
match conv with
|
2006-04-05 04:49:07 -07:00
|
|
|
| 'n' | 'N' ->
|
2006-05-04 05:52:22 -07:00
|
|
|
sfmt.[String.length sfmt - 1] <- 'u';
|
2006-04-05 04:49:07 -07:00
|
|
|
sfmt
|
2008-07-01 02:55:52 -07:00
|
|
|
| _ -> sfmt
|
|
|
|
;;
|
2002-12-08 05:52:02 -08:00
|
|
|
|
2009-05-20 04:52:42 -07:00
|
|
|
let extract_format_float conv fmt start stop widths =
|
|
|
|
let sfmt = extract_format fmt start stop widths in
|
|
|
|
match conv with
|
|
|
|
| 'F' ->
|
2009-09-23 04:18:23 -07:00
|
|
|
sfmt.[String.length sfmt - 1] <- 'g';
|
2009-05-20 04:52:42 -07:00
|
|
|
sfmt
|
|
|
|
| _ -> sfmt
|
|
|
|
;;
|
|
|
|
|
2006-10-04 03:02:01 -07:00
|
|
|
(* Returns the position of the next character following the meta format
|
2004-09-22 02:17:21 -07:00
|
|
|
string, starting from position [i], inside a given format [fmt].
|
|
|
|
According to the character [conv], the meta format string is
|
2009-09-25 01:01:40 -07:00
|
|
|
enclosed by the delimiters %{ and %} (when [conv = '{']) or %( and
|
2005-03-04 06:51:31 -08:00
|
|
|
%) (when [conv = '(']). Hence, [sub_format] returns the index of
|
2006-10-27 02:13:40 -07:00
|
|
|
the character following the [')'] or ['}'] that ends the meta format,
|
2006-10-04 03:02:01 -07:00
|
|
|
according to the character [conv]. *)
|
2006-04-05 04:49:07 -07:00
|
|
|
let sub_format incomplete_format bad_conversion_format conv fmt i =
|
|
|
|
let len = Sformat.length fmt in
|
2004-09-22 02:17:21 -07:00
|
|
|
let rec sub_fmt c i =
|
2006-01-04 00:50:40 -08:00
|
|
|
let close = if c = '(' then ')' else (* '{' *) '}' in
|
2004-09-22 02:17:21 -07:00
|
|
|
let rec sub j =
|
2004-12-06 22:17:12 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.get fmt j with
|
2005-09-20 10:18:03 -07:00
|
|
|
| '%' -> sub_sub (succ j)
|
|
|
|
| _ -> sub (succ j)
|
2004-09-22 02:17:21 -07:00
|
|
|
and sub_sub j =
|
2004-12-06 22:17:12 -08:00
|
|
|
if j >= len then incomplete_format fmt else
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.get fmt j with
|
2004-12-06 22:17:12 -08:00
|
|
|
| '(' | '{' as c ->
|
2008-07-01 02:55:52 -07:00
|
|
|
let j = sub_fmt c (succ j) in
|
|
|
|
sub (succ j)
|
2006-01-04 00:50:40 -08:00
|
|
|
| '}' | ')' as c ->
|
2006-10-04 03:02:01 -07:00
|
|
|
if c = close then succ j else bad_conversion_format fmt i c
|
2005-09-20 10:18:03 -07:00
|
|
|
| _ -> sub (succ j) in
|
2004-09-22 02:17:21 -07:00
|
|
|
sub i in
|
2008-07-01 02:55:52 -07:00
|
|
|
sub_fmt conv i
|
|
|
|
;;
|
2004-09-22 02:17:21 -07:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
let sub_format_for_printf conv =
|
2011-07-20 02:17:07 -07:00
|
|
|
sub_format incomplete_format bad_conversion_format conv
|
|
|
|
;;
|
2004-12-06 22:17:12 -08:00
|
|
|
|
2006-01-04 00:50:40 -08:00
|
|
|
let iter_on_format_args fmt add_conv add_char =
|
2006-04-05 04:49:07 -07:00
|
|
|
|
|
|
|
let lim = Sformat.length fmt - 1 in
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2005-09-20 10:18:03 -07:00
|
|
|
let rec scan_flags skip i =
|
2006-01-24 03:12:26 -08:00
|
|
|
if i > lim then incomplete_format fmt else
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2005-09-20 10:18:03 -07:00
|
|
|
| '*' -> scan_flags skip (add_conv skip i 'i')
|
2008-09-10 08:34:51 -07:00
|
|
|
(* | '$' -> scan_flags skip (succ i) *** PR#4321 *)
|
2005-09-20 10:18:03 -07:00
|
|
|
| '#' | '-' | ' ' | '+' -> scan_flags skip (succ i)
|
|
|
|
| '_' -> scan_flags true (succ i)
|
2004-09-22 02:17:21 -07:00
|
|
|
| '0'..'9'
|
2005-09-26 03:12:01 -07:00
|
|
|
| '.' -> scan_flags skip (succ i)
|
2005-09-20 10:18:03 -07:00
|
|
|
| _ -> scan_conv skip i
|
|
|
|
and scan_conv skip i =
|
2006-01-24 03:12:26 -08:00
|
|
|
if i > lim then incomplete_format fmt else
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2012-01-11 07:22:51 -08:00
|
|
|
| '%' | '@' | '!' | ',' -> succ i
|
2005-09-20 10:18:03 -07:00
|
|
|
| 's' | 'S' | '[' -> add_conv skip i 's'
|
|
|
|
| 'c' | 'C' -> add_conv skip i 'c'
|
2006-05-04 05:52:22 -07:00
|
|
|
| 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i'
|
2005-09-20 10:18:03 -07:00
|
|
|
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f'
|
|
|
|
| 'B' | 'b' -> add_conv skip i 'B'
|
2006-10-24 15:07:47 -07:00
|
|
|
| 'a' | 'r' | 't' as conv -> add_conv skip i conv
|
2004-09-22 02:17:21 -07:00
|
|
|
| 'l' | 'n' | 'L' as conv ->
|
2006-05-04 05:52:22 -07:00
|
|
|
let j = succ i in
|
|
|
|
if j > lim then add_conv skip i 'i' else begin
|
|
|
|
match Sformat.get fmt j with
|
|
|
|
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
|
|
|
|
add_char (add_conv skip i conv) 'i'
|
2011-06-20 14:46:20 -07:00
|
|
|
| _ -> add_conv skip i 'i' end
|
2006-01-04 00:50:40 -08:00
|
|
|
| '{' as conv ->
|
|
|
|
(* Just get a regular argument, skipping the specification. *)
|
|
|
|
let i = add_conv skip i conv in
|
2006-10-04 03:02:01 -07:00
|
|
|
(* To go on, find the index of the next char after the meta format. *)
|
2006-01-04 00:50:40 -08:00
|
|
|
let j = sub_format_for_printf conv fmt i in
|
2006-10-04 03:02:01 -07:00
|
|
|
(* Add the meta specification to the summary anyway. *)
|
2006-01-04 00:50:40 -08:00
|
|
|
let rec loop i =
|
2006-10-04 03:02:01 -07:00
|
|
|
if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in
|
2006-01-04 00:50:40 -08:00
|
|
|
loop i;
|
2006-10-04 03:02:01 -07:00
|
|
|
(* Go on, starting at the closing brace to properly close the meta
|
|
|
|
specification in the summary. *)
|
|
|
|
scan_conv skip (j - 1)
|
2006-01-04 00:50:40 -08:00
|
|
|
| '(' as conv ->
|
|
|
|
(* Use the static format argument specification instead of
|
2006-01-24 03:12:26 -08:00
|
|
|
the runtime format argument value: they must have the same type
|
|
|
|
anyway. *)
|
|
|
|
scan_fmt (add_conv skip i conv)
|
2005-09-20 10:18:03 -07:00
|
|
|
| '}' | ')' as conv -> add_conv skip i conv
|
2006-04-05 04:49:07 -07:00
|
|
|
| conv -> bad_conversion_format fmt i conv
|
2006-01-24 03:12:26 -08:00
|
|
|
|
|
|
|
and scan_fmt i =
|
2004-09-22 02:17:21 -07:00
|
|
|
if i < lim then
|
2006-04-05 04:49:07 -07:00
|
|
|
if Sformat.get fmt i = '%'
|
2006-01-24 03:12:26 -08:00
|
|
|
then scan_fmt (scan_flags false (succ i))
|
|
|
|
else scan_fmt (succ i)
|
|
|
|
else i in
|
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
ignore (scan_fmt 0)
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
|
|
|
(* Returns a string that summarizes the typing information that a given
|
|
|
|
format string contains.
|
2006-05-04 05:52:22 -07:00
|
|
|
For instance, [summarize_format_type "A number %d\n"] is "%i".
|
|
|
|
It also checks the well-formedness of the format string. *)
|
2005-09-20 10:18:03 -07:00
|
|
|
let summarize_format_type fmt =
|
2006-04-05 04:49:07 -07:00
|
|
|
let len = Sformat.length fmt in
|
2005-09-20 10:18:03 -07:00
|
|
|
let b = Buffer.create len in
|
2006-01-04 00:50:40 -08:00
|
|
|
let add_char i c = Buffer.add_char b c; succ i in
|
|
|
|
let add_conv skip i c =
|
2005-09-20 10:18:03 -07:00
|
|
|
if skip then Buffer.add_string b "%_" else Buffer.add_char b '%';
|
2006-01-04 00:50:40 -08:00
|
|
|
add_char i c in
|
|
|
|
iter_on_format_args fmt add_conv add_char;
|
2008-07-01 02:55:52 -07:00
|
|
|
Buffer.contents b
|
|
|
|
;;
|
2004-09-22 02:17:21 -07:00
|
|
|
|
2006-11-17 00:34:05 -08:00
|
|
|
module Ac = struct
|
|
|
|
type ac = {
|
|
|
|
mutable ac_rglr : int;
|
|
|
|
mutable ac_skip : int;
|
|
|
|
mutable ac_rdrs : int;
|
|
|
|
}
|
2008-07-01 02:55:52 -07:00
|
|
|
end
|
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
|
|
|
|
open Ac;;
|
2006-10-27 02:13:40 -07:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
(* Computes the number of arguments of a format (including the flag
|
2005-09-20 10:18:03 -07:00
|
|
|
arguments if any). *)
|
2006-11-06 02:22:42 -08:00
|
|
|
let ac_of_format fmt =
|
|
|
|
let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in
|
|
|
|
let incr_ac skip c =
|
2006-10-27 02:13:40 -07:00
|
|
|
let inc = if c = 'a' then 2 else 1 in
|
2006-11-06 02:22:42 -08:00
|
|
|
if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1;
|
2006-10-27 02:13:40 -07:00
|
|
|
if skip
|
2006-11-06 02:22:42 -08:00
|
|
|
then ac.ac_skip <- ac.ac_skip + inc
|
|
|
|
else ac.ac_rglr <- ac.ac_rglr + inc in
|
2005-09-20 10:18:03 -07:00
|
|
|
let add_conv skip i c =
|
2006-01-04 00:50:40 -08:00
|
|
|
(* Just finishing a meta format: no additional argument to record. *)
|
2006-11-06 02:22:42 -08:00
|
|
|
if c <> ')' && c <> '}' then incr_ac skip c;
|
2005-09-20 10:18:03 -07:00
|
|
|
succ i
|
2011-06-20 14:46:20 -07:00
|
|
|
and add_char i _ = succ i in
|
2006-10-27 02:13:40 -07:00
|
|
|
|
2006-01-04 00:50:40 -08:00
|
|
|
iter_on_format_args fmt add_conv add_char;
|
2008-07-01 02:55:52 -07:00
|
|
|
ac
|
|
|
|
;;
|
2006-10-27 02:13:40 -07:00
|
|
|
|
2006-11-06 02:22:42 -08:00
|
|
|
let count_arguments_of_format fmt =
|
|
|
|
let ac = ac_of_format fmt in
|
2011-07-20 02:17:07 -07:00
|
|
|
(* For printing, only the regular arguments have to be counted. *)
|
2009-03-28 07:24:53 -07:00
|
|
|
ac.ac_rglr
|
2008-07-01 02:55:52 -07:00
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
|
|
|
let list_iter_i f l =
|
|
|
|
let rec loop i = function
|
|
|
|
| [] -> ()
|
2006-10-27 02:13:40 -07:00
|
|
|
| [x] -> f i x (* Tail calling [f] *)
|
2005-09-20 10:18:03 -07:00
|
|
|
| x :: xs -> f i x; loop (succ i) xs in
|
2008-07-01 02:55:52 -07:00
|
|
|
loop 0 l
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2005-09-26 03:12:01 -07:00
|
|
|
(* ``Abstracting'' version of kprintf: returns a (curried) function that
|
2005-09-30 09:15:18 -07:00
|
|
|
will print when totally applied.
|
|
|
|
Note: in the following, we are careful not to be badly caught
|
2009-04-06 15:23:23 -07:00
|
|
|
by the compiler optimizations for the representation of arrays. *)
|
2005-09-20 10:18:03 -07:00
|
|
|
let kapr kpr fmt =
|
2006-11-06 02:22:42 -08:00
|
|
|
match count_arguments_of_format fmt with
|
2005-09-20 10:18:03 -07:00
|
|
|
| 0 -> kpr fmt [||]
|
2005-09-30 09:15:18 -07:00
|
|
|
| 1 -> Obj.magic (fun x ->
|
|
|
|
let a = Array.make 1 (Obj.repr 0) in
|
|
|
|
a.(0) <- x;
|
|
|
|
kpr fmt a)
|
|
|
|
| 2 -> Obj.magic (fun x y ->
|
|
|
|
let a = Array.make 2 (Obj.repr 0) in
|
|
|
|
a.(0) <- x; a.(1) <- y;
|
|
|
|
kpr fmt a)
|
|
|
|
| 3 -> Obj.magic (fun x y z ->
|
|
|
|
let a = Array.make 3 (Obj.repr 0) in
|
|
|
|
a.(0) <- x; a.(1) <- y; a.(2) <- z;
|
|
|
|
kpr fmt a)
|
|
|
|
| 4 -> Obj.magic (fun x y z t ->
|
|
|
|
let a = Array.make 4 (Obj.repr 0) in
|
|
|
|
a.(0) <- x; a.(1) <- y; a.(2) <- z;
|
|
|
|
a.(3) <- t;
|
|
|
|
kpr fmt a)
|
|
|
|
| 5 -> Obj.magic (fun x y z t u ->
|
|
|
|
let a = Array.make 5 (Obj.repr 0) in
|
|
|
|
a.(0) <- x; a.(1) <- y; a.(2) <- z;
|
|
|
|
a.(3) <- t; a.(4) <- u;
|
|
|
|
kpr fmt a)
|
|
|
|
| 6 -> Obj.magic (fun x y z t u v ->
|
|
|
|
let a = Array.make 6 (Obj.repr 0) in
|
|
|
|
a.(0) <- x; a.(1) <- y; a.(2) <- z;
|
|
|
|
a.(3) <- t; a.(4) <- u; a.(5) <- v;
|
|
|
|
kpr fmt a)
|
2005-09-20 10:18:03 -07:00
|
|
|
| nargs ->
|
|
|
|
let rec loop i args =
|
|
|
|
if i >= nargs then
|
2005-09-30 09:15:18 -07:00
|
|
|
let a = Array.make nargs (Obj.repr 0) in
|
|
|
|
list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args;
|
|
|
|
kpr fmt a
|
2005-09-20 10:18:03 -07:00
|
|
|
else Obj.magic (fun x -> loop (succ i) (x :: args)) in
|
2008-07-01 02:55:52 -07:00
|
|
|
loop 0 []
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2006-05-04 05:52:22 -07:00
|
|
|
type positional_specification =
|
2008-07-01 02:55:52 -07:00
|
|
|
| Spec_none | Spec_index of Sformat.index
|
|
|
|
;;
|
2006-01-24 03:12:26 -08:00
|
|
|
|
|
|
|
(* To scan an optional positional parameter specification,
|
2006-10-27 02:13:40 -07:00
|
|
|
i.e. an integer followed by a [$].
|
2008-07-01 02:55:52 -07:00
|
|
|
|
|
|
|
Calling [got_spec] with appropriate arguments, we ``return'' a positional
|
|
|
|
specification and an index to go on scanning the [fmt] format at hand.
|
|
|
|
|
2009-04-06 15:23:23 -07:00
|
|
|
Note that this is optimized for the regular case, i.e. no positional
|
2008-09-27 13:50:01 -07:00
|
|
|
parameter, since in this case we juste ``return'' the constant
|
|
|
|
[Spec_none]; in case we have a positional parameter, we ``return'' a
|
2011-07-20 02:17:07 -07:00
|
|
|
[Spec_index] [positional_specification] which is a bit more costly.
|
2008-09-27 13:50:01 -07:00
|
|
|
|
|
|
|
Note also that we do not support [*$] specifications, since this would
|
|
|
|
lead to type checking problems: a [*$] positional specification means
|
|
|
|
``take the next argument to [printf] (which must be an integer value)'',
|
|
|
|
name this integer value $n$; [*$] now designates parameter $n$.
|
2008-07-01 05:47:39 -07:00
|
|
|
|
|
|
|
Unfortunately, the type of a parameter specified via a [*$] positional
|
|
|
|
specification should be the type of the corresponding argument to
|
2009-03-28 07:24:53 -07:00
|
|
|
[printf], hence this should be the type of the $n$-th argument to [printf]
|
2008-07-01 05:47:39 -07:00
|
|
|
with $n$ being the {\em value} of the integer argument defining [*]; we
|
|
|
|
clearly cannot statically guess the value of this parameter in the general
|
|
|
|
case. Put it another way: this means type dependency, which is completely
|
2011-12-21 07:37:54 -08:00
|
|
|
out of scope of the OCaml type algebra. *)
|
2008-07-01 05:47:39 -07:00
|
|
|
|
2011-06-20 14:46:20 -07:00
|
|
|
let scan_positional_spec fmt got_spec i =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2005-09-26 03:12:01 -07:00
|
|
|
| '0'..'9' as d ->
|
2009-03-28 07:24:53 -07:00
|
|
|
let rec get_int_literal accu j =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt j with
|
2005-09-26 03:12:01 -07:00
|
|
|
| '0'..'9' as d ->
|
2009-03-28 07:24:53 -07:00
|
|
|
get_int_literal (10 * accu + (int_of_char d - 48)) (succ j)
|
2005-09-26 03:12:01 -07:00
|
|
|
| '$' ->
|
2007-10-04 14:00:51 -07:00
|
|
|
if accu = 0 then
|
|
|
|
failwith "printf: bad positional specification (0)." else
|
2009-03-28 07:24:53 -07:00
|
|
|
got_spec (Spec_index (Sformat.index_of_literal_position accu)) (succ j)
|
2008-07-01 02:55:52 -07:00
|
|
|
(* Not a positional specification: tell so the caller, and go back to
|
|
|
|
scanning the format from the original [i] position we were called at
|
|
|
|
first. *)
|
2006-05-04 05:52:22 -07:00
|
|
|
| _ -> got_spec Spec_none i in
|
2009-03-28 07:24:53 -07:00
|
|
|
get_int_literal (int_of_char d - 48) (succ i)
|
2008-07-01 02:55:52 -07:00
|
|
|
(* No positional specification: tell so the caller, and go back to scanning
|
|
|
|
the format from the original [i] position. *)
|
|
|
|
| _ -> got_spec Spec_none i
|
|
|
|
;;
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
(* Get the index of the next argument to printf, according to the given
|
2006-01-24 03:12:26 -08:00
|
|
|
positional specification. *)
|
|
|
|
let next_index spec n =
|
|
|
|
match spec with
|
2006-11-17 00:34:05 -08:00
|
|
|
| Spec_none -> Sformat.succ_index n
|
2008-07-01 02:55:52 -07:00
|
|
|
| Spec_index _ -> n
|
|
|
|
;;
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
(* Get the index of the actual argument to printf, according to its
|
2006-01-24 03:12:26 -08:00
|
|
|
optional positional specification. *)
|
|
|
|
let get_index spec n =
|
|
|
|
match spec with
|
|
|
|
| Spec_none -> n
|
2008-07-01 02:55:52 -07:00
|
|
|
| Spec_index p -> p
|
|
|
|
;;
|
2005-09-26 03:12:01 -07:00
|
|
|
|
2011-12-21 07:37:54 -08:00
|
|
|
(* Format a float argument as a valid OCaml lexeme. *)
|
2009-09-25 01:01:40 -07:00
|
|
|
let format_float_lexeme =
|
2009-09-23 04:18:23 -07:00
|
|
|
|
|
|
|
(* To be revised: this procedure should be a unique loop that performs the
|
2009-09-25 01:01:40 -07:00
|
|
|
validity check and the string lexeme modification at the same time.
|
2009-09-23 04:18:23 -07:00
|
|
|
Otherwise, it is too difficult to handle the strange padding facilities
|
|
|
|
given by printf. Let alone handling the correct widths indication,
|
|
|
|
knowing that we have sometime to add a '.' at the end of the result!
|
|
|
|
*)
|
|
|
|
|
2009-09-25 01:01:40 -07:00
|
|
|
let make_valid_float_lexeme s =
|
|
|
|
(* Check if s is already a valid lexeme:
|
2009-12-09 00:28:59 -08:00
|
|
|
in this case do nothing,
|
2011-12-21 07:37:54 -08:00
|
|
|
otherwise turn s into a valid OCaml lexeme. *)
|
2009-11-30 13:49:25 -08:00
|
|
|
let l = String.length s in
|
2009-09-23 04:18:23 -07:00
|
|
|
let rec valid_float_loop i =
|
2009-11-30 13:49:25 -08:00
|
|
|
if i >= l then s ^ "." else
|
2009-09-23 04:18:23 -07:00
|
|
|
match s.[i] with
|
2009-09-25 01:01:40 -07:00
|
|
|
(* Sure, this is already a valid float lexeme. *)
|
2009-12-07 08:40:39 -08:00
|
|
|
| '.' | 'e' | 'E' -> s
|
2009-09-23 04:18:23 -07:00
|
|
|
| _ -> valid_float_loop (i + 1) in
|
|
|
|
|
|
|
|
valid_float_loop 0 in
|
|
|
|
|
|
|
|
(fun sfmt x ->
|
|
|
|
let s = format_float sfmt x in
|
|
|
|
match classify_float x with
|
2009-09-25 01:01:40 -07:00
|
|
|
| FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s
|
2009-09-23 04:18:23 -07:00
|
|
|
| FP_nan | FP_infinite -> s)
|
2009-05-20 04:52:42 -07:00
|
|
|
;;
|
|
|
|
|
2006-10-27 02:13:40 -07:00
|
|
|
(* Decode a format string and act on it.
|
2008-07-01 05:47:39 -07:00
|
|
|
[fmt] is the [printf] format string, and [pos] points to a [%] character in
|
2008-07-01 02:55:52 -07:00
|
|
|
the format string.
|
2001-10-28 06:21:27 -08:00
|
|
|
After consuming the appropriate number of arguments and formatting
|
2008-07-01 05:47:39 -07:00
|
|
|
them, one of the following five continuations described below is called:
|
|
|
|
|
|
|
|
- [cont_s] for outputting a string (arguments: arg num, string, next pos)
|
|
|
|
- [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos)
|
|
|
|
- [cont_t] for performing a %t action (arguments: arg num, fn, next pos)
|
|
|
|
- [cont_f] for performing a flush action (arguments: arg num, next pos)
|
|
|
|
- [cont_m] for performing a %( action (arguments: arg num, sfmt, next pos)
|
|
|
|
|
|
|
|
"arg num" is the index in array [args] of the next argument to [printf].
|
2001-10-28 06:21:27 -08:00
|
|
|
"next pos" is the position in [fmt] of the first character following
|
2006-05-04 05:52:22 -07:00
|
|
|
the %conversion specification in [fmt]. *)
|
2001-10-28 06:21:27 -08:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
(* Note: here, rather than test explicitly against [Sformat.length fmt]
|
|
|
|
to detect the end of the format, we use [Sformat.unsafe_get] and
|
2009-03-28 07:24:53 -07:00
|
|
|
rely on the fact that we'll get a "null" character if we access
|
|
|
|
one past the end of the string. These "null" characters are then
|
2004-12-06 22:17:12 -08:00
|
|
|
caught by the [_ -> bad_conversion] clauses below.
|
2002-10-07 05:15:17 -07:00
|
|
|
Don't do this at home, kids. *)
|
2005-09-20 10:18:03 -07:00
|
|
|
let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
|
|
|
|
|
2006-11-17 00:34:05 -08:00
|
|
|
let get_arg spec n =
|
|
|
|
Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2006-01-24 03:12:26 -08:00
|
|
|
let rec scan_positional n widths i =
|
2006-05-04 05:52:22 -07:00
|
|
|
let got_spec spec i = scan_flags spec n widths i in
|
2011-06-20 14:46:20 -07:00
|
|
|
scan_positional_spec fmt got_spec i
|
2006-01-24 03:12:26 -08:00
|
|
|
|
|
|
|
and scan_flags spec n widths i =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2001-10-28 06:21:27 -08:00
|
|
|
| '*' ->
|
2006-05-04 05:52:22 -07:00
|
|
|
let got_spec wspec i =
|
2006-01-24 03:12:26 -08:00
|
|
|
let (width : int) = get_arg wspec n in
|
|
|
|
scan_flags spec (next_index wspec n) (width :: widths) i in
|
2011-06-20 14:46:20 -07:00
|
|
|
scan_positional_spec fmt got_spec (succ i)
|
2005-09-30 09:15:18 -07:00
|
|
|
| '0'..'9'
|
2006-01-24 03:12:26 -08:00
|
|
|
| '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
|
|
|
|
| _ -> scan_conv spec n widths i
|
2005-09-26 03:12:01 -07:00
|
|
|
|
2006-01-24 03:12:26 -08:00
|
|
|
and scan_conv spec n widths i =
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2012-01-11 07:22:51 -08:00
|
|
|
| '%' | '@' as c ->
|
|
|
|
cont_s n (String.make 1 c) (succ i)
|
|
|
|
| '!' -> cont_f n (succ i)
|
|
|
|
| ',' -> cont_s n "" (succ i)
|
2002-05-12 11:37:49 -07:00
|
|
|
| 's' | 'S' as conv ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : string) = get_arg spec n in
|
2005-09-20 10:18:03 -07:00
|
|
|
let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in
|
|
|
|
let s =
|
2009-04-06 15:23:23 -07:00
|
|
|
(* Optimize for common case %s *)
|
2005-09-20 10:18:03 -07:00
|
|
|
if i = succ pos then x else
|
|
|
|
format_string (extract_format fmt pos i widths) x in
|
2006-01-24 03:12:26 -08:00
|
|
|
cont_s (next_index spec n) s (succ i)
|
2012-01-11 07:22:51 -08:00
|
|
|
| '[' as conv ->
|
|
|
|
bad_conversion_format fmt i conv
|
2002-05-12 11:37:49 -07:00
|
|
|
| 'c' | 'C' as conv ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : char) = get_arg spec n in
|
2005-09-20 10:18:03 -07:00
|
|
|
let s =
|
|
|
|
if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in
|
2006-01-24 03:12:26 -08:00
|
|
|
cont_s (next_index spec n) s (succ i)
|
2006-05-04 05:52:22 -07:00
|
|
|
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : int) = get_arg spec n in
|
2006-04-05 04:49:07 -07:00
|
|
|
let s =
|
|
|
|
format_int (extract_format_int conv fmt pos i widths) x in
|
2006-01-24 03:12:26 -08:00
|
|
|
cont_s (next_index spec n) s (succ i)
|
2006-05-04 05:52:22 -07:00
|
|
|
| 'f' | 'e' | 'E' | 'g' | 'G' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : float) = get_arg spec n in
|
2006-05-04 05:52:22 -07:00
|
|
|
let s = format_float (extract_format fmt pos i widths) x in
|
2006-01-24 03:12:26 -08:00
|
|
|
cont_s (next_index spec n) s (succ i)
|
2009-05-20 04:52:42 -07:00
|
|
|
| 'F' as conv ->
|
2006-05-04 05:52:22 -07:00
|
|
|
let (x : float) = get_arg spec n in
|
2009-05-20 04:52:42 -07:00
|
|
|
let s =
|
2009-09-23 04:18:23 -07:00
|
|
|
if widths = [] then Pervasives.string_of_float x else
|
2009-09-25 01:01:40 -07:00
|
|
|
format_float_lexeme (extract_format_float conv fmt pos i widths) x in
|
2009-05-20 04:52:42 -07:00
|
|
|
cont_s (next_index spec n) s (succ i)
|
2003-07-01 09:30:12 -07:00
|
|
|
| 'B' | 'b' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : bool) = get_arg spec n in
|
|
|
|
cont_s (next_index spec n) (string_of_bool x) (succ i)
|
2001-10-28 06:21:27 -08:00
|
|
|
| 'a' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let printer = get_arg spec n in
|
|
|
|
(* If the printer spec is Spec_none, go on as usual.
|
|
|
|
If the printer spec is Spec_index p,
|
|
|
|
printer's argument spec is Spec_index (succ_index p). *)
|
2006-11-17 00:34:05 -08:00
|
|
|
let n = Sformat.succ_index (get_index spec n) in
|
2006-01-24 03:12:26 -08:00
|
|
|
let arg = get_arg Spec_none n in
|
|
|
|
cont_a (next_index spec n) printer arg (succ i)
|
2012-01-11 07:22:51 -08:00
|
|
|
| 'r' as conv ->
|
|
|
|
bad_conversion_format fmt i conv
|
2001-10-28 06:21:27 -08:00
|
|
|
| 't' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let printer = get_arg spec n in
|
|
|
|
cont_t (next_index spec n) printer (succ i)
|
2004-09-22 02:17:21 -07:00
|
|
|
| 'l' | 'n' | 'L' as conv ->
|
2006-04-05 04:49:07 -07:00
|
|
|
begin match Sformat.unsafe_get fmt (succ i) with
|
2006-05-04 05:52:22 -07:00
|
|
|
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
|
|
|
|
let i = succ i in
|
2005-09-20 10:18:03 -07:00
|
|
|
let s =
|
|
|
|
match conv with
|
|
|
|
| 'l' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : int32) = get_arg spec n in
|
2006-05-04 05:52:22 -07:00
|
|
|
format_int32 (extract_format fmt pos i widths) x
|
2005-09-20 10:18:03 -07:00
|
|
|
| 'n' ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : nativeint) = get_arg spec n in
|
2006-05-04 05:52:22 -07:00
|
|
|
format_nativeint (extract_format fmt pos i widths) x
|
2005-09-20 10:18:03 -07:00
|
|
|
| _ ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : int64) = get_arg spec n in
|
2006-05-04 05:52:22 -07:00
|
|
|
format_int64 (extract_format fmt pos i widths) x in
|
|
|
|
cont_s (next_index spec n) s (succ i)
|
2005-09-20 10:18:03 -07:00
|
|
|
| _ ->
|
2006-01-24 03:12:26 -08:00
|
|
|
let (x : int) = get_arg spec n in
|
2006-04-05 04:49:07 -07:00
|
|
|
let s = format_int (extract_format_int 'n' fmt pos i widths) x in
|
|
|
|
cont_s (next_index spec n) s (succ i)
|
2005-09-20 10:18:03 -07:00
|
|
|
end
|
2006-01-04 00:50:40 -08:00
|
|
|
| '{' | '(' as conv (* ')' '}' *) ->
|
2006-10-24 14:11:48 -07:00
|
|
|
let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
|
2005-09-20 10:18:03 -07:00
|
|
|
let i = succ i in
|
2006-10-04 03:02:01 -07:00
|
|
|
let j = sub_format_for_printf conv fmt i in
|
2005-09-20 10:18:03 -07:00
|
|
|
if conv = '{' (* '}' *) then
|
|
|
|
(* Just print the format argument as a specification. *)
|
2005-09-26 03:12:01 -07:00
|
|
|
cont_s
|
2006-01-24 03:12:26 -08:00
|
|
|
(next_index spec n)
|
2006-04-05 04:49:07 -07:00
|
|
|
(summarize_format_type xf)
|
2006-01-04 00:50:40 -08:00
|
|
|
j else
|
2005-09-20 10:18:03 -07:00
|
|
|
(* Use the format argument instead of the format specification. *)
|
2006-01-24 03:12:26 -08:00
|
|
|
cont_m (next_index spec n) xf j
|
2006-01-04 00:50:40 -08:00
|
|
|
| (* '(' *) ')' ->
|
2005-09-20 10:18:03 -07:00
|
|
|
cont_s n "" (succ i)
|
2004-12-06 22:17:12 -08:00
|
|
|
| conv ->
|
2006-04-05 04:49:07 -07:00
|
|
|
bad_conversion_format fmt i conv in
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
scan_positional n [] (succ pos)
|
|
|
|
;;
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2006-04-05 08:39:10 -07:00
|
|
|
let mkprintf to_s get_out outc outs flush k fmt =
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
(* [out] is global to this definition of [pr], and must be shared by all its
|
2006-04-05 08:39:10 -07:00
|
|
|
recursive calls (if any). *)
|
2006-01-24 03:12:26 -08:00
|
|
|
let out = get_out fmt in
|
|
|
|
|
|
|
|
let rec pr k n fmt v =
|
2001-10-28 06:21:27 -08:00
|
|
|
|
2006-04-05 04:49:07 -07:00
|
|
|
let len = Sformat.length fmt in
|
2004-09-22 02:17:21 -07:00
|
|
|
|
2006-01-24 03:12:26 -08:00
|
|
|
let rec doprn n i =
|
|
|
|
if i >= len then Obj.magic (k out) else
|
2006-04-05 04:49:07 -07:00
|
|
|
match Sformat.unsafe_get fmt i with
|
2006-01-24 03:12:26 -08:00
|
|
|
| '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
|
|
|
|
| c -> outc out c; doprn n (succ i)
|
2007-10-04 14:00:51 -07:00
|
|
|
and cont_s n s i =
|
|
|
|
outs out s; doprn n i
|
|
|
|
and cont_a n printer arg i =
|
|
|
|
if to_s then
|
|
|
|
outs out ((Obj.magic printer : unit -> _ -> string) () arg)
|
|
|
|
else
|
|
|
|
printer out arg;
|
|
|
|
doprn n i
|
|
|
|
and cont_t n printer i =
|
|
|
|
if to_s 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 xf i =
|
|
|
|
let m = Sformat.add_int_index (count_arguments_of_format xf) n in
|
|
|
|
pr (Obj.magic (fun _ -> doprn m i)) n xf v in
|
|
|
|
|
|
|
|
doprn n 0 in
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2006-11-17 00:34:05 -08:00
|
|
|
let kpr = pr k (Sformat.index_of_int 0) in
|
2006-01-24 03:12:26 -08:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
kapr kpr fmt
|
|
|
|
;;
|
2004-10-04 13:21:04 -07:00
|
|
|
|
2012-04-11 11:01:02 -07:00
|
|
|
(**************************************************************
|
|
|
|
|
|
|
|
Defining [fprintf] and various flavors of [fprintf].
|
|
|
|
|
|
|
|
**************************************************************)
|
|
|
|
|
2005-09-20 10:18:03 -07:00
|
|
|
let kfprintf k oc =
|
2008-07-01 02:55:52 -07:00
|
|
|
mkprintf false (fun _ -> oc) output_char output_string flush k
|
|
|
|
;;
|
2012-04-11 11:01:02 -07:00
|
|
|
let ikfprintf k oc = kapr (fun _ _ -> Obj.magic (k oc));;
|
2006-11-06 01:12:53 -08:00
|
|
|
|
2006-05-04 05:52:22 -07:00
|
|
|
let fprintf oc = kfprintf ignore oc;;
|
2012-04-11 11:01:02 -07:00
|
|
|
let ifprintf oc = ikfprintf ignore oc;;
|
2006-05-04 05:52:22 -07:00
|
|
|
let printf fmt = fprintf stdout fmt;;
|
|
|
|
let eprintf fmt = fprintf stderr fmt;;
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2005-09-20 10:18:03 -07:00
|
|
|
let kbprintf k b =
|
2008-07-01 02:55:52 -07:00
|
|
|
mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k
|
|
|
|
;;
|
2006-05-04 05:52:22 -07:00
|
|
|
let bprintf b = kbprintf ignore b;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
|
|
|
let get_buff fmt =
|
2006-04-05 04:49:07 -07:00
|
|
|
let len = 2 * Sformat.length fmt in
|
2008-07-01 02:55:52 -07:00
|
|
|
Buffer.create len
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
|
|
|
let get_contents b =
|
|
|
|
let s = Buffer.contents b in
|
|
|
|
Buffer.clear b;
|
2008-07-01 02:55:52 -07:00
|
|
|
s
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
|
|
|
let get_cont k b = k (get_contents b);;
|
|
|
|
|
|
|
|
let ksprintf k =
|
2008-07-01 02:55:52 -07:00
|
|
|
mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k)
|
|
|
|
;;
|
2005-09-20 10:18:03 -07:00
|
|
|
|
2011-07-20 02:17:07 -07:00
|
|
|
let sprintf fmt = ksprintf (fun s -> s) fmt;;
|
|
|
|
|
2012-04-11 11:01:02 -07:00
|
|
|
(**************************************************************
|
|
|
|
|
|
|
|
Deprecated stuff.
|
|
|
|
|
|
|
|
**************************************************************)
|
|
|
|
|
2005-09-20 10:18:03 -07:00
|
|
|
let kprintf = ksprintf;;
|
|
|
|
|
2011-12-21 07:37:54 -08:00
|
|
|
(* For OCaml system internal use only: needed to implement modules [Format]
|
2011-07-20 02:17:07 -07:00
|
|
|
and [Scanf]. *)
|
2006-11-17 00:34:05 -08:00
|
|
|
|
|
|
|
module CamlinternalPr = struct
|
|
|
|
|
|
|
|
module Sformat = Sformat;;
|
|
|
|
|
|
|
|
module Tformat = struct
|
|
|
|
|
|
|
|
type ac =
|
|
|
|
Ac.ac = {
|
|
|
|
mutable ac_rglr : int;
|
|
|
|
mutable ac_skip : int;
|
|
|
|
mutable ac_rdrs : int;
|
2008-07-01 02:55:52 -07:00
|
|
|
}
|
2008-07-01 05:47:39 -07:00
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
|
|
|
|
let ac_of_format = ac_of_format;;
|
|
|
|
|
|
|
|
let sub_format = sub_format;;
|
|
|
|
|
|
|
|
let summarize_format_type = summarize_format_type;;
|
|
|
|
|
|
|
|
let scan_format = scan_format;;
|
|
|
|
|
|
|
|
let kapr = kapr;;
|
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
end
|
2008-07-01 05:47:39 -07:00
|
|
|
;;
|
2006-11-17 00:34:05 -08:00
|
|
|
|
2008-07-01 02:55:52 -07:00
|
|
|
end
|
|
|
|
;;
|