diff --git a/stdlib/format.ml b/stdlib/format.ml index f4b519c8d..2eb8f6760 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -965,15 +965,18 @@ let implode_rev s0 = function | [] -> s0 | l -> String.concat "" (List.rev (s0 :: l));; -(* [fprintf_out] is the printf-like function generator: given the +(* [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 at the end of formatting, - it generates a [fprintf] function that takes as arguments a [ppf] - formatter and a printing format to print the rest of arguments - according to the format. + - 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 [fprintf_out]. *) + applications of [mkprintf]. *) let mkprintf to_s get_out = + let rec kprintf k fmt = let len = Sformat.length fmt in diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 872fc076c..a417dc67a 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -61,7 +61,7 @@ let incomplete_format fmt = Sformat.to_string fmt ^ "''");; (* Parses a format to return the specified length and the padding direction. *) -let parse_format sfmt = +let parse_string_format sfmt = let rec parse neg i = if i >= String.length sfmt then (0, neg) else match String.unsafe_get sfmt i with @@ -89,7 +89,7 @@ let pad_string pad_char p neg s i len = (* 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_format sfmt in + let (p, neg) = parse_string_format sfmt in pad_string ' ' p neg s 0 (String.length s);; (* Extract a format string out of [fmt] between [start] and [stop] inclusive. @@ -127,7 +127,7 @@ let extract_format_int conv fmt start stop widths = let sfmt = extract_format fmt start stop widths in match conv with | 'n' | 'N' -> - sfmt. [String.length sfmt - 1] <- 'u'; + sfmt.[String.length sfmt - 1] <- 'u'; sfmt | _ -> sfmt;; @@ -181,17 +181,17 @@ let iter_on_format_args fmt add_conv add_char = | '%' | '!' -> succ i | 's' | 'S' | '[' -> add_conv skip i 's' | 'c' | 'C' -> add_conv skip i 'c' - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> add_conv skip i 'i' + | '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' | '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' | 'x' | 'X' | 'u' -> - add_char (add_conv skip i conv) 'i' - | c -> add_conv skip i 'i' end + 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 @@ -220,8 +220,8 @@ let iter_on_format_args fmt add_conv add_char = (* Returns a string that summarizes the typing information that a given format string contains. - It also checks the well-formedness of the format string. - For instance, [summarize_format_type "A number %d\n"] is "%i". *) + 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 @@ -296,14 +296,15 @@ let kapr kpr fmt = else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [];; -type param_spec = Spec_none | Spec_index of index;; +type positional_specification = + | Spec_none | Spec_index of 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 would be dependant of the {\em value} of an integer argument to printf. *) -let scan_positional_spec fmt got_pos n i = +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 = @@ -313,12 +314,12 @@ let scan_positional_spec fmt got_pos n i = | '$' -> if accu = 0 then failwith "printf: bad positional specification (0)." else - got_pos (Spec_index (index_of_litteral_position accu)) (succ j) + got_spec (Spec_index (index_of_litteral_position accu)) (succ j) (* Not a positional specification. *) - | _ -> got_pos Spec_none i in + | _ -> got_spec Spec_none i in get_int_litteral (int_of_char d - 48) (succ i) (* No positional specification. *) - | _ -> got_pos Spec_none i;; + | _ -> got_spec Spec_none i;; (* Get the position of the next argument to printf, according to the given positional specification. *) @@ -338,13 +339,15 @@ let get_index spec n = [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: string, next pos) - [cont_a] for performing a %a action (args: fn, arg, next pos) - [cont_t] for performing a %t action (args: fn, next pos) - [cont_f] for performing a flush action - [cont_m] for performing a %( action (args: sfmt, next pos) + [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 %format in [fmt]. *) + 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 @@ -354,19 +357,19 @@ 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.(int_of_index (get_index spec n)) in + let get_arg spec n = Obj.magic (args.(int_of_index (get_index spec n))) in let rec scan_positional n widths i = - let got_pos spec i = scan_flags spec n widths i in - scan_positional_spec fmt got_pos n i + let got_spec spec i = scan_flags spec n widths i in + scan_positional_spec fmt got_spec n i and scan_flags spec n widths i = match Sformat.unsafe_get fmt i with | '*' -> - let got_pos wspec i = + 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_pos n (succ i) + scan_positional_spec fmt got_spec n (succ i) | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) | _ -> scan_conv spec n widths i @@ -388,17 +391,18 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in cont_s (next_index spec n) s (succ i) - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' as conv -> + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> let (x : int) = get_arg spec 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) - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' as conv -> + | 'f' | 'e' | 'E' | 'g' | 'G' -> let (x : float) = get_arg spec n in - let s = - if conv = 'F' then string_of_float x else - format_float (extract_format fmt pos i widths) x in + let s = format_float (extract_format fmt pos i widths) x in cont_s (next_index spec 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) | 'B' | 'b' -> let (x : bool) = get_arg spec n in cont_s (next_index spec n) (string_of_bool x) (succ i) @@ -415,19 +419,20 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = cont_t (next_index spec n) printer (succ i) | 'l' | 'n' | 'L' as conv -> begin match Sformat.unsafe_get fmt (succ i) with - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> + let i = succ i in let s = match conv with | 'l' -> let (x : int32) = get_arg spec n in - format_int32 (extract_format fmt pos (succ i) widths) x + format_int32 (extract_format fmt pos i widths) x | 'n' -> let (x : nativeint) = get_arg spec n in - format_nativeint (extract_format fmt pos (succ i) widths) x + format_nativeint (extract_format fmt pos i widths) x | _ -> let (x : int64) = get_arg spec n in - format_int64 (extract_format fmt pos (succ i) widths) x in - cont_s (next_index spec n) s (i + 2) + format_int64 (extract_format fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) | _ -> let (x : int) = get_arg spec n in let s = format_int (extract_format_int 'n' fmt pos i widths) x in @@ -495,14 +500,14 @@ let mkprintf to_s get_out outc outs flush k fmt = kapr kpr fmt;; let kfprintf k oc = - mkprintf false (fun _ -> oc) output_char output_string flush k -let fprintf oc = kfprintf ignore oc -let printf fmt = fprintf stdout fmt -let eprintf fmt = fprintf stderr fmt + mkprintf false (fun _ -> oc) output_char output_string flush k;; +let fprintf oc = kfprintf ignore oc;; +let printf fmt = fprintf stdout fmt;; +let eprintf fmt = fprintf stderr fmt;; let kbprintf k b = - mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k -let bprintf b = kbprintf ignore b + mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k;; +let bprintf b = kbprintf ignore b;; let get_buff fmt = let len = 2 * Sformat.length fmt in diff --git a/stdlib/printf.mli b/stdlib/printf.mli index d612f4ad3..27921e7c5 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -123,6 +123,7 @@ val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a append the formatted arguments to the given extensible buffer (see module {!Buffer}). *) +(** Formatted output functions with continuations. *) val kfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b;; (** Same as [fprintf], but instead of returning immediately, @@ -132,6 +133,11 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) +val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> + ('b, Buffer.t, unit, 'a) format4 -> 'b;; +(** Same as [bprintf], but instead of returning immediately, + passes the buffer to its first argument at the end of printing. *) + val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** A deprecated synonym for [ksprintf]. *) diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 44d4949ce..2cb075e5a 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -133,8 +133,8 @@ let next_char ib = let c = ib.get_next_char () in ib.current_char <- c; ib.current_char_is_valid <- true; - ib.char_count <- ib.char_count + 1; - if c == '\n' then ib.line_count <- ib.line_count + 1; + ib.char_count <- succ ib.char_count; + if c == '\n' then ib.line_count <- succ ib.line_count; c with | End_of_file -> let c = null_char in @@ -173,7 +173,7 @@ let token ib = let tokbuf = ib.tokbuf in let tok = Buffer.contents tokbuf in Buffer.clear tokbuf; - ib.token_count <- ib.token_count + 1; + ib.token_count <- succ ib.token_count; tok;; let token_count ib = ib.token_count;; @@ -709,18 +709,18 @@ let read_char_set fmt i = if j > lim then incomplete_format fmt else match Sformat.get fmt j with | ']' -> j - | c -> find_in_set (j + 1) + | c -> find_in_set (succ j) and find_set i = if i > lim then incomplete_format fmt else match Sformat.get fmt i with - | ']' -> find_in_set (i + 1) + | ']' -> find_in_set (succ i) | c -> find_in_set i in if i > lim then incomplete_format fmt else match Sformat.get fmt i with | '^' -> - let i = i + 1 in + let i = succ i in let j = find_set i in j, Neg_set (Sformat.sub fmt i (j - i)) | _ -> @@ -774,15 +774,15 @@ let make_char_bit_vect bit set = (* if i = 0 then rp is false (since the initial call is loop bit false 0). Hence i >= 1 and the following is safe. *) let c1 = set.[i - 1] in - let i = i + 1 in + let i = succ i in if i > lim then loop bit false (i - 1) else let c2 = set.[i] in for j = int_of_char c1 to int_of_char c2 do set_bit_of_range r j bit done; - loop bit false (i + 1) + loop bit false (succ i) | c -> set_bit_of_range r (int_of_char set.[i]) bit; - loop bit true (i + 1) in + loop bit true (succ i) in loop bit false 0; r;; @@ -960,56 +960,58 @@ let kscanf ib ef fmt f = let rec scan_fmt f i = if i > lim then f else match Sformat.get fmt i with - | ' ' -> skip_whites ib; scan_fmt f (i + 1) + | ' ' -> skip_whites ib; scan_fmt f (succ i) | '%' -> if i > lim then incomplete_format fmt else - scan_conversion false max_int f (i + 1) + scan_conversion false max_int f (succ i) | '@' -> - let i = i + 1 in + let i = succ i in if i > lim then incomplete_format fmt else begin check_char ib (Sformat.get fmt i); - scan_fmt f (i + 1) end - | c -> check_char ib c; scan_fmt f (i + 1) + scan_fmt f (succ i) end + | c -> check_char ib c; scan_fmt f (succ i) and scan_conversion skip max f i = let stack = if skip then no_stack else stack in match Sformat.get fmt i with | '%' as conv -> - check_char ib conv; scan_fmt f (i + 1) + check_char ib conv; scan_fmt f (succ i) + | 's' -> + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_string stp max ib in + scan_fmt (stack f (token_string ib)) (succ i) + | 'S' -> + let _x = scan_String max ib in + scan_fmt (stack f (token_string ib)) (succ i) + | '[' -> + let i, char_set = read_char_set fmt (succ i) in + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_chars_in_char_set stp char_set max ib in + scan_fmt (stack f (token_string ib)) (succ i) | 'c' when max = 0 -> let c = Scanning.checked_peek_char ib in - scan_fmt (stack f c) (i + 1) + scan_fmt (stack f c) (succ i) | 'c' | 'C' as conv -> if max <> 1 && max <> max_int then bad_conversion fmt i conv else let _x = if conv = 'c' then scan_char max ib else scan_Char max ib in - scan_fmt (stack f (token_char ib)) (i + 1) + scan_fmt (stack f (token_char ib)) (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> let _x = scan_int_conv conv max ib in - scan_fmt (stack f (token_int conv ib)) (i + 1) - | 'f' | 'g' | 'G' | 'e' | 'E' -> + scan_fmt (stack f (token_int conv ib)) (succ i) + | 'N' as conv -> + scan_fmt (stack f (get_count conv ib)) (succ i) + | 'f' | 'e' | 'E' | 'g' | 'G' -> let _x = scan_float max ib in - scan_fmt (stack f (token_float ib)) (i + 1) + scan_fmt (stack f (token_float ib)) (succ i) | 'F' -> let _x = scan_Float max ib in - scan_fmt (stack f (token_float ib)) (i + 1) - | 's' -> - let i, stp = scan_fmt_stoppers (i + 1) in - let _x = scan_string stp max ib in - scan_fmt (stack f (token_string ib)) (i + 1) - | '[' -> - let i, char_set = read_char_set fmt (i + 1) in - let i, stp = scan_fmt_stoppers (i + 1) in - let _x = scan_chars_in_char_set stp char_set max ib in - scan_fmt (stack f (token_string ib)) (i + 1) - | 'S' -> - let _x = scan_String max ib in - scan_fmt (stack f (token_string ib)) (i + 1) + scan_fmt (stack f (token_float ib)) (succ i) | 'B' | 'b' -> let _x = scan_bool max ib in - scan_fmt (stack f (token_bool ib)) (i + 1) + scan_fmt (stack f (token_bool ib)) (succ i) | 'l' | 'n' | 'L' as conv -> - let i = i + 1 in + let i = succ i in if i > lim then scan_fmt (stack f (get_count conv ib)) i else begin match Sformat.get fmt i with (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) @@ -1019,38 +1021,37 @@ let kscanf ib ef fmt f = (this character is either 'l', 'n' or 'L'), to find the conversion to apply to the integer token read. *) begin match Sformat.get fmt (i - 1) with - | 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1) - | 'n' -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1) - | _ -> scan_fmt (stack f (token_int64 conv ib)) (i + 1) end + | 'l' -> scan_fmt (stack f (token_int32 conv ib)) (succ i) + | 'n' -> scan_fmt (stack f (token_nativeint conv ib)) (succ i) + | _ -> scan_fmt (stack f (token_int64 conv ib)) (succ i) end (* This is not an integer conversion, but a regular %l, %n or %L. *) | _ -> scan_fmt (stack f (get_count conv ib)) i end - | 'N' as conv -> - scan_fmt (stack f (get_count conv ib)) (i + 1) | '!' -> - if Scanning.end_of_input ib then scan_fmt f (i + 1) + if Scanning.end_of_input ib then scan_fmt f (succ i) else bad_input "end of input not found" | '_' -> if i > lim then incomplete_format fmt else - scan_conversion true max f (i + 1) + scan_conversion true max f (succ i) | '0' .. '9' as conv -> let rec read_width accu i = if i > lim then accu, i else match Sformat.get fmt i with | '0' .. '9' as c -> let accu = 10 * accu + int_value_of_char c in - read_width accu (i + 1) + read_width accu (succ i) | _ -> accu, i in - let max, i = read_width (int_value_of_char conv) (i + 1) in + let max, i = read_width (int_value_of_char conv) (succ i) in if i > lim then incomplete_format fmt else begin match Sformat.get fmt i with | '.' -> - let p, i = read_width 0 (i + 1) in - scan_conversion skip (max + p + 1) f i + let p, i = read_width 0 (succ i) in + scan_conversion skip (succ (max + p)) f i | _ -> scan_conversion skip max f i end | '(' | '{' as conv -> let i = succ i in let j = - Printf.sub_format incomplete_format bad_conversion conv fmt i + 1 in + Printf.sub_format + incomplete_format bad_conversion conv fmt (succ i) in let mf = Sformat.sub fmt i (j - i - 2) in let _x = scan_String max ib in let rf = token_string ib in @@ -1064,7 +1065,7 @@ let kscanf ib ef fmt f = and scan_fmt_stoppers i = if i > lim then i - 1, [] else match Sformat.get fmt i with - | '@' when i < lim -> let i = i + 1 in i, [Sformat.get fmt i] + | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] | '@' when i = lim -> incomplete_format fmt | _ -> i - 1, [] in