summaryrefslogtreecommitdiff
path: root/stdlib/printf.ml
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/printf.ml')
-rw-r--r--stdlib/printf.ml183
1 files changed, 61 insertions, 122 deletions
diff --git a/stdlib/printf.ml b/stdlib/printf.ml
index f4a27ca521..9652b14606 100644
--- a/stdlib/printf.ml
+++ b/stdlib/printf.ml
@@ -36,8 +36,6 @@ module Sformat = struct
let add_int_index i idx = index_of_int (i + int_of_index idx);;
let succ_index = add_int_index 1;;
- (* Litteral position are one-based (hence pred p instead of p). *)
- let index_of_litteral_position p = index_of_int (pred p);;
external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int
= "%string_length";;
@@ -102,17 +100,7 @@ let format_string sfmt s =
'*' in the format are replaced by integers taken from the [widths] list.
extract_format returns a string. *)
let extract_format fmt start stop widths =
- let skip_positional_spec start =
- match Sformat.unsafe_get fmt start with
- | '0'..'9' ->
- let rec skip_int_litteral i =
- match Sformat.unsafe_get fmt i with
- | '0'..'9' -> skip_int_litteral (succ i)
- | '$' -> succ i
- | _ -> start in
- skip_int_litteral (succ start)
- | _ -> start in
- let start = skip_positional_spec (succ start) in
+ let start = succ start in
let b = Buffer.create (stop - start + 10) in
Buffer.add_char b '%';
let rec fill_format i widths =
@@ -120,7 +108,7 @@ let extract_format fmt start stop widths =
match (Sformat.unsafe_get fmt i, widths) with
| ('*', h :: t) ->
Buffer.add_string b (string_of_int h);
- let i = skip_positional_spec (succ i) in
+ let i = succ i in
fill_format i t
| ('*', []) ->
assert false (* should not happen *)
@@ -175,7 +163,6 @@ let iter_on_format_args fmt add_conv add_char =
if i > lim then incomplete_format fmt else
match Sformat.unsafe_get fmt i with
| '*' -> scan_flags skip (add_conv skip i 'i')
- | '$' -> scan_flags skip (succ i)
| '#' | '-' | ' ' | '+' -> scan_flags skip (succ i)
| '_' -> scan_flags true (succ i)
| '0'..'9'
@@ -324,47 +311,8 @@ let kapr kpr fmt =
else Obj.magic (fun x -> loop (succ i) (x :: args)) in
loop 0 [];;
-type positional_specification =
- | Spec_none | Spec_index of Sformat.index;;
-
-(* To scan an optional positional parameter specification,
- i.e. an integer followed by a [$].
- We do not support [*$] specifications, since this would lead to type checking
- problems: the type of the specified [*$] parameter would be the type of the
- corresponding argument to [printf], hence the type of the $n$-th argument to
- [printf] with $n$ being the {\em value} of the integer argument defining
- [*]; this means type dependency, which is out of scope of the Caml type
- algebra. *)
-let scan_positional_spec fmt got_spec n i =
- match Sformat.unsafe_get fmt i with
- | '0'..'9' as d ->
- let rec get_int_litteral accu j =
- match Sformat.unsafe_get fmt j with
- | '0'..'9' as d ->
- get_int_litteral (10 * accu + (int_of_char d - 48)) (succ j)
- | '$' ->
- if accu = 0
- then failwith "printf: bad positional specification (0)." else
- got_spec (Spec_index (Sformat.index_of_litteral_position accu)) (succ j)
- (* Not a positional specification. *)
- | _ -> got_spec Spec_none i in
- get_int_litteral (int_of_char d - 48) (succ i)
- (* No positional specification. *)
- | _ -> got_spec Spec_none i;;
-
-(* Get the position of the next argument to printf, according to the given
- positional specification. *)
-let next_index spec n =
- match spec with
- | Spec_none -> Sformat.succ_index n
- | Spec_index _ -> n;;
-
-(* Get the position of the actual argument to printf, according to its
- optional positional specification. *)
-let get_index spec n =
- match spec with
- | Spec_none -> n
- | Spec_index p -> p;;
+(* Get the index of the next argument to printf. *)
+let next_index n = Sformat.succ_index n;;
(* Decode a format string and act on it.
[fmt] is the printf format string, and [pos] points to a [%] character.
@@ -388,67 +336,58 @@ let get_index spec n =
Don't do this at home, kids. *)
let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
- let get_arg spec n =
- Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
-
- let rec scan_positional n widths i =
- let got_spec spec i = scan_flags spec n widths i in
- scan_positional_spec fmt got_spec n i
+ let get_arg n =
+ Obj.magic (args.(Sformat.int_of_index n)) in
- and scan_flags spec n widths i =
+ let rec scan_flags n widths i =
match Sformat.unsafe_get fmt i with
| '*' ->
- let got_spec wspec i =
- let (width : int) = get_arg wspec n in
- scan_flags spec (next_index wspec n) (width :: widths) i in
- scan_positional_spec fmt got_spec n (succ i)
+ let (width : int) = get_arg n in
+ scan_flags (next_index n) (width :: widths) (succ i)
| '0'..'9'
- | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i)
- | _ -> scan_conv spec n widths i
+ | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i)
+ | _ -> scan_conv n widths i
- and scan_conv spec n widths i =
+ and scan_conv n widths i =
match Sformat.unsafe_get fmt i with
| '%' ->
cont_s n "%" (succ i)
| 's' | 'S' as conv ->
- let (x : string) = get_arg spec n in
+ let (x : string) = get_arg 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 (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
| 'c' | 'C' as conv ->
- let (x : char) = get_arg spec n in
+ let (x : char) = get_arg n in
let s =
if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in
- cont_s (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv ->
- let (x : int) = get_arg spec n in
+ let (x : int) = get_arg n in
let s =
format_int (extract_format_int conv fmt pos i widths) x in
- cont_s (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
| 'f' | 'e' | 'E' | 'g' | 'G' ->
- let (x : float) = get_arg spec n in
+ let (x : float) = get_arg n in
let s = format_float (extract_format fmt pos i widths) x in
- cont_s (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
| 'F' ->
- let (x : float) = get_arg spec n in
- cont_s (next_index spec n) (string_of_float x) (succ i)
+ let (x : float) = get_arg n in
+ cont_s (next_index n) (string_of_float x) (succ i)
| 'B' | 'b' ->
- let (x : bool) = get_arg spec n in
- cont_s (next_index spec n) (string_of_bool x) (succ i)
+ let (x : bool) = get_arg n in
+ cont_s (next_index n) (string_of_bool x) (succ i)
| 'a' ->
- 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). *)
- let n = Sformat.succ_index (get_index spec n) in
- let arg = get_arg Spec_none n in
- cont_a (next_index spec n) printer arg (succ i)
+ let printer = get_arg n in
+ let n = Sformat.succ_index n in
+ let arg = get_arg n in
+ cont_a (next_index n) printer arg (succ i)
| 't' ->
- let printer = get_arg spec n in
- cont_t (next_index spec n) printer (succ i)
+ let printer = get_arg n in
+ cont_t (next_index n) printer (succ i)
| 'l' | 'n' | 'L' as conv ->
begin match Sformat.unsafe_get fmt (succ i) with
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' ->
@@ -456,39 +395,39 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
let s =
match conv with
| 'l' ->
- let (x : int32) = get_arg spec n in
+ let (x : int32) = get_arg n in
format_int32 (extract_format fmt pos i widths) x
| 'n' ->
- let (x : nativeint) = get_arg spec n in
+ let (x : nativeint) = get_arg n in
format_nativeint (extract_format fmt pos i widths) x
| _ ->
- let (x : int64) = get_arg spec n in
+ let (x : int64) = get_arg n in
format_int64 (extract_format fmt pos i widths) x in
- cont_s (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
| _ ->
- let (x : int) = get_arg spec n in
+ let (x : int) = get_arg n in
let s = format_int (extract_format_int 'n' fmt pos i widths) x in
- cont_s (next_index spec n) s (succ i)
+ cont_s (next_index n) s (succ i)
end
| '!' -> cont_f n (succ i)
| '{' | '(' as conv (* ')' '}' *) ->
- let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in
+ let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg n in
let i = succ i in
let j = sub_format_for_printf conv fmt i in
if conv = '{' (* '}' *) then
(* Just print the format argument as a specification. *)
cont_s
- (next_index spec n)
+ (next_index n)
(summarize_format_type xf)
j else
(* Use the format argument instead of the format specification. *)
- cont_m (next_index spec n) xf j
+ cont_m (next_index n) xf j
| (* '(' *) ')' ->
cont_s n "" (succ i)
| conv ->
bad_conversion_format fmt i conv in
- scan_positional n [] (succ pos);;
+ scan_flags n [] (succ pos);;
let mkprintf to_s get_out outc outs flush k fmt =
@@ -505,27 +444,27 @@ let mkprintf to_s get_out outc outs flush k fmt =
match Sformat.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 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
+ 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
let kpr = pr k (Sformat.index_of_int 0) in