-
Notifications
You must be signed in to change notification settings - Fork 2
/
batPrintf.ml
518 lines (466 loc) · 18.1 KB
/
batPrintf.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
(*
* BatPrintf - Extended Printf module
* Copyright (C) 2008 David Teller (contributor)
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version,
* with the special exception on linking described in file LICENSE.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
(**
{6 Printf}
A reimplementation of Printf (with a few additional functions) based
on [output]. We provide an internal signature to limit the dangers
of {!Obj.magic}.
{b Note} this module is inlined because of circular dependencies (themselves
caused by the legacy definition of a function {!printf} in module {!BatIO}).
*)
open BatInnerIO
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"
external format_nativeint: string -> nativeint -> string
= "caml_nativeint_format"
external format_int64: string -> int64 -> string
= "caml_int64_format"
module Sformat = struct
type index;;
external unsafe_index_of_int : int -> index = "%identity";;
let index_of_int i =
if i >= 0 then unsafe_index_of_int i
else failwith ("index_of_int: negative argument " ^ string_of_int i);;
external int_of_index : index -> int = "%identity";;
let add_int_index i idx = index_of_int (i + int_of_index idx);;
let succ_index = add_int_index 1;;
let length fmt = String.length (string_of_format fmt)
let get fmt i = String.get (string_of_format fmt) i
let unsafe_get fmt i = String.unsafe_get (string_of_format fmt) i
let unsafe_to_string = string_of_format
let sub fmt idx len =
String.sub (unsafe_to_string fmt) (int_of_index idx) len;;
let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt);;
end;;
let bad_conversion sfmt i c =
invalid_arg
("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^
string_of_int i ^ " in format string ``" ^ sfmt ^ "''");;
let bad_conversion_format fmt i c =
bad_conversion (Sformat.to_string fmt) i c;;
let incomplete_format fmt =
invalid_arg
("printf: premature end of format string ``" ^
Sformat.to_string fmt ^ "''");;
(* Parses a string conversion to return the specified length and the padding direction. *)
let parse_string_conversion sfmt =
let rec parse neg i =
if i >= String.length sfmt then (0, neg) else
match String.unsafe_get sfmt i with
| '1'..'9' ->
(int_of_string
(String.sub sfmt i (String.length sfmt - i - 1)),
neg)
| '-' -> parse true (succ i)
| _ -> parse neg (succ i) in
try parse false 1 with Failure _ -> bad_conversion sfmt 0 's'
(* 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
if p <= len then String.sub s i len else
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
(* Format a string given a %s format, e.g. %40s or %-20s.
To do: ignore other flags (#, +, etc)? *)
let format_string sfmt s =
let (p, neg) = parse_string_conversion sfmt in
pad_string ' ' p neg s 0 (String.length s);;
(* Extract a format string out of [fmt] between [start] and [stop] inclusive.
'*' 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 start = 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
match (Sformat.unsafe_get fmt i, widths) with
| ('*', h :: t) ->
Buffer.add_string b (string_of_int h);
let i = succ i in
fill_format i t
| ('*', []) ->
assert false (* should not happen *)
| (c, _) ->
Buffer.add_char b c; fill_format (succ i) widths in
fill_format start (List.rev widths);
Buffer.contents b;;
let extract_format_int conv fmt start stop widths =
let sfmt = extract_format fmt start stop widths in
match conv with
| 'n' | 'N' ->
Bytes.set sfmt (String.length sfmt - 1) 'u';
sfmt
| _ -> sfmt;;
(* Returns the position of the next character following the meta format
string, starting from position [i], inside a given format [fmt].
According to the character [conv], the meta format string is
enclosed by the delimitors %{ and %} (when [conv = '{']) or %( and
%) (when [conv = '(']). Hence, [sub_format] returns the index of
the character following the [')'] or ['}'] that ends the meta format,
according to the character [conv]. *)
let sub_format incomplete_format bad_conversion_format conv fmt i =
let len = Sformat.length fmt in
let rec sub_fmt c i =
let close = if c = '(' then ')' else (* '{' *) '}' in
let rec sub j =
if j >= len then incomplete_format fmt else
match Sformat.get fmt j with
| '%' -> sub_sub (succ j)
| _ -> sub (succ j)
and sub_sub j =
if j >= len then incomplete_format fmt else
match Sformat.get fmt j with
| '(' | '{' as c ->
let j = sub_fmt c (succ j) in sub (succ j)
| '}' | ')' as c ->
if c = close then succ j else bad_conversion_format fmt i c
| _ -> sub (succ j) in
sub i in
sub_fmt conv i;;
let sub_format_for_printf conv =
sub_format incomplete_format bad_conversion_format conv;;
let iter_on_format_args fmt add_conv add_char =
let lim = Sformat.length fmt - 1 in
let rec scan_flags skip i =
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 true (succ i)
| '0'..'9'
| '.' -> scan_flags skip (succ i)
| _ -> scan_conv skip i
and scan_conv skip i =
if i > lim then incomplete_format fmt else
match Sformat.unsafe_get fmt i with
| '%' | '!' | ',' -> succ i
| 's' | 'S' | '[' -> add_conv skip i 's'
| 'c' | 'C' -> add_conv skip i 'c'
| 'd' | 'i' |'o' | 'u' | 'x' | 'X' | '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' | 'r' | 't' as conv -> add_conv skip i conv
| 'l' | 'n' | 'L' as conv ->
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'
| _c -> add_conv skip i 'i' end
| '{' as conv ->
(* Just get a regular argument, skipping the specification. *)
let i = add_conv skip i conv in
(* To go on, find the index of the next char after the meta format. *)
let j = sub_format_for_printf conv fmt i in
(* Add the meta specification to the summary anyway. *)
let rec loop i =
if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in
loop i;
(* Go on, starting at the closing brace to properly close the meta
specification in the summary. *)
scan_conv skip (j - 1)
| '(' as conv ->
(* Use the static format argument specification instead of
the runtime format argument value: they must have the same type
anyway. *)
scan_fmt (add_conv skip i conv)
| '}' | ')' as conv -> add_conv skip i conv
| conv -> bad_conversion_format fmt i conv
and scan_fmt i =
if i < lim then
if Sformat.get fmt i = '%'
then scan_fmt (scan_flags false (succ i))
else scan_fmt (succ i)
else i in
ignore (scan_fmt 0);;
(* Returns a string that summarizes the typing information that a given
format string contains.
For instance, [summarize_format_type "A number %d\n"] is "%i".
It also checks the well-formedness of the format string. *)
let summarize_format_type fmt =
let len = Sformat.length fmt in
let b = Buffer.create len in
let add_char i c = Buffer.add_char b c; succ i in
let add_conv skip i c =
if skip then Buffer.add_string b "%_" else Buffer.add_char b '%';
add_char i c in
iter_on_format_args fmt add_conv add_char;
Buffer.contents b;;
module Ac = struct
type ac = {
mutable ac_rglr : int;
mutable ac_skip : int;
mutable ac_rdrs : int;
}
end;;
open Ac;;
(* Computes the number of arguments of a format (including flag
arguments if any). *)
let ac_of_format fmt =
let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in
let incr_ac skip c =
let inc = if c = 'a' then 2 else 1 in
if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1;
if skip
then ac.ac_skip <- ac.ac_skip + inc
else ac.ac_rglr <- ac.ac_rglr + inc in
let add_conv skip i c =
(* Just finishing a meta format: no additional argument to record. *)
if c <> ')' && c <> '}' then incr_ac skip c;
succ i
and add_char i _c = succ i in
iter_on_format_args fmt add_conv add_char;
ac;;
let count_arguments_of_format fmt =
let ac = ac_of_format fmt in
ac.ac_rglr + ac.ac_skip + ac.ac_rdrs;;
let list_iter_i f l =
let rec loop i = function
| [] -> ()
| [x] -> f i x (* Tail calling [f] *)
| 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.
Note: in the following, we are careful not to be badly caught
by the compiler optimizations on the representation of arrays. *)
let kapr kpr fmt =
match count_arguments_of_format fmt with
| 0 -> kpr fmt [||]
| 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)
| nargs ->
let rec loop i args =
if i >= nargs then
let a = Array.make nargs (Obj.repr 0) in
list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args;
kpr fmt a
else Obj.magic (fun x -> loop (succ i) (x :: args)) in
loop 0 [];;
(* 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.
After consuming the appropriate number of arguments and formatting
them, one of the five continuations is called:
[cont_s] for outputting a string (args: arg num, string, next pos)
[cont_a] for performing a %a action (args: arg num, fn, arg, next pos)
[cont_t] for performing a %t action (args: arg num, fn, next pos)
[cont_f] for performing a flush action (args: arg num, next pos)
[cont_m] for performing a %( action (args: arg num, sfmt, next pos)
"arg num" is the index in array args of the next argument to printf.
"next pos" is the position in [fmt] of the first character following
the %conversion specification in [fmt]. *)
(* Note: here, rather than test explicitly against [Sformat.length fmt]
to detect the end of the format, we use [Sformat.unsafe_get] and
rely on the fact that we'll get a "nul" character if we access
one past the end of the string. These "nul" characters are then
caught by the [_ -> bad_conversion] clauses below.
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 n =
Obj.magic (args.(Sformat.int_of_index n)) in
let rec scan_flags n widths i =
match Sformat.unsafe_get fmt i with
| '*' ->
let (width : int) = get_arg n in
scan_flags (next_index 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 Sformat.unsafe_get fmt i with
| '%' ->
cont_s n "%" (succ i)
| 's' | 'S' as conv ->
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 n) s (succ i)
| 'c' | 'C' as conv ->
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 n) s (succ i)
| 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv ->
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 n) s (succ i)
| 'f' | 'e' | 'E' | 'g' | 'G' ->
let (x : float) = get_arg n in
let s = format_float (extract_format fmt pos i widths) x in
cont_s (next_index n) s (succ i)
| 'F' ->
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 n in
cont_s (next_index n) (string_of_bool x) (succ i)
| 'a' ->
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 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' ->
let i = succ i in
let s =
match conv with
| 'l' ->
let (x : int32) = get_arg n in
format_int32 (extract_format fmt pos i widths) x
| 'n' ->
let (x : nativeint) = get_arg n in
format_nativeint (extract_format fmt pos i widths) x
| _ ->
let (x : int64) = get_arg n in
format_int64 (extract_format fmt pos i widths) x in
cont_s (next_index n) s (succ i)
| _ ->
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 n) s (succ i)
end
| ',' -> cont_s n "" (succ i)
| '!' -> cont_f n (succ i)
| '{' | '(' as conv (* ')' '}' *) ->
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 n)
(summarize_format_type xf)
j else
(* Use the format argument instead of the format specification. *)
cont_m (next_index n) xf j
| (* '(' *) ')' ->
cont_s n "" (succ i)
| conv ->
bad_conversion_format fmt i conv in
scan_flags n [] (succ pos);;
(*Trimmed-down version of the legacy lib's [mkprintf]. Most of the generality
is lifted to [output] rather than [mkprintf] itself.*)
let mkprintf k out fmt =
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.unsafe_get fmt i with
| '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m
| c -> write out c; doprn n (succ i)
and cont_s n s i =
nwrite out s;
doprn n i
and cont_a n printer arg i =
printer out arg;
doprn n i
and cont_t n printer i =
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
kapr kpr fmt;;
external identity : 'a -> 'a = "%identity"(*Inlined from [Std] to avoid cyclic dependencies*)
let fprintf out fmt = mkprintf ignore out fmt
let printf fmt = fprintf stdout fmt
let eprintf fmt = fprintf stderr fmt
let ifprintf _ fmt = fprintf stdnull fmt
let ksprintf2 k fmt =
let out = output_string () in
mkprintf (fun out -> k (close_out out)) out fmt
let kbprintf2 k buf fmt =
let out = BatBuffer.output_buffer buf in
mkprintf (fun _out -> k buf) out fmt
let sprintf2 fmt = ksprintf2 (identity) fmt
let bprintf2 buf fmt = kbprintf2 ignore buf fmt
(**
Other possible implementation of [sprintf2],
left as example:
[
let sprintf2 fmt =
let out = output_string () in
mkprintf (fun out -> close_out out) out fmt
]
*)
(**
Other possible implementation of [bprintf2],
left as example:
[
let bprintf2 buf fmt =
let out = output_buffer buf in
mkprintf ignore out fmt
]*)
type ('a, 'b, 'c) t = ('a, 'b, 'c) Pervasives.format
let kfprintf = mkprintf
let bprintf = Printf.bprintf
let sprintf = Printf.sprintf
let ksprintf = Printf.ksprintf
let kbprintf = Printf.kbprintf
let kprintf = Printf.kprintf