Browse files

first part of Benoît Vaugon's format-gadts patch

After applying this patch, you should run:

  make library-cross
  make promote-cross
  make partialclean
  make ocamlc ocamllex ocamltools

and then immediately apply the following patches until the "second
part of Benoît Vaugon's format+gadts patch"; the bootstrap cycle is
not finished yet.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14806 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent a64648e commit 43647ba502f32676c546ca426307b0ea6d193e3e @gasche gasche committed May 12, 2014
View
1 bytecomp/translcore.ml
@@ -901,7 +901,6 @@ and transl_exp0 e =
|| has_base_type e Predef.path_exn
|| has_base_type e Predef.path_array
|| has_base_type e Predef.path_list
- || has_base_type e Predef.path_format6
|| has_base_type e Predef.path_option
|| has_base_type e Predef.path_nativeint
|| has_base_type e Predef.path_int32
View
514 otherlibs/threads/pervasives.ml
@@ -545,6 +545,520 @@ module LargeFile =
end
(* Formats *)
+
+module CamlinternalFormatBasics = struct
+(* Type of a block used by the Format pretty-printer. *)
+type block_type =
+ | Pp_hbox (* Horizontal block no line breaking *)
+ | Pp_vbox (* Vertical block each break leads to a new line *)
+ | Pp_hvbox (* Horizontal-vertical block: same as vbox, except if this block
+ is small enough to fit on a single line *)
+ | Pp_hovbox (* Horizontal or Vertical block: breaks lead to new line
+ only when necessary to print the content of the block *)
+ | Pp_box (* Horizontal or Indent block: breaks lead to new line
+ only when necessary to print the content of the block, or
+ when it leads to a new indentation of the current line *)
+ | Pp_fits (* Internal usage: when a block fits on a single line *)
+
+(* Formatting element used by the Format pretty-printter. *)
+type formatting =
+ | Open_box of string * block_type * int (* @[ *)
+ | Close_box (* @] *)
+ | Open_tag of string * string (* @{ *)
+ | Close_tag (* @} *)
+ | Break of string * int * int (* @, | @ | @; | @;<> *)
+ | FFlush (* @? *)
+ | Force_newline (* @\n *)
+ | Flush_newline (* @. *)
+ | Magic_size of string * int (* @<n> *)
+ | Escaped_at (* @@ *)
+ | Escaped_percent (* @%% *)
+ | Scan_indic of char (* @X *)
+
+(***)
+
+(* Padding position. *)
+type padty =
+ | Left (* Text is left justified ('-' option). *)
+ | Right (* Text is right justified (no '-' option). *)
+ | Zeros (* Text is right justified by zeros (see '0' option). *)
+
+(***)
+
+(* Integer conversion. *)
+type int_conv =
+ | Int_d | Int_pd | Int_sd (* %d | %+d | % d *)
+ | Int_i | Int_pi | Int_si (* %i | %+i | % i *)
+ | Int_x | Int_Cx (* %x | %#x *)
+ | Int_X | Int_CX (* %X | %#X *)
+ | Int_o | Int_Co (* %o | %#o *)
+ | Int_u (* %u *)
+
+(* Float conversion. *)
+type float_conv =
+ | Float_f | Float_pf | Float_sf (* %f | %+f | % f *)
+ | Float_e | Float_pe | Float_se (* %e | %+e | % e *)
+ | Float_E | Float_pE | Float_sE (* %E | %+E | % E *)
+ | Float_g | Float_pg | Float_sg (* %g | %+g | % g *)
+ | Float_G | Float_pG | Float_sG (* %G | %+G | % G *)
+ | Float_F (* %F *)
+
+(***)
+
+(* Char sets (see %[...]) are bitmaps implemented as 32-char strings. *)
+type char_set = string
+
+(***)
+
+(* Counter used in Scanf. *)
+type counter =
+ | Line_counter (* %l *)
+ | Char_counter (* %n *)
+ | Token_counter (* %N, %L *)
+
+(***)
+
+(* Padding of strings and numbers. *)
+type ('a, 'b) padding =
+ (* No padding (ex: "%d") *)
+ | No_padding : ('a, 'a) padding
+ (* Literal padding (ex: "%8d") *)
+ | Lit_padding : padty * int -> ('a, 'a) padding
+ (* Padding as extra argument (ex: "%*d") *)
+ | Arg_padding : padty -> (int -> 'a, 'a) padding
+
+(* Precision of floats and '0'-padding of integers. *)
+type ('a, 'b) precision =
+ (* No precision (ex: "%f") *)
+ | No_precision : ('a, 'a) precision
+ (* Literal precision (ex: "%.3f") *)
+ | Lit_precision : int -> ('a, 'a) precision
+ (* Precision as extra argument (ex: "%.*f") *)
+ | Arg_precision : (int -> 'a, 'a) precision
+
+(***)
+
+(* Type used in Format_subst_ty and Format_subst constructors as "a proof"
+ of '->' number equality between two ('d, 'e) relations. *)
+(* See the scanf implementation of "%(...%)". *)
+(* Not meaningfull for Printf and Format since "%r" is Scanf specific. *)
+type ('d1, 'e1, 'd2, 'e2) reader_nb_unifier =
+ | Zero_reader :
+ ('d1, 'd1, 'd2, 'd2) reader_nb_unifier
+ | Succ_reader :
+ ('d1, 'e1, 'd2, 'e2) reader_nb_unifier ->
+ ('x -> 'd1, 'e1, 'x -> 'd2, 'e2) reader_nb_unifier
+
+(***)
+
+(* List of format type elements. *)
+(* In particular used to represent %(...%) and %{...%} contents. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
+ | Char_ty : (* %c *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | String_ty : (* %s *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Int_ty : (* %d *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Int32_ty : (* %ld *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (int32 -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Nativeint_ty : (* %nd *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (nativeint -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Int64_ty : (* %Ld *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (int64 -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Float_ty : (* %f *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (float -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Bool_ty : (* %B *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+
+ | Format_arg_ty : (* %{...%} *)
+ ('x, 'b, 'c, 'q, 'r, 'u) fmtty *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (('x, 'b, 'c, 'q, 'r, 'u) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Format_subst_ty : (* %(...%) *)
+ ('d1, 'q1, 'd2, 'q2) reader_nb_unifier *
+ ('x, 'b, 'c, 'd1, 'q1, 'u) fmtty *
+ ('u, 'b, 'c, 'q1, 'e1, 'f) fmtty ->
+ (('x, 'b, 'c, 'd2, 'q2, 'u) format6 -> 'x, 'b, 'c, 'd1, 'e1, 'f) fmtty
+
+ (* Printf and Format specific constructors. *)
+ | Alpha_ty : (* %a *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+ | Theta_ty : (* %t *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+
+ (* Scanf specific constructor. *)
+ | Reader_ty : (* %r *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmtty
+ | Ignored_reader_ty : (* %_r *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ ('a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmtty
+
+ | End_of_fmtty :
+ ('f, 'b, 'c, 'd, 'd, 'f) fmtty
+
+(***)
+
+(* List of format elements. *)
+and ('a, 'b, 'c, 'd, 'e, 'f) fmt =
+ | Char : (* %c *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Caml_char : (* %C *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | String : (* %s *)
+ ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Caml_string : (* %S *)
+ ('x, string -> 'a) padding * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Int : (* %[dixXuo] *)
+ int_conv * ('x, 'y) padding * ('y, int -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Int32 : (* %l[dixXuo] *)
+ int_conv * ('x, 'y) padding * ('y, int32 -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Nativeint : (* %n[dixXuo] *)
+ int_conv * ('x, 'y) padding * ('y, nativeint -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Int64 : (* %L[dixXuo] *)
+ int_conv * ('x, 'y) padding * ('y, int64 -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Float : (* %[feEgGF] *)
+ float_conv * ('x, 'y) padding * ('y, float -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x, 'b, 'c, 'd, 'e, 'f) fmt
+ | Bool : (* %[bB] *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Flush : (* %! *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+ | String_literal : (* abc *)
+ string * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Char_literal : (* x *)
+ char * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+ | Format_arg : (* %{...%} *)
+ int option * ('x, 'b, 'c, 'q, 'r, 'u) fmtty *
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (('x, 'b, 'c, 'q, 'r, 'u) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Format_subst : (* %(...%) *)
+ int option * ('d1, 'q1, 'd2, 'q2) reader_nb_unifier *
+ ('x, 'b, 'c, 'd1, 'q1, 'u) fmtty *
+ ('u, 'b, 'c, 'q1, 'e1, 'f) fmt ->
+ (('x, 'b, 'c, 'd2, 'q2, 'u) format6 -> 'x, 'b, 'c, 'd1, 'e1, 'f) fmt
+
+ (* Printf and Format specific constructor. *)
+ | Alpha : (* %a *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (('b -> 'x -> 'c) -> 'x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Theta : (* %t *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (('b -> 'c) -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+
+ (* Format specific constructor: *)
+ | Formatting : (* @_ *)
+ formatting * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+ (* Scanf specific constructors: *)
+ | Reader : (* %r *)
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('x -> 'a, 'b, 'c, ('b -> 'x) -> 'd, 'e, 'f) fmt
+ | Scan_char_set : (* %[...] *)
+ int option * char_set * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (string -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Scan_get_counter : (* %[nlNL] *)
+ counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
+ | Ignored_param : (* %_ *)
+ ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmt
+
+ | End_of_format :
+ ('f, 'b, 'c, 'e, 'e, 'f) fmt
+
+(***)
+
+(* Type for ignored parameters (see "%_"). *)
+and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
+ | Ignored_char : (* %_c *)
+ ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_caml_char : (* %_C *)
+ ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_string : (* %_s *)
+ int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_caml_string : (* %_S *)
+ int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_int : (* %_d *)
+ int_conv * int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_int32 : (* %_ld *)
+ int_conv * int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_nativeint : (* %_nd *)
+ int_conv * int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_int64 : (* %_Ld *)
+ int_conv * int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_float : (* %_f *)
+ int option * int option -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_bool : (* %_B *)
+ ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_format_arg : (* %_{...%} *)
+ int option * ('x, 'b, 'c, 'y, 'z, 't) fmtty ->
+ ('a, 'b, 'c, 'd, 'd, 'a) ignored
+ | Ignored_format_subst : (* %_(...%) *)
+ int option * ('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ ('a, 'b, 'c, 'd, 'e, 'f) ignored
+ | Ignored_reader : (* %_r *)
+ ('a, 'b, 'c, ('b -> 'x) -> 'd, 'd, 'a) ignored
+ | Ignored_scan_char_set : (* %_[...] *)
+ int option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
+
+and ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+
+(******************************************************************************)
+ (* Format type concatenation *)
+
+(* Concatenate two format types. *)
+(* Used by:
+ * reader_nb_unifier_of_fmtty to count readers in an fmtty,
+ * Scanf.take_fmtty_format_readers to extract readers inside %(...%),
+ * CamlinternalFormat.fmtty_of_ignored_format to extract format type. *)
+let rec concat_fmtty : type a b c d e f g h .
+ (a, b, c, d, e, f) fmtty ->
+ (f, b, c, e, g, h) fmtty ->
+ (a, b, c, d, g, h) fmtty =
+fun fmtty1 fmtty2 -> match fmtty1 with
+ | Char_ty rest ->
+ Char_ty (concat_fmtty rest fmtty2)
+ | String_ty rest ->
+ String_ty (concat_fmtty rest fmtty2)
+ | Int_ty rest ->
+ Int_ty (concat_fmtty rest fmtty2)
+ | Int32_ty rest ->
+ Int32_ty (concat_fmtty rest fmtty2)
+ | Nativeint_ty rest ->
+ Nativeint_ty (concat_fmtty rest fmtty2)
+ | Int64_ty rest ->
+ Int64_ty (concat_fmtty rest fmtty2)
+ | Float_ty rest ->
+ Float_ty (concat_fmtty rest fmtty2)
+ | Bool_ty rest ->
+ Bool_ty (concat_fmtty rest fmtty2)
+ | Alpha_ty rest ->
+ Alpha_ty (concat_fmtty rest fmtty2)
+ | Theta_ty rest ->
+ Theta_ty (concat_fmtty rest fmtty2)
+ | Reader_ty rest ->
+ Reader_ty (concat_fmtty rest fmtty2)
+ | Ignored_reader_ty rest ->
+ Ignored_reader_ty (concat_fmtty rest fmtty2)
+ | Format_arg_ty (ty, rest) ->
+ Format_arg_ty (ty, concat_fmtty rest fmtty2)
+ | Format_subst_ty (rnu, ty, rest) ->
+ Format_subst_ty (rnu, ty, concat_fmtty rest fmtty2)
+ | End_of_fmtty -> fmtty2
+
+(******************************************************************************)
+ (* Format concatenation *)
+
+(* Concatenate two formats. *)
+let rec concat_fmt : type a b c d e f g h .
+ (a, b, c, d, e, f) fmt ->
+ (f, b, c, e, g, h) fmt ->
+ (a, b, c, d, g, h) fmt =
+fun fmt1 fmt2 -> match fmt1 with
+ | String (pad, rest) ->
+ String (pad, concat_fmt rest fmt2)
+ | Caml_string (pad, rest) ->
+ Caml_string (pad, concat_fmt rest fmt2)
+
+ | Int (iconv, pad, prec, rest) ->
+ Int (iconv, pad, prec, concat_fmt rest fmt2)
+ | Int32 (iconv, pad, prec, rest) ->
+ Int32 (iconv, pad, prec, concat_fmt rest fmt2)
+ | Nativeint (iconv, pad, prec, rest) ->
+ Nativeint (iconv, pad, prec, concat_fmt rest fmt2)
+ | Int64 (iconv, pad, prec, rest) ->
+ Int64 (iconv, pad, prec, concat_fmt rest fmt2)
+ | Float (fconv, pad, prec, rest) ->
+ Float (fconv, pad, prec, concat_fmt rest fmt2)
+
+ | Char (rest) ->
+ Char (concat_fmt rest fmt2)
+ | Caml_char rest ->
+ Caml_char (concat_fmt rest fmt2)
+ | Bool rest ->
+ Bool (concat_fmt rest fmt2)
+ | Alpha rest ->
+ Alpha (concat_fmt rest fmt2)
+ | Theta rest ->
+ Theta (concat_fmt rest fmt2)
+ | Reader rest ->
+ Reader (concat_fmt rest fmt2)
+ | Flush rest ->
+ Flush (concat_fmt rest fmt2)
+
+ | String_literal (str, rest) ->
+ String_literal (str, concat_fmt rest fmt2)
+ | Char_literal (chr, rest) ->
+ Char_literal (chr, concat_fmt rest fmt2)
+
+ | Format_arg (pad, fmtty, rest) ->
+ Format_arg (pad, fmtty, concat_fmt rest fmt2)
+ | Format_subst (pad, rnu, fmtty, rest) ->
+ Format_subst (pad, rnu, fmtty, concat_fmt rest fmt2)
+
+ | Scan_char_set (width_opt, char_set, rest) ->
+ Scan_char_set (width_opt, char_set, concat_fmt rest fmt2)
+ | Scan_get_counter (counter, rest) ->
+ Scan_get_counter (counter, concat_fmt rest fmt2)
+ | Ignored_param (ign, rest) ->
+ Ignored_param (ign, concat_fmt rest fmt2)
+
+ | Formatting (fmting, rest) ->
+ Formatting (fmting, concat_fmt rest fmt2)
+
+ | End_of_format ->
+ fmt2
+
+(******************************************************************************)
+ (* Tools to manipulate scanning set of chars (see %[...]) *)
+
+(* Create a fresh empty char set. *)
+let create_char_set () =
+ let str = string_create 32 in
+ for i = 0 to 31 do str.[i] <- '\000' done;
+ str
+
+(* Return true if a `c' is in `char_set'. *)
+let is_in_char_set char_set c =
+ let ind = int_of_char c in
+ let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in
+ (int_of_char char_set.[str_ind] land mask) <> 0
+
+(* Add a char in a char set. *)
+let add_in_char_set char_set c =
+ let ind = int_of_char c in
+ let str_ind = ind lsr 3 and mask = 1 lsl (ind land 0b111) in
+ char_set.[str_ind] <- char_of_int (int_of_char char_set.[str_ind] lor mask)
+
+(* Compute the complement of a char set. *)
+(* Return a fresh string, do not modify its argument. *)
+let rev_char_set char_set =
+ let char_set' = create_char_set () in
+ for i = 0 to 31 do
+ char_set'.[i] <- char_of_int (int_of_char char_set.[i] lxor 0xFF);
+ done;
+ char_set'
+
+(******************************************************************************)
+ (* Reader count *)
+
+(* Count the number of "%r" (Reader_ty) and "%_r" (Ignored_reader_ty)
+ in an fmtty. *)
+let rec reader_nb_unifier_of_fmtty : type a b c d e f .
+ (a, b, c, d, e, f) fmtty -> (d, e, d, e) reader_nb_unifier =
+fun fmtty -> match fmtty with
+ | Char_ty rest -> reader_nb_unifier_of_fmtty rest
+ | String_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Int_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Int32_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Nativeint_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Int64_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Float_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Bool_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Alpha_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Theta_ty rest -> reader_nb_unifier_of_fmtty rest
+ | Reader_ty rest -> Succ_reader (reader_nb_unifier_of_fmtty rest)
+ | Ignored_reader_ty rest -> Succ_reader (reader_nb_unifier_of_fmtty rest)
+ | Format_arg_ty (_, rest) -> reader_nb_unifier_of_fmtty rest
+ | Format_subst_ty(_,sub_fmtty,rest) ->
+ reader_nb_unifier_of_fmtty (concat_fmtty sub_fmtty rest)
+ | End_of_fmtty -> Zero_reader
+
+(******************************************************************************)
+ (* Ignored param conversion *)
+
+(* GADT used to abstract an existential type parameter. *)
+(* See param_format_of_ignored_format. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb = Param_format_EBB :
+ ('x -> 'a, 'b, 'c, 'd, 'e, 'f) fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb
+
+(* Compute a padding associated to an int option (see "%_42d"). *)
+let pad_of_pad_opt pad_opt = match pad_opt with
+ | None -> No_padding
+ | Some width -> Lit_padding (Right, width)
+
+(* Compute a precision associated to an int option (see "%_.42f"). *)
+let prec_of_prec_opt prec_opt = match prec_opt with
+ | None -> No_precision
+ | Some ndec -> Lit_precision ndec
+
+(* Turn an ignored param into its equivalent not-ignored format node. *)
+(* Used for format pretty-printing and Scanf. *)
+let param_format_of_ignored_format : type a b c d e f x y .
+ (a, b, c, d, y, x) ignored -> (x, b, c, y, e, f) fmt ->
+ (a, b, c, d, e, f) param_format_ebb =
+fun ign fmt -> match ign with
+ | Ignored_char ->
+ Param_format_EBB (Char fmt)
+ | Ignored_caml_char ->
+ Param_format_EBB (Caml_char fmt)
+ | Ignored_string pad_opt ->
+ Param_format_EBB (String (pad_of_pad_opt pad_opt, fmt))
+ | Ignored_caml_string pad_opt ->
+ Param_format_EBB (Caml_string (pad_of_pad_opt pad_opt, fmt))
+ | Ignored_int (iconv, pad_opt) ->
+ Param_format_EBB (Int (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+ | Ignored_int32 (iconv, pad_opt) ->
+ Param_format_EBB
+ (Int32 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+ | Ignored_nativeint (iconv, pad_opt) ->
+ Param_format_EBB
+ (Nativeint (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+ | Ignored_int64 (iconv, pad_opt) ->
+ Param_format_EBB
+ (Int64 (iconv, pad_of_pad_opt pad_opt, No_precision, fmt))
+ | Ignored_float (pad_opt, prec_opt) ->
+ Param_format_EBB
+ (Float (Float_f, pad_of_pad_opt pad_opt, prec_of_prec_opt prec_opt, fmt))
+ | Ignored_bool ->
+ Param_format_EBB (Bool fmt)
+ | Ignored_format_arg (pad_opt, fmtty) ->
+ Param_format_EBB (Format_arg (pad_opt, fmtty, fmt))
+ | Ignored_format_subst (pad_opt, fmtty) ->
+ Param_format_EBB
+ (Format_subst (pad_opt, reader_nb_unifier_of_fmtty fmtty, fmtty, fmt))
+ | Ignored_reader ->
+ Param_format_EBB (Reader fmt)
+ | Ignored_scan_char_set (width_opt, char_set) ->
+ Param_format_EBB (Scan_char_set (width_opt, char_set, fmt))
+end
+
+(*type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6*)
+
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
View
3 stdlib/.depend
@@ -5,6 +5,7 @@ buffer.cmi :
bytes.cmi :
bytesLabels.cmi :
callback.cmi :
+camlinternalFormat.cmi :
camlinternalLazy.cmi :
camlinternalMod.cmi : obj.cmi
camlinternalOO.cmi : obj.cmi
@@ -61,6 +62,8 @@ bytesLabels.cmo : bytes.cmi bytesLabels.cmi
bytesLabels.cmx : bytes.cmx bytesLabels.cmi
callback.cmo : obj.cmi callback.cmi
callback.cmx : obj.cmx callback.cmi
+camlinternalFormat.cmo : camlinternalFormat.cmi char.cmi string.cmi
+camlinternalFormat.cmx : camlinternalFormat.cmi char.cmx string.cmx
camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi
camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi
camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \
View
4 stdlib/Compflags
@@ -18,7 +18,9 @@ case $1 in
camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';;
buffer.cmx|buffer.p.cmx) echo ' -inline 3';;
# make sure add_char is inlined (PR#5872)
- buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
+ buffer.cm[io]) echo ' -w A';;
+ camlinternalFormat.cm[io]) echo ' -w a';;
+ printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';;
scanf.cmx|scanf.p.cmx) echo ' -inline 9';;
*Labels.cm[ox]|*Labels.p.cmx) echo ' -nolabels -no-alias-deps';;
*) echo ' ';;
View
2 stdlib/Makefile.shared
@@ -28,7 +28,7 @@ OTHERS=array.cmo list.cmo char.cmo bytes.cmo string.cmo sys.cmo \
lexing.cmo parsing.cmo \
set.cmo map.cmo stack.cmo queue.cmo \
camlinternalLazy.cmo lazy.cmo stream.cmo \
- buffer.cmo printf.cmo \
+ buffer.cmo camlinternalFormat.cmo printf.cmo \
arg.cmo printexc.cmo gc.cmo \
digest.cmo random.cmo hashtbl.cmo format.cmo scanf.cmo callback.cmo \
camlinternalOO.cmo oo.cmo camlinternalMod.cmo \
View
2,021 stdlib/camlinternalFormat.ml
@@ -0,0 +1,2021 @@
+open CamlinternalFormatBasics
+
+(******************************************************************************)
+ (* Types *)
+
+(* Reversed list of printing atoms. *)
+(* Used to accumulate printf arguments. *)
+type ('b, 'c) acc =
+ | Acc_formatting of ('b, 'c) acc * formatting(* Special formatting (box) *)
+ | Acc_string of ('b, 'c) acc * string (* Literal or generated string*)
+ | Acc_char of ('b, 'c) acc * char (* Literal or generated char *)
+ | Acc_delay of ('b, 'c) acc * ('b -> 'c)(* Delayed printing (%a, %t) *)
+ | Acc_flush of ('b, 'c) acc (* Flush *)
+ | Acc_invalid_arg of ('b, 'c) acc * string (* Raise Invalid_argument msg *)
+ | End_of_acc
+
+(* List of heterogeneous values. *)
+(* Used to accumulate scanf callback arguments. *)
+type ('a, 'b) heter_list =
+ | Cons : 'c * ('a, 'b) heter_list -> ('c -> 'a, 'b) heter_list
+ | Nil : ('b, 'b) heter_list
+
+(* Existential Black Boxes. *)
+(* Used to abstract some existential type parameters. *)
+
+(* GADT type associating a padding and an fmtty. *)
+(* See the type_padding function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb = Padding_fmtty_EBB :
+ ('x, 'y) padding * ('y, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ ('x, 'b, 'c, 'd, 'e, 'f) padding_fmtty_ebb
+
+(* GADT type associating a padding, a precision and an fmtty. *)
+(* See the type_padprec function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb = Padprec_fmtty_EBB :
+ ('x, 'y) padding * ('y, 'z) precision * ('z, 'b, 'c, 'd, 'e, 'f) fmtty ->
+ ('x, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb
+
+(* GADT type associating a padding and an fmt. *)
+(* See make_padding_fmt_ebb and parse_format functions. *)
+type ('a, 'b, 'c, 'e, 'f) padding_fmt_ebb = Padding_fmt_EBB :
+ (_, 'x -> 'a) padding *
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt ->
+ ('x, 'b, 'c, 'e, 'f) padding_fmt_ebb
+
+(* GADT type associating a precision and an fmt. *)
+(* See make_precision_fmt_ebb and parse_format functions. *)
+type ('a, 'b, 'c, 'e, 'f) precision_fmt_ebb = Precision_fmt_EBB :
+ (_, 'x -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt ->
+ ('x, 'b, 'c, 'e, 'f) precision_fmt_ebb
+
+(* GADT type associating a padding, a precision and an fmt. *)
+(* See make_padprec_fmt_ebb and parse_format functions. *)
+type ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb = Padprec_fmt_EBB :
+ ('x, 'y) padding * ('y, 'p -> 'a) precision *
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt ->
+ ('p, 'b, 'c, 'e, 'f) padprec_fmt_ebb
+
+(* Abstract the 'a and 'd parameters of an fmt. *)
+(* Output type of the format parsing function. *)
+type ('b, 'c, 'e, 'f) fmt_ebb = Fmt_EBB :
+ ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt ->
+ ('b, 'c, 'e, 'f) fmt_ebb
+
+(* GADT type associating an fmtty and an fmt. *)
+(* See the type_ignored_format_substitution function. *)
+type ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb = Fmtty_fmt_EBB :
+ ('a, 'b, 'c, 'd, 'y, 'x) fmtty *
+ ('x, 'b, 'c, 'y, 'e, 'f) CamlinternalFormatBasics.fmt ->
+ ('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb
+
+(* Abstract all fmtty type parameters. *)
+(* Used to compare format types. *)
+type fmtty_ebb = Fmtty_EBB : ('a, 'b, 'c, 'd, 'e, 'f) fmtty -> fmtty_ebb
+
+(* Abstract all padding type parameters. *)
+(* Used to compare paddings. *)
+type padding_ebb = Padding_EBB : ('a, 'b) padding -> padding_ebb
+
+(* Abstract all precision type parameters. *)
+(* Used to compare precisions. *)
+type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb
+
+(******************************************************************************)
+ (* Constants *)
+
+(* Default precision for float printing. *)
+let default_float_precision = 6
+
+(******************************************************************************)
+ (* Externals *)
+
+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"
+
+(******************************************************************************)
+ (* Tools to pretty-print formats *)
+
+(* Type of extensible character buffers. *)
+type buffer = {
+ mutable ind : int;
+ mutable str : string;
+}
+
+(* Create a fresh buffer. *)
+let buffer_create init_size = { ind = 0; str = String.create init_size }
+
+(* Check size of the buffer and grow it if needed. *)
+let buffer_check_size buf overhead =
+ let len = String.length buf.str in
+ let min_len = buf.ind + overhead in
+ if min_len > len then (
+ let new_len = max (len * 2) min_len in
+ let new_str = String.create new_len in
+ String.blit buf.str 0 new_str 0 len;
+ buf.str <- new_str;
+ )
+
+(* Add the character `c' to the buffer `buf'. *)
+let buffer_add_char buf c =
+ buffer_check_size buf 1;
+ buf.str.[buf.ind] <- c;
+ buf.ind <- buf.ind + 1
+
+(* Add the string `s' to the buffer `buf'. *)
+let buffer_add_string buf s =
+ let str_len = String.length s in
+ buffer_check_size buf str_len;
+ String.blit s 0 buf.str buf.ind str_len;
+ buf.ind <- buf.ind + str_len
+
+(* Get the content of the buffer. *)
+let buffer_contents buf =
+ let str = String.create buf.ind in
+ String.blit buf.str 0 str 0 buf.ind;
+ str
+
+(***)
+
+(* Convert an integer conversion to char. *)
+let char_of_iconv iconv = match iconv with
+ | Int_d | Int_pd | Int_sd -> 'd' | Int_i | Int_pi | Int_si -> 'i'
+ | Int_x | Int_Cx -> 'x' | Int_X | Int_CX -> 'X' | Int_o | Int_Co -> 'o'
+ | Int_u -> 'u'
+
+(* Convert a float conversion to char. *)
+let char_of_fconv fconv = match fconv with
+ | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e'
+ | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g'
+ | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F'
+
+(* Convert a scanning counter to char. *)
+let char_of_counter counter = match counter with
+ | Line_counter -> 'l'
+ | Char_counter -> 'n'
+ | Token_counter -> 'N'
+
+(***)
+
+(* Print a char_set in a buffer with the OCaml format lexical convention. *)
+let bprint_char_set buf char_set =
+ let rec print_start set =
+ if is_in_char_set set ']' &&
+ (not (is_in_char_set set '\\') || not (is_in_char_set set '^'))
+ then buffer_add_char buf ']';
+ print_out set 1;
+ if is_in_char_set set '-' &&
+ (not (is_in_char_set set ',') || not (is_in_char_set set '.'))
+ then buffer_add_char buf '-';
+ and print_out set i =
+ if i < 256 then
+ if is_in_char_set set (char_of_int i) then print_first set i
+ else print_out set (i + 1)
+ and print_first set i =
+ match char_of_int i with
+ | '\255' -> print_char buf 255;
+ | ']' | '-' -> print_out set (i + 1);
+ | _ -> print_second set (i + 1);
+ and print_second set i =
+ if is_in_char_set set (char_of_int i) then
+ match char_of_int i with
+ | '\255' ->
+ print_char buf 254;
+ print_char buf 255;
+ | ']' | '-' when not (is_in_char_set set (char_of_int (i + 1))) ->
+ print_char buf (i - 1);
+ print_out set (i + 1);
+ | _ when not (is_in_char_set set (char_of_int (i + 1))) ->
+ print_char buf (i - 1);
+ print_char buf i;
+ print_out set (i + 2);
+ | _ ->
+ print_in set (i - 1) (i + 2);
+ else (
+ print_char buf (i - 1);
+ print_out set (i + 1);
+ )
+ and print_in set i j =
+ if j = 256 || not (is_in_char_set set (char_of_int j)) then (
+ print_char buf i;
+ print_char buf (int_of_char '-');
+ print_char buf (j - 1);
+ if j < 256 then print_out set (j + 1);
+ ) else
+ print_in set i (j + 1);
+ and print_char buf i = match char_of_int i with
+ | '%' -> buffer_add_char buf '%'; buffer_add_char buf '%';
+ | '@' -> buffer_add_char buf '%'; buffer_add_char buf '@';
+ | c -> buffer_add_char buf c;
+ in
+ buffer_add_char buf '[';
+ print_start (
+ if is_in_char_set char_set '\000'
+ then ( buffer_add_char buf '^'; rev_char_set char_set )
+ else char_set
+ );
+ buffer_add_char buf ']'
+
+(***)
+
+(* Print a padty in a buffer with the format-like syntax. *)
+let bprint_padty buf padty = match padty with
+ | Left -> buffer_add_char buf '-'
+ | Right -> ()
+ | Zeros -> buffer_add_char buf '0'
+
+(* Print the '_' of an ignored flag if needed. *)
+let bprint_ignored_flag buf ign_flag =
+ if ign_flag then buffer_add_char buf '_'
+
+(***)
+
+let bprint_pad_opt buf pad_opt = match pad_opt with
+ | None -> ()
+ | Some width -> buffer_add_string buf (string_of_int width)
+
+(***)
+
+(* Print padding in a buffer with the format-like syntax. *)
+let bprint_padding : type a b . buffer -> (a, b) padding -> unit =
+fun buf pad -> match pad with
+ | No_padding -> ()
+ | Lit_padding (padty, n) ->
+ bprint_padty buf padty;
+ buffer_add_string buf (string_of_int n);
+ | Arg_padding padty ->
+ bprint_padty buf padty;
+ buffer_add_char buf '*'
+
+(* Print precision in a buffer with the format-like syntax. *)
+let bprint_precision : type a b . buffer -> (a, b) precision -> unit =
+ fun buf prec -> match prec with
+ | No_precision -> ()
+ | Lit_precision n ->
+ buffer_add_char buf '.';
+ buffer_add_string buf (string_of_int n);
+ | Arg_precision ->
+ buffer_add_string buf ".*"
+
+(***)
+
+(* Print the optionnal '+', ' ' or '#' associated to an int conversion. *)
+let bprint_iconv_flag buf iconv = match iconv with
+ | Int_pd | Int_pi -> buffer_add_char buf '+'
+ | Int_sd | Int_si -> buffer_add_char buf ' '
+ | Int_Cx | Int_CX | Int_Co -> buffer_add_char buf '#'
+ | Int_d | Int_i | Int_x | Int_X | Int_o | Int_u -> ()
+
+(* Print an complete int format in a buffer (ex: "%3.*d"). *)
+let bprint_int_fmt buf ign_flag iconv pad prec =
+ buffer_add_char buf '%';
+ bprint_ignored_flag buf ign_flag;
+ bprint_iconv_flag buf iconv;
+ bprint_padding buf pad;
+ bprint_precision buf prec;
+ buffer_add_char buf (char_of_iconv iconv)
+
+(* Print a complete int32, nativeint or int64 format in a buffer. *)
+let bprint_altint_fmt buf ign_flag iconv pad prec c =
+ buffer_add_char buf '%';
+ bprint_ignored_flag buf ign_flag;
+ bprint_iconv_flag buf iconv;
+ bprint_padding buf pad;
+ bprint_precision buf prec;
+ buffer_add_char buf c;
+ buffer_add_char buf (char_of_iconv iconv)
+
+(***)
+
+(* Print the optionnal '+' associated to a float conversion. *)
+let bprint_fconv_flag buf fconv = match fconv with
+ | Float_pf | Float_pe | Float_pE | Float_pg | Float_pG ->
+ buffer_add_char buf '+'
+ | Float_sf | Float_se | Float_sE | Float_sg | Float_sG ->
+ buffer_add_char buf ' '
+ | Float_f | Float_e | Float_E | Float_g | Float_G | Float_F ->
+ ()
+
+(* Print a complete float format in a buffer (ex: "%+*.3f"). *)
+let bprint_float_fmt buf ign_flag fconv pad prec =
+ buffer_add_char buf '%';
+ bprint_ignored_flag buf ign_flag;
+ bprint_fconv_flag buf fconv;
+ bprint_padding buf pad;
+ bprint_precision buf prec;
+ buffer_add_char buf (char_of_fconv fconv)
+
+(* Compute the literal string representation of a formatting. *)
+(* Also used by Printf and Scanf where formatting is not interpreted. *)
+let string_of_formatting formatting = match formatting with
+ | Open_box (str, _, _) -> str
+ | Close_box -> "@]"
+ | Open_tag (str, _) -> str
+ | Close_tag -> "@}"
+ | Break (str, _, _) -> str
+ | FFlush -> "@?"
+ | Force_newline -> "@\n"
+ | Flush_newline -> "@."
+ | Magic_size (str, _) -> str
+ | Escaped_at -> "@@"
+ | Escaped_percent -> "@%"
+ | Scan_indic c ->
+ let str = String.create 2 in
+ str.[0] <- '@'; str.[1] <- c;
+ str
+
+(***)
+
+(* Print a literal char in a buffer, escape '%' by "%%". *)
+let bprint_char_literal buf chr = match chr with
+ | '%' -> buffer_add_string buf "%%"
+ | _ -> buffer_add_char buf chr
+
+(* Print a literal string in a buffer, escape all '%' by "%%". *)
+let bprint_string_literal buf str =
+ for i = 0 to String.length str - 1 do
+ bprint_char_literal buf str.[i]
+ done
+
+(******************************************************************************)
+ (* Format pretty-printing *)
+
+(* Print a complete format type (an fmtty) in a buffer. *)
+let rec bprint_fmtty : type a b c d e f .
+ buffer -> (a, b, c, d, e, f) fmtty -> unit =
+fun buf fmtty -> match fmtty with
+ | Char_ty rest -> buffer_add_string buf "%c"; bprint_fmtty buf rest;
+ | String_ty rest -> buffer_add_string buf "%s"; bprint_fmtty buf rest;
+ | Int_ty rest -> buffer_add_string buf "%i"; bprint_fmtty buf rest;
+ | Int32_ty rest -> buffer_add_string buf "%li"; bprint_fmtty buf rest;
+ | Nativeint_ty rest -> buffer_add_string buf "%ni"; bprint_fmtty buf rest;
+ | Int64_ty rest -> buffer_add_string buf "%Li"; bprint_fmtty buf rest;
+ | Float_ty rest -> buffer_add_string buf "%f"; bprint_fmtty buf rest;
+ | Bool_ty rest -> buffer_add_string buf "%B"; bprint_fmtty buf rest;
+ | Alpha_ty rest -> buffer_add_string buf "%a"; bprint_fmtty buf rest;
+ | Theta_ty rest -> buffer_add_string buf "%t"; bprint_fmtty buf rest;
+ | Reader_ty rest -> buffer_add_string buf "%r"; bprint_fmtty buf rest;
+
+ | Ignored_reader_ty rest ->
+ buffer_add_string buf "%_r";
+ bprint_fmtty buf rest;
+
+ | Format_arg_ty (sub_fmtty, rest) ->
+ buffer_add_string buf "%{"; bprint_fmtty buf sub_fmtty;
+ buffer_add_string buf "%}"; bprint_fmtty buf rest;
+ | Format_subst_ty (_, sub_fmtty, rest) ->
+ buffer_add_string buf "%("; bprint_fmtty buf sub_fmtty;
+ buffer_add_string buf "%)"; bprint_fmtty buf rest;
+
+ | End_of_fmtty -> ()
+
+(***)
+
+(* Print a complete format in a buffer. *)
+let bprint_fmt buf fmt =
+ let rec fmtiter : type a b c d e f .
+ (a, b, c, d, e, f) fmt -> bool -> unit =
+ fun fmt ign_flag -> match fmt with
+ | String (pad, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ bprint_padding buf pad; buffer_add_char buf 's';
+ fmtiter rest false;
+ | Caml_string (pad, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ bprint_padding buf pad; buffer_add_char buf 'S';
+ fmtiter rest false;
+
+ | Int (iconv, pad, prec, rest) ->
+ bprint_int_fmt buf ign_flag iconv pad prec;
+ fmtiter rest false;
+ | Int32 (iconv, pad, prec, rest) ->
+ bprint_altint_fmt buf ign_flag iconv pad prec 'l';
+ fmtiter rest false;
+ | Nativeint (iconv, pad, prec, rest) ->
+ bprint_altint_fmt buf ign_flag iconv pad prec 'n';
+ fmtiter rest false;
+ | Int64 (iconv, pad, prec, rest) ->
+ bprint_altint_fmt buf ign_flag iconv pad prec 'L';
+ fmtiter rest false;
+ | Float (fconv, pad, prec, rest) ->
+ bprint_float_fmt buf ign_flag fconv pad prec;
+ fmtiter rest false;
+
+ | Char rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 'c'; fmtiter rest false;
+ | Caml_char rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 'C'; fmtiter rest false;
+ | Bool rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 'B'; fmtiter rest false;
+ | Alpha rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 'a'; fmtiter rest false;
+ | Theta rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 't'; fmtiter rest false;
+ | Reader rest ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf 'r'; fmtiter rest false;
+ | Flush rest ->
+ buffer_add_string buf "%!";
+ fmtiter rest ign_flag;
+
+ | String_literal (str, rest) ->
+ bprint_string_literal buf str;
+ fmtiter rest ign_flag;
+ | Char_literal (chr, rest) ->
+ bprint_char_literal buf chr;
+ fmtiter rest ign_flag;
+
+ | Format_arg (pad_opt, fmtty, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ bprint_pad_opt buf pad_opt; buffer_add_char buf '{';
+ bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf '}';
+ fmtiter rest false;
+ | Format_subst (pad_opt, _, fmtty, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ bprint_pad_opt buf pad_opt; buffer_add_char buf '(';
+ bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf ')';
+ fmtiter rest false;
+
+ | Scan_char_set (width_opt, char_set, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ bprint_pad_opt buf width_opt; bprint_char_set buf char_set;
+ fmtiter rest false;
+ | Scan_get_counter (counter, rest) ->
+ buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag;
+ buffer_add_char buf (char_of_counter counter);
+ fmtiter rest false;
+ | Ignored_param (ign, rest) ->
+ let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
+ fmtiter fmt' true;
+
+ | Formatting (fmting, rest) ->
+ bprint_string_literal buf (string_of_formatting fmting);
+ fmtiter rest ign_flag;
+
+ | End_of_format -> ()
+
+ in fmtiter fmt false
+
+(***)
+
+(* Convert a format to string. *)
+let string_of_fmt fmt =
+ let buf = buffer_create 16 in
+ bprint_fmt buf fmt;
+ buffer_contents buf
+
+(******************************************************************************)
+ (* Type extraction *)
+
+(* Extract the type representation (an fmtty) of a format. *)
+let rec fmtty_of_fmt : type a b c d e f .
+ (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> (a, b, c, d, e, f) fmtty =
+fun fmtty -> match fmtty with
+ | String (pad, rest) ->
+ fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest))
+ | Caml_string (pad, rest) ->
+ fmtty_of_padding_fmtty pad (String_ty (fmtty_of_fmt rest))
+
+ | Int (_, pad, prec, rest) ->
+ let ty_rest = fmtty_of_fmt rest in
+ let prec_ty = fmtty_of_precision_fmtty prec (Int_ty ty_rest) in
+ fmtty_of_padding_fmtty pad prec_ty
+ | Int32 (_, pad, prec, rest) ->
+ let ty_rest = fmtty_of_fmt rest in
+ let prec_ty = fmtty_of_precision_fmtty prec (Int32_ty ty_rest) in
+ fmtty_of_padding_fmtty pad prec_ty
+ | Nativeint (_, pad, prec, rest) ->
+ let ty_rest = fmtty_of_fmt rest in
+ let prec_ty = fmtty_of_precision_fmtty prec (Nativeint_ty ty_rest) in
+ fmtty_of_padding_fmtty pad prec_ty
+ | Int64 (_, pad, prec, rest) ->
+ let ty_rest = fmtty_of_fmt rest in
+ let prec_ty = fmtty_of_precision_fmtty prec (Int64_ty ty_rest) in
+ fmtty_of_padding_fmtty pad prec_ty
+ | Float (_, pad, prec, rest) ->
+ let ty_rest = fmtty_of_fmt rest in
+ let prec_ty = fmtty_of_precision_fmtty prec (Float_ty ty_rest) in
+ fmtty_of_padding_fmtty pad prec_ty
+
+ | Char rest -> Char_ty (fmtty_of_fmt rest)
+ | Caml_char rest -> Char_ty (fmtty_of_fmt rest)
+ | Bool rest -> Bool_ty (fmtty_of_fmt rest)
+ | Alpha rest -> Alpha_ty (fmtty_of_fmt rest)
+ | Theta rest -> Theta_ty (fmtty_of_fmt rest)
+ | Reader rest -> Reader_ty (fmtty_of_fmt rest)
+
+ | Format_arg (_, ty, rest) ->
+ Format_arg_ty (ty, fmtty_of_fmt rest)
+ | Format_subst (_, rnu, ty, rest) ->
+ Format_subst_ty (rnu, ty, fmtty_of_fmt rest)
+
+ | Flush rest -> fmtty_of_fmt rest
+ | String_literal (_, rest) -> fmtty_of_fmt rest
+ | Char_literal (_, rest) -> fmtty_of_fmt rest
+
+ | Scan_char_set (_, _, rest) -> String_ty (fmtty_of_fmt rest)
+ | Scan_get_counter (_, rest) -> Int_ty (fmtty_of_fmt rest)
+ | Ignored_param (ign, rest) -> fmtty_of_ignored_format ign rest
+ | Formatting (_, rest) -> fmtty_of_fmt rest
+
+ | End_of_format -> End_of_fmtty
+
+(* Extract the fmtty of an ignored parameter followed by the rest of
+ the format. *)
+and fmtty_of_ignored_format : type x y a b c d e f .
+ (a, b, c, d, y, x) ignored ->
+ (x, b, c, y, e, f) CamlinternalFormatBasics.fmt ->
+ (a, b, c, d, e, f) fmtty =
+fun ign fmt -> match ign with
+ | Ignored_char -> fmtty_of_fmt fmt
+ | Ignored_caml_char -> fmtty_of_fmt fmt
+ | Ignored_string _ -> fmtty_of_fmt fmt
+ | Ignored_caml_string _ -> fmtty_of_fmt fmt
+ | Ignored_int (_, _) -> fmtty_of_fmt fmt
+ | Ignored_int32 (_, _) -> fmtty_of_fmt fmt
+ | Ignored_nativeint (_, _) -> fmtty_of_fmt fmt
+ | Ignored_int64 (_, _) -> fmtty_of_fmt fmt
+ | Ignored_float (_, _) -> fmtty_of_fmt fmt
+ | Ignored_bool -> fmtty_of_fmt fmt
+ | Ignored_format_arg _ -> fmtty_of_fmt fmt
+ | Ignored_format_subst (_, fmtty) -> concat_fmtty fmtty (fmtty_of_fmt fmt)
+ | Ignored_reader -> Ignored_reader_ty (fmtty_of_fmt fmt)
+ | Ignored_scan_char_set _ -> fmtty_of_fmt fmt
+
+(* Add an Int_ty node if padding is taken as an extra argument (ex: "%*s"). *)
+and fmtty_of_padding_fmtty : type x a b c d e f .
+ (x, a) padding -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty =
+ fun pad fmtty -> match pad with
+ | No_padding -> fmtty
+ | Lit_padding _ -> fmtty
+ | Arg_padding _ -> Int_ty fmtty
+
+(* Add an Int_ty node if precision is taken as an extra argument (ex: "%.*f").*)
+and fmtty_of_precision_fmtty : type x a b c d e f .
+ (x, a) precision -> (a, b, c, d, e, f) fmtty -> (x, b, c, d, e, f) fmtty =
+ fun prec fmtty -> match prec with
+ | No_precision -> fmtty
+ | Lit_precision _ -> fmtty
+ | Arg_precision -> Int_ty fmtty
+
+(******************************************************************************)
+ (* Format typing *)
+
+(* Exception raised by type_XXX when a typing error occurs. *)
+exception Type_mismatch
+
+(* Type a padding. *)
+(* Take an Int_ty from the fmtty if the integer should be kept as argument. *)
+(* Raise Type_mismatch in case of type mismatch. *)
+let type_padding : type a b c d e f x y .
+ (x, y) padding -> (a, b, c, d, e, f) fmtty ->
+ (a, b, c, d, e, f) padding_fmtty_ebb =
+fun pad fmtty -> match pad, fmtty with
+ | No_padding, _ -> Padding_fmtty_EBB (No_padding, fmtty)
+ | Lit_padding (padty, w), _ -> Padding_fmtty_EBB (Lit_padding (padty,w),fmtty)
+ | Arg_padding padty, Int_ty rest -> Padding_fmtty_EBB (Arg_padding padty,rest)
+ | _ -> raise Type_mismatch
+
+(* Convert a (upadding, uprecision) to a (padding, precision). *)
+(* Take one or two Int_ty from the fmtty if needed. *)
+(* Raise Type_mismatch in case of type mismatch. *)
+let type_padprec : type a b c d e f x y z .
+ (x, y) padding -> (y, z) precision -> (a, b, c, d, e, f) fmtty ->
+ (a, b, c, d, e, f) padprec_fmtty_ebb =
+fun pad prec fmtty -> match prec, type_padding pad fmtty with
+ | No_precision, Padding_fmtty_EBB (pad, rest) ->
+ Padprec_fmtty_EBB (pad, No_precision, rest)
+ | Lit_precision p, Padding_fmtty_EBB (pad, rest) ->
+ Padprec_fmtty_EBB (pad, Lit_precision p, rest)
+ | Arg_precision, Padding_fmtty_EBB (pad, Int_ty rest) ->
+ Padprec_fmtty_EBB (pad, Arg_precision, rest)
+ | _, Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+
+(* Type a format according to an fmtty. *)
+(* If typing succeed, generate a copy of the format with the same
+ type parameters as the fmtty. *)
+(* Raise a Failure with an error message in case of type mismatch. *)
+let rec type_format : type x t u v a b c d e f .
+ (x, b, c, t, u, v) CamlinternalFormatBasics.fmt ->
+ (a, b, c, d, e, f) fmtty ->
+ (a, b, c, d, e, f) CamlinternalFormatBasics.fmt =
+fun fmt fmtty -> match fmt, fmtty with
+ | Char fmt_rest, Char_ty fmtty_rest ->
+ Char (type_format fmt_rest fmtty_rest)
+ | Caml_char fmt_rest, Char_ty fmtty_rest ->
+ Caml_char (type_format fmt_rest fmtty_rest)
+ | String (pad, fmt_rest), _ -> (
+ match type_padding pad fmtty with
+ | Padding_fmtty_EBB (pad, String_ty fmtty_rest) ->
+ String (pad, type_format fmt_rest fmtty_rest)
+ | Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+ )
+ | Caml_string (pad, fmt_rest), _ -> (
+ match type_padding pad fmtty with
+ | Padding_fmtty_EBB (pad, String_ty fmtty_rest) ->
+ Caml_string (pad, type_format fmt_rest fmtty_rest)
+ | Padding_fmtty_EBB (_, _) -> raise Type_mismatch
+ )
+ | Int (iconv, pad, prec, fmt_rest), _ -> (
+ match type_padprec pad prec fmtty with
+ | Padprec_fmtty_EBB (pad, prec, Int_ty fmtty_rest) ->
+ Int (iconv, pad, prec, type_format fmt_rest fmtty_rest)
+ | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+ )
+ | Int32 (iconv, pad, prec, fmt_rest), _ -> (
+ match type_padprec pad prec fmtty with
+ | Padprec_fmtty_EBB (pad, prec, Int32_ty fmtty_rest) ->
+ Int32 (iconv, pad, prec, type_format fmt_rest fmtty_rest)
+ | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+ )
+ | Nativeint (iconv, pad, prec, fmt_rest), _ -> (
+ match type_padprec pad prec fmtty with
+ | Padprec_fmtty_EBB (pad, prec, Nativeint_ty fmtty_rest) ->
+ Nativeint (iconv, pad, prec, type_format fmt_rest fmtty_rest)
+ | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+ )
+ | Int64 (iconv, pad, prec, fmt_rest), _ -> (
+ match type_padprec pad prec fmtty with
+ | Padprec_fmtty_EBB (pad, prec, Int64_ty fmtty_rest) ->
+ Int64 (iconv, pad, prec, type_format fmt_rest fmtty_rest)
+ | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+ )
+ | Float (fconv, pad, prec, fmt_rest), _ -> (
+ match type_padprec pad prec fmtty with
+ | Padprec_fmtty_EBB (pad, prec, Float_ty fmtty_rest) ->
+ Float (fconv, pad, prec, type_format fmt_rest fmtty_rest)
+ | Padprec_fmtty_EBB (_, _, _) -> raise Type_mismatch
+ )
+ | Bool fmt_rest, Bool_ty fmtty_rest ->
+ Bool (type_format fmt_rest fmtty_rest)
+ | Flush fmt_rest, _ ->
+ Flush (type_format fmt_rest fmtty)
+
+ | String_literal (str, fmt_rest), _ ->
+ String_literal (str, type_format fmt_rest fmtty)
+ | Char_literal (chr, fmt_rest), _ ->
+ Char_literal (chr, type_format fmt_rest fmtty)
+
+ | Format_arg (pad_opt, sub_fmtty, fmt_rest),
+ Format_arg_ty (sub_fmtty', fmtty_rest) ->
+ if Fmtty_EBB sub_fmtty <> Fmtty_EBB sub_fmtty' then raise Type_mismatch;
+ Format_arg (pad_opt, sub_fmtty', type_format fmt_rest fmtty_rest)
+ | Format_subst (pad_opt, _, sub_fmtty, fmt_rest),
+ Format_subst_ty (rnu', sub_fmtty', fmtty_rest) ->
+ if Fmtty_EBB sub_fmtty <> Fmtty_EBB sub_fmtty' then raise Type_mismatch;
+ Format_subst (pad_opt, rnu', sub_fmtty', type_format fmt_rest fmtty_rest)
+
+ (* Printf and Format specific constructors: *)
+ | Alpha fmt_rest, Alpha_ty fmtty_rest ->
+ Alpha (type_format fmt_rest fmtty_rest)
+ | Theta fmt_rest, Theta_ty fmtty_rest ->
+ Theta (type_format fmt_rest fmtty_rest)
+
+ (* Format specific constructors: *)
+ | Formatting (formatting, fmt_rest), _ ->
+ Formatting (formatting, type_format fmt_rest fmtty)
+
+ (* Scanf specific constructors: *)
+ | Reader fmt_rest, Reader_ty fmtty_rest ->
+ Reader (type_format fmt_rest fmtty_rest)
+ | Scan_char_set (width_opt, char_set, fmt_rest), String_ty fmtty_rest ->
+ Scan_char_set
+ (width_opt, char_set, type_format fmt_rest fmtty_rest)
+ | Scan_get_counter (counter, fmt_rest), Int_ty fmtty_rest ->
+ Scan_get_counter (counter, type_format fmt_rest fmtty_rest)
+ | Ignored_param (ign, rest), _ ->
+ type_ignored_param ign rest fmtty
+
+ | End_of_format, End_of_fmtty -> End_of_format
+
+ | _ -> raise Type_mismatch
+
+(* Type and Ignored_param node according to an fmtty. *)
+and type_ignored_param : type p q x t u v a b c d e f .
+ (x, b, c, t, q, p) ignored ->
+ (p, b, c, q, u, v) CamlinternalFormatBasics.fmt ->
+ (a, b, c, d, e, f) fmtty ->
+ (a, b, c, d, e, f) CamlinternalFormatBasics.fmt =
+fun ign fmt fmtty -> match ign with
+ | Ignored_char as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_caml_char as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_string _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_caml_string _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_int _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_int32 _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_nativeint _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_int64 _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_float _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_bool as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_scan_char_set _ as ign'-> Ignored_param (ign',type_format fmt fmtty)
+ | Ignored_format_arg (pad_opt, sub_fmtty) ->
+ let ignored = Ignored_format_arg (pad_opt, sub_fmtty) in
+ Ignored_param (ignored, type_format fmt fmtty)
+ | Ignored_format_subst (pad_opt, sub_fmtty) ->
+ let Fmtty_fmt_EBB (sub_fmtty', fmt') =
+ type_ignored_format_substitution sub_fmtty fmt fmtty in
+ Ignored_param (Ignored_format_subst (pad_opt, sub_fmtty'), fmt')
+ | Ignored_reader ->
+ match fmtty with
+ | Ignored_reader_ty fmtty_rest ->
+ Ignored_param (Ignored_reader, type_format fmt fmtty_rest)
+ | _ -> raise Type_mismatch
+
+(* Typing of the complex case: "%_(...%)". *)
+and type_ignored_format_substitution : type w z p s t u a b c d e f .
+ (w, b, c, z, s, p) fmtty ->
+ (p, b, c, s, t, u) CamlinternalFormatBasics.fmt ->
+ (a, b, c, d, e, f) fmtty -> (a, b, c, d, e, f) fmtty_fmt_ebb =
+fun sub_fmtty fmt fmtty -> match sub_fmtty, fmtty with
+ | Char_ty sub_fmtty_rest, Char_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Char_ty sub_fmtty_rest', fmt')
+ | String_ty sub_fmtty_rest, String_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (String_ty sub_fmtty_rest', fmt')
+ | Int_ty sub_fmtty_rest, Int_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Int_ty sub_fmtty_rest', fmt')
+ | Int32_ty sub_fmtty_rest, Int32_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Int32_ty sub_fmtty_rest', fmt')
+ | Nativeint_ty sub_fmtty_rest, Nativeint_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Nativeint_ty sub_fmtty_rest', fmt')
+ | Int64_ty sub_fmtty_rest, Int64_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Int64_ty sub_fmtty_rest', fmt')
+ | Float_ty sub_fmtty_rest, Float_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Float_ty sub_fmtty_rest', fmt')
+ | Bool_ty sub_fmtty_rest, Bool_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Bool_ty sub_fmtty_rest', fmt')
+ | Alpha_ty sub_fmtty_rest, Alpha_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Alpha_ty sub_fmtty_rest', fmt')
+ | Theta_ty sub_fmtty_rest, Theta_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Theta_ty sub_fmtty_rest', fmt')
+ | Reader_ty sub_fmtty_rest, Reader_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Reader_ty sub_fmtty_rest', fmt')
+ | Ignored_reader_ty sub_fmtty_rest, Ignored_reader_ty fmtty_rest ->
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Ignored_reader_ty sub_fmtty_rest', fmt')
+
+ | Format_arg_ty (sub2_fmtty, sub_fmtty_rest),
+ Format_arg_ty (sub2_fmtty', fmtty_rest) ->
+ if Fmtty_EBB sub2_fmtty <> Fmtty_EBB sub2_fmtty' then raise Type_mismatch;
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Format_arg_ty (sub2_fmtty', sub_fmtty_rest'), fmt')
+ | Format_subst_ty (_, sub2_fmtty, sub_fmtty_rest),
+ Format_subst_ty (rnu', sub2_fmtty', fmtty_rest) ->
+ if Fmtty_EBB sub2_fmtty <> Fmtty_EBB sub2_fmtty' then raise Type_mismatch;
+ let Fmtty_fmt_EBB (sub_fmtty_rest', fmt') =
+ type_ignored_format_substitution sub_fmtty_rest fmt fmtty_rest in
+ Fmtty_fmt_EBB (Format_subst_ty (rnu', sub2_fmtty', sub_fmtty_rest'),fmt')
+
+ | End_of_fmtty, fmtty ->
+ Fmtty_fmt_EBB (End_of_fmtty, type_format fmt fmtty)
+
+ | _ -> raise Type_mismatch
+
+(******************************************************************************)
+ (* Printing tools *)
+
+(* Add padding spaces arround a string. *)
+let fix_padding padty width str =
+ let len = String.length str in
+ if width <= len then str else
+ let res = String.make width (if padty = Zeros then '0' else ' ') in
+ begin match padty with
+ | Left -> String.blit str 0 res 0 len
+ | Right -> String.blit str 0 res (width - len) len
+ | Zeros when len > 0 && (str.[0] = '+' || str.[0] = '-') ->
+ res.[0] <- str.[0];
+ String.blit str 1 res (width - len + 1) (len - 1)
+ | Zeros when len > 1 && str.[0] = '0' && (str.[1] = 'x' || str.[1] = 'X') ->
+ res.[1] <- str.[1];
+ String.blit str 2 res (width - len + 2) (len - 2)
+ | Zeros ->
+ String.blit str 0 res (width - len) len
+ end;
+ res
+
+(* Add '0' padding to int, int32, nativeint or int64 string representation. *)
+let fix_int_precision prec str =
+ let len = String.length str in
+ if prec <= len then str else
+ let res = String.make prec '0' in
+ begin match str.[0] with
+ | ('+' | '-' | ' ') as c ->
+ res.[0] <- c;
+ String.blit str 1 res (prec - len + 1) (len - 1);
+ | '0' when len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
+ res.[1] <- str.[1];
+ String.blit str 2 res (prec - len + 2) (len - 2);
+ | '0' .. '9' ->
+ String.blit str 0 res (prec - len) len;
+ | _ ->
+ assert false
+ end;
+ res
+
+(* Escape a string according to the OCaml lexing convention. *)
+let string_to_caml_string str =
+ let esc = String.escaped str in
+ let len = String.length esc in
+ let res = String.create (len + 2) in
+ res.[0] <- '"'; String.blit esc 0 res 1 len; res.[len + 1] <- '"';
+ res
+
+(* Generate the format_int first argument from an int_conv. *)
+let format_of_iconv iconv = match iconv with
+ | Int_d -> "%d" | Int_pd -> "%+d" | Int_sd -> "% d"
+ | Int_i -> "%i" | Int_pi -> "%+i" | Int_si -> "% i"
+ | Int_x -> "%x" | Int_Cx -> "%#x"
+ | Int_X -> "%X" | Int_CX -> "%#X"
+ | Int_o -> "%o" | Int_Co -> "%#o"
+ | Int_u -> "%u"
+
+(* Generate the format_int32, format_nativeint and format_int64 first argument
+ from an int_conv. *)
+let format_of_aconv iconv c =
+ let fix i fmt = fmt.[i] <- c; fmt in
+ match iconv with
+ | Int_d -> fix 1 "% d" | Int_pd -> fix 2 "%+ d" | Int_sd -> fix 2 "% d"
+ | Int_i -> fix 1 "% i" | Int_pi -> fix 2 "%+ i" | Int_si -> fix 2 "% i"
+ | Int_x -> fix 1 "% x" | Int_Cx -> fix 2 "%# x"
+ | Int_X -> fix 1 "% X" | Int_CX -> fix 2 "%# X"
+ | Int_o -> fix 1 "% o" | Int_Co -> fix 2 "%# o"
+ | Int_u -> fix 1 "% u"
+
+(* Generate the format_float first argument form a float_conv. *)
+let format_of_fconv fconv prec =
+ let symb = if fconv = Float_F then 'g' else char_of_fconv fconv in
+ let buf = buffer_create 16 in
+ buffer_add_char buf '%';
+ bprint_fconv_flag buf fconv;
+ buffer_add_char buf '.';
+ buffer_add_string buf (string_of_int prec);
+ buffer_add_char buf symb;
+ buffer_contents buf
+
+(* Convert an integer to a string according to a conversion. *)
+let convert_int iconv n = format_int (format_of_iconv iconv) n
+let convert_int32 iconv n = format_int32 (format_of_aconv iconv 'l') n
+let convert_nativeint iconv n = format_nativeint (format_of_aconv iconv 'n') n
+let convert_int64 iconv n = format_int64 (format_of_aconv iconv 'L') n
+
+(* Convert a float to string. *)
+(* Fix special case of "OCaml float format". *)
+let convert_float fconv prec x =
+ let str = format_float (format_of_fconv fconv prec) x in
+ if fconv <> Float_F then str else
+ let len = String.length str in
+ let rec is_valid i =
+ if i = len then false else
+ match str.[i] with
+ | '.' | 'e' | 'E' -> true
+ | _ -> is_valid (i + 1)
+ in
+ match classify_float x with
+ | FP_normal | FP_subnormal | FP_zero when not (is_valid 0) -> str ^ "."
+ | FP_infinite | FP_nan | FP_normal | FP_subnormal | FP_zero -> str
+
+(* Convert a char to a string according to the OCaml lexical convention. *)
+let format_caml_char c =
+ let esc = Char.escaped c in
+ let len = String.length esc in
+ let res = String.create (len + 2) in
+ res.[0] <- '\''; String.blit esc 0 res 1 len; res.[len+1] <- '\'';
+ res
+
+(* Convert a format type to string *)
+let string_of_fmtty fmtty =
+ let buf = buffer_create 16 in
+ bprint_fmtty buf fmtty;
+ buffer_contents buf
+
+(******************************************************************************)
+ (* Generic printing function *)
+
+(* Make a generic printing function. *)
+(* Used to generate Printf and Format printing functions. *)
+(* Parameters:
+ k: a continuation finally applied to the output stream and the accumulator.
+ o: the output stream (see k, %a and %t).
+ acc: rev list of printing entities (string, char, flush, formatting, ...).
+ fmt: the format. *)
+let rec make_printf : type a b c d .
+ (b -> (b, c) acc -> d) -> b -> (b, c) acc ->
+ (a, b, c, c, c, d) CamlinternalFormatBasics.fmt -> a =
+fun k o acc fmt -> match fmt with
+ | Char rest ->
+ fun c ->
+ let new_acc = Acc_char (acc, c) in
+ make_printf k o new_acc rest
+ | Caml_char rest ->
+ fun c ->
+ let new_acc = Acc_string (acc, format_caml_char c) in
+ make_printf k o new_acc rest
+ | String (pad, rest) ->
+ make_string_padding k o acc rest pad (fun str -> str)
+ | Caml_string (pad, rest) ->
+ make_string_padding k o acc rest pad string_to_caml_string
+ | Int (iconv, pad, prec, rest) ->
+ make_int_padding_precision k o acc rest pad prec convert_int iconv
+ | Int32 (iconv, pad, prec, rest) ->
+ make_int_padding_precision k o acc rest pad prec convert_int32 iconv
+ | Nativeint (iconv, pad, prec, rest) ->
+ make_int_padding_precision k o acc rest pad prec convert_nativeint iconv
+ | Int64 (iconv, pad, prec, rest) ->
+ make_int_padding_precision k o acc rest pad prec convert_int64 iconv
+ | Float (fconv, pad, prec, rest) ->
+ make_float_padding_precision k o acc rest pad prec fconv
+ | Bool rest ->
+ fun b -> make_printf k o (Acc_string (acc, string_of_bool b)) rest
+ | Alpha rest ->
+ fun f x -> make_printf k o (Acc_delay (acc, fun o -> f o x)) rest
+ | Theta rest ->
+ fun f -> make_printf k o (Acc_delay (acc, f)) rest
+ | Reader _ ->
+ (* This case is impossible, by typing of formats. *)
+ (* Indeed, since printf and co. take a format4 as argument, the 'd and 'e
+ type parameters of fmt are obviously equals. The Reader is the
+ only constructor which touch 'd and 'e type parameters of the format
+ type, it adds an (->) to the 'd parameters. Consequently, a format4
+ cannot contain a Reader node, except in the sub-format associated to
+ an %{...%}. It's not a problem because make_printf do not call
+ itself recursively on the sub-format associated to %{...%}. *)
+ assert false
+ | Flush rest ->
+ make_printf k o (Acc_flush acc) rest
+
+ | String_literal (str, rest) ->
+ make_printf k o (Acc_string (acc, str)) rest
+ | Char_literal (chr, rest) ->
+ make_printf k o (Acc_char (acc, chr)) rest
+
+ | Format_arg (_, _, rest) ->
+ (* Use the following code to obtain the old (curious?) semantics. *)
+ (*fun _ -> make_printf k o (Acc_string (acc, string_of_fmtty fmtty)) rest*)
+ fun (_, str) -> make_printf k o (Acc_string (acc, str)) rest
+ | Format_subst (_, _, fmtty, rest) ->
+ (* Call to type_format can't failed (raise Type_mismatch). *)
+ fun (fmt, _) -> make_printf k o acc
+ CamlinternalFormatBasics.(concat_fmt (type_format fmt fmtty) rest)
+
+ | Scan_char_set (_, _, rest) ->
+ let new_acc = Acc_invalid_arg (acc, "Printf: bad conversion %[") in
+ fun _ -> make_printf k o new_acc rest
+ | Scan_get_counter (_, rest) ->
+ (* This case should be refused for Printf. *)
+ (* Accepted for backward compatibility. *)
+ (* Interpret %l, %n and %L as %d. *)
+ fun n ->
+ let new_acc = Acc_string (acc, format_int "%d" n) in
+ make_printf k o new_acc rest
+ | Ignored_param (ign, rest) ->
+ make_ignored_param k o acc ign rest
+
+ | Formatting (fmting, rest) ->
+ make_printf k o (Acc_formatting (acc, fmting)) rest
+
+ | End_of_format ->
+ k o acc
+
+(* Delay the error (Invalid_argument "Printf: bad conversion %_"). *)
+(* Generate functions to take remaining arguments (after the "%_"). *)
+and make_ignored_param : type x y a b c f .
+ (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+ (a, b, c, c, y, x) CamlinternalFormatBasics.ignored ->
+ (x, b, c, y, c, f) CamlinternalFormatBasics.fmt -> a =
+fun k o acc ign fmt -> match ign with
+ | Ignored_char -> make_invalid_arg k o acc fmt
+ | Ignored_caml_char -> make_invalid_arg k o acc fmt
+ | Ignored_string _ -> make_invalid_arg k o acc fmt
+ | Ignored_caml_string _ -> make_invalid_arg k o acc fmt
+ | Ignored_int (_, _) -> make_invalid_arg k o acc fmt
+ | Ignored_int32 (_, _) -> make_invalid_arg k o acc fmt
+ | Ignored_nativeint (_, _) -> make_invalid_arg k o acc fmt
+ | Ignored_int64 (_, _) -> make_invalid_arg k o acc fmt
+ | Ignored_float (_, _) -> make_invalid_arg k o acc fmt
+ | Ignored_bool -> make_invalid_arg k o acc fmt
+ | Ignored_format_arg _ -> make_invalid_arg k o acc fmt
+ | Ignored_format_subst (_, fmtty) -> make_from_fmtty k o acc fmtty fmt
+ | Ignored_reader -> assert false
+ | Ignored_scan_char_set _ -> make_invalid_arg k o acc fmt
+
+(* Special case of printf "%_(". *)
+and make_from_fmtty : type x y a b c f .
+ (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+ (a, b, c, c, y, x) CamlinternalFormatBasics.fmtty ->
+ (x, b, c, y, c, f) CamlinternalFormatBasics.fmt -> a =
+fun k o acc fmtty fmt -> match fmtty with
+ | Char_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | String_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Int_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Int32_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Nativeint_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Int64_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Float_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Bool_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Alpha_ty rest -> fun _ _ -> make_from_fmtty k o acc rest fmt
+ | Theta_ty rest -> fun _ -> make_from_fmtty k o acc rest fmt
+ | Reader_ty _ -> assert false
+ | Ignored_reader_ty _ -> assert false
+ | Format_arg_ty (_, rest) -> fun _ -> make_from_fmtty k o acc rest fmt
+ | End_of_fmtty -> make_invalid_arg k o acc fmt
+ | Format_subst_ty (_, ty, rest) ->
+ fun _ -> make_from_fmtty k o acc (concat_fmtty ty rest) fmt
+
+(* Insert an Acc_invalid_arg in the accumulator and continue to generate
+ closures to get the remaining arguments. *)
+and make_invalid_arg : type a b c f .
+ (b -> (b, c) acc -> f) -> b -> (b, c) acc ->
+ (a, b, c, c, c, f) CamlinternalFormatBasics.fmt -> a =
+fun k o acc fmt ->
+ make_printf k o (Acc_invalid_arg (acc, "Printf: bad conversion %_")) fmt
+
+(* Fix padding, take it as an extra integer argument if needed. *)
+and make_string_padding : type x z a b c d .
+ (b -> (b, c) acc -> d) -> b -> (b, c) acc ->
+ (a, b, c, c, c, d) CamlinternalFormatBasics.fmt ->
+ (x, z -> a) padding -> (z -> string) -> x =
+ fun k o acc fmt pad trans -> match pad with
+ | No_padding ->
+ fun x ->
+ let new_acc = Acc_string (acc, trans x) in
+ make_printf k o new_acc fmt
+ | Lit_padding (padty, width) ->
+ fun x ->
+ let new_acc = Acc_string (acc, fix_padding padty width (trans x)) in
+ make_printf k o new_acc fmt
+ | Arg_padding padty ->
+ fun w x ->
+ let new_acc = Acc_string (acc, fix_padding padty w (trans x)) in
+ make_printf k o new_acc fmt
+
+(* Fix padding and precision for int, int32, nativeint or int64. *)
+(* Take one or two extra integer arguments if needed. *)
+and make_int_padding_precision : type x y z a b c d .
+ (b -> (b, c) acc -> d) -> b -> (b, c) acc ->
+ (a, b, c, c, c, d) CamlinternalFormatBasics.fmt ->
+ (x, y) padding -> (y, z -> a) precision -> (int_conv -> z -> string) ->
+ int_conv -> x =
+ fun k o acc fmt pad prec trans iconv -> match pad, prec with
+ | No_padding, No_precision ->
+ fun x ->
+ let str = trans iconv x in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | No_padding, Lit_precision p ->
+ fun x ->
+ let str = fix_int_precision p (trans iconv x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | No_padding, Arg_precision ->
+ fun p x ->
+ let str = fix_int_precision p (trans iconv x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Lit_padding (padty, w), No_precision ->
+ fun x ->
+ let str = fix_padding padty w (trans iconv x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Lit_padding (padty, w), Lit_precision p ->
+ fun x ->
+ let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Lit_padding (padty, w), Arg_precision ->
+ fun p x ->
+ let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Arg_padding padty, No_precision ->
+ fun w x ->
+ let str = fix_padding padty w (trans iconv x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Arg_padding padty, Lit_precision p ->
+ fun w x ->
+ let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Arg_padding padty, Arg_precision ->
+ fun w p x ->
+ let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in
+ make_printf k o (Acc_string (acc, str)) fmt
+
+(* Convert a float, fix padding and precision if needed. *)
+(* Take the float argument and one or two extra integer arguments if needed. *)
+and make_float_padding_precision : type x y a b c d .
+ (b -> (b, c) acc -> d) -> b -> (b, c) acc ->
+ (a, b, c, c, c, d) CamlinternalFormatBasics.fmt ->
+ (x, y) padding -> (y, float -> a) precision -> float_conv -> x =
+ fun k o acc fmt pad prec fconv -> match pad, prec with
+ | No_padding, No_precision ->
+ fun x ->
+ let str = convert_float fconv default_float_precision x in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | No_padding, Lit_precision p ->
+ fun x ->
+ let str = convert_float fconv p x in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | No_padding, Arg_precision ->
+ fun p x ->
+ let str = convert_float fconv p x in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Lit_padding (padty, w), No_precision ->
+ fun x ->
+ let str = convert_float fconv default_float_precision x in
+ let str' = fix_padding padty w str in
+ make_printf k o (Acc_string (acc, str')) fmt
+ | Lit_padding (padty, w), Lit_precision p ->
+ fun x ->
+ let str = fix_padding padty w (convert_float fconv p x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Lit_padding (padty, w), Arg_precision ->
+ fun p x ->
+ let str = fix_padding padty w (convert_float fconv p x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Arg_padding padty, No_precision ->
+ fun w x ->
+ let str = convert_float fconv default_float_precision x in
+ let str' = fix_padding padty w str in
+ make_printf k o (Acc_string (acc, str')) fmt
+ | Arg_padding padty, Lit_precision p ->
+ fun w x ->
+ let str = fix_padding padty w (convert_float fconv p x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+ | Arg_padding padty, Arg_precision ->
+ fun w p x ->
+ let str = fix_padding padty w (convert_float fconv p x) in
+ make_printf k o (Acc_string (acc, str)) fmt
+
+(******************************************************************************)
+ (* Continuations for make_printf *)
+
+(* Recursively output an "accumulator" containing a reversed list of
+ printing entities (string, char, flus, ...) in an output_stream. *)
+(* Used as a continuation of make_printf. *)
+let rec output_acc o acc = match acc with
+ | Acc_formatting (p, fmting) ->
+ let s = string_of_formatting fmting in
+ output_acc o p;
+ output_string o s;
+ | Acc_string (p, s) -> output_acc o p; output_string o s
+ | Acc_char (p, c) -> output_acc o p; output_char o c
+ | Acc_delay (p, f) -> output_acc o p; f o
+ | Acc_flush p -> output_acc o p; flush o
+ | Acc_invalid_arg (p, msg) -> output_acc o p; invalid_arg msg;
+ | End_of_acc -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+ printing entities (string, char, flus, ...) in a buffer. *)
+(* Used as a continuation of make_printf. *)
+let rec bufput_acc b acc = match acc with
+ | Acc_formatting (p, fmting) ->
+ let s = string_of_formatting fmting in
+ bufput_acc b p;
+ Buffer.add_string b s;
+ | Acc_string (p, s) -> bufput_acc b p; Buffer.add_string b s
+ | Acc_char (p, c) -> bufput_acc b p; Buffer.add_char b c
+ | Acc_delay (p, f) -> bufput_acc b p; f b
+ | Acc_flush p -> bufput_acc b p;
+ | Acc_invalid_arg (p, msg) -> bufput_acc b p; invalid_arg msg;
+ | End_of_acc -> ()
+
+(* Recursively output an "accumulator" containing a reversed list of
+ printing entities (string, char, flus, ...) in a buffer. *)
+(* Differ from bufput_acc by the interpretation of %a and %t. *)
+(* Used as a continuation of make_printf. *)
+let rec strput_acc b acc = match acc with
+ | Acc_formatting (p, fmting) ->
+ let s = string_of_formatting fmting in
+ strput_acc b p;
+ Buffer.add_string b s;
+ | Acc_string (p, s) -> strput_acc b p; Buffer.add_string b s
+ | Acc_char (p, c) -> strput_acc b p; Buffer.add_char b c
+ | Acc_delay (p, f) -> strput_acc b p; Buffer.add_string b (f ())
+ | Acc_flush p -> strput_acc b p;
+ | Acc_invalid_arg (p, msg) -> strput_acc b p; invalid_arg msg;
+ | End_of_acc -> ()
+
+(******************************************************************************)
+ (* Error managment *)
+
+(* Raise a Failure with a pretty-printed error message. *)
+(* Since it uses "compiled formats", it can't be implemented in bootstrap
+ mode. *)
+let failwith_message _ =
+ failwith
+ "CamlinternalFormat failure \
+ (error messages not implemented at bootstrap time)"
+
+(******************************************************************************)
+ (* Parsing tools *)
+
+(* Create a padding_fmt_ebb from a padding and a format. *)
+(* Copy the padding to disjoin the type parameters of argument and result. *)
+let make_padding_fmt_ebb : type x y .
+ (x, y) padding -> (_, _, _, _, _, _) CamlinternalFormatBasics.fmt ->
+ (_, _, _, _, _) padding_fmt_ebb =
+fun pad fmt -> match pad with
+ | No_padding -> Padding_fmt_EBB (No_padding, fmt)
+ | Lit_padding (s, w) -> Padding_fmt_EBB (Lit_padding (s, w), fmt)
+ | Arg_padding s -> Padding_fmt_EBB (Arg_padding s, fmt)
+
+(* Create a precision_fmt_ebb from a precision and a format. *)
+(* Copy the precision to disjoin the type parameters of argument and result. *)
+let make_precision_fmt_ebb : type x y .
+ (x, y) precision -> (_, _, _, _, _, _) CamlinternalFormatBasics.fmt ->
+ (_, _, _, _, _) precision_fmt_ebb =
+fun prec fmt -> match prec with
+ | No_precision -> Precision_fmt_EBB (No_precision, fmt)
+ | Lit_precision p -> Precision_fmt_EBB (Lit_precision p, fmt)
+ | Arg_precision -> Precision_fmt_EBB (Arg_precision, fmt)
+
+(* Create a padprec_fmt_ebb forma a padding, a precision and a format. *)
+(* Copy the padding and the precision to disjoin type parameters of arguments
+ and result. *)
+let make_padprec_fmt_ebb : type x y z t .
+ (x, y) padding -> (z, t) precision ->
+ (_, _, _, _, _, _) CamlinternalFormatBasics.fmt ->
+ (_, _, _, _, _) padprec_fmt_ebb =
+fun pad prec fmt ->
+ let Precision_fmt_EBB (prec, fmt') = make_precision_fmt_ebb prec fmt in
+ match pad with
+ | No_padding -> Padprec_fmt_EBB (No_padding, prec, fmt')
+ | Lit_padding (s, w) -> Padprec_fmt_EBB (Lit_padding (s, w), prec, fmt')
+ | Arg_padding s -> Padprec_fmt_EBB (Arg_padding s, prec, fmt')
+
+(******************************************************************************)
+ (* Format parsing *)
+
+(* Parse a string representing a format and create a fmt_ebb. *)
+(* Raise an Failure exception in case of invalid format. *)
+let fmt_ebb_of_string str =
+ (* Parameters naming convention: *)
+ (* - lit_start: start of the literal sequence. *)
+ (* - str_ind: current index in the string. *)
+ (* - end_ind: end of the current (sub-)format. *)
+ (* - pct_ind: index of the '%' in the current micro-format. *)
+ (* - zero: is the '0' flag defined in the current micro-format. *)
+ (* - minus: is the '-' flag defined in the current micro-format. *)
+ (* - plus: is the '+' flag defined in the current micro-format. *)
+ (* - sharp: is the '#' flag defined in the current micro-format. *)
+ (* - space: is the ' ' flag defined in the current micro-format. *)
+ (* - ign: is the '_' flag defined in the current micro-format. *)
+ (* - pad: padding of the current micro-format. *)
+ (* - prec: precision of the current micro-format. *)
+ (* - symb: char representing the conversion ('c', 's', 'd', ...). *)
+ (* - char_set: set of characters as bitmap (see scanf %[...]). *)
+
+ (* Raise a Failure with a friendly error message. *)
+ (* Used when the end of the format (or the current sub-format) was encoutered
+ unexpectedly. *)
+ let unexpected_end_of_format end_ind =
+ failwith_message
+ "invalid format %S: at character number %d, unexpected end of format"
+ str end_ind;
+
+ (* Raise Failure with a friendly error message about an option dependencie
+ problem. *)
+ and invalid_format_without str_ind c s =
+ failwith_message
+ "invalid format %S: at character number %d, '%c' without %s"
+ str str_ind c s
+
+ (* Raise Failure with a friendly error message about an unexpected
+ character. *)
+ and expected_character str_ind expected read =
+ failwith_message
+ "invalid format %S: at character number %d, %s expected, read %C"
+ str str_ind expected read in
+
+ (* Parse the string from beg_ind (included) to end_ind (excluded). *)
+ let rec parse : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+ fun beg_ind end_ind -> parse_literal beg_ind beg_ind end_ind
+
+ (* Read literal characters up to '%' or '@' special characters. *)
+ and parse_literal : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb =
+ fun lit_start str_ind end_ind ->
+ if str_ind = end_ind then add_literal lit_start str_ind End_of_format else
+ match str.[str_ind] with
+ | '%' ->
+ let Fmt_EBB fmt_rest = parse_flags str_ind end_ind in
+ add_literal lit_start str_ind fmt_rest
+ | '@' ->
+ let Fmt_EBB fmt_rest = parse_after_at (str_ind + 1) end_ind in
+ add_literal lit_start str_ind fmt_rest
+ | _ ->
+ parse_literal lit_start (str_ind + 1) end_ind
+
+ and parse_flags : type e f . int -> int -> (_, _, e, f) fmt_ebb =
+ fun pct_ind end_ind ->
+ let zero = ref false and minus = ref false and plus = ref false
+ and sharp = ref false and space = ref false and ign = ref false in
+ let set_flag str_ind flag =
+ if !flag then
+ failwith_message
+ "invalid format %S: at character number %d, duplicate flag %C"
+ str str_ind str.[str_ind];
+ flag := true
+ in
+ let rec read_flags str_ind =
+ if str_ind = end_ind then unexpected_end_of_format end_ind;
+ begin match str.[str_ind] with
+ | '0' -> set_flag str_ind zero; read_flags (str_ind + 1)
+ | '-' -> set_flag str_ind minus; read_flags (str_ind + 1)
+ | '+' -> set_flag str_ind plus; read_flags (str_ind + 1)
+ | '#' -> set_flag str_ind sharp; read_flags (str_ind + 1)
+ | ' ' -> set_flag str_ind space; read_flags (str_ind + 1)
+ | '_' -> set_flag str_ind ign; read_flags (str_ind + 1)
+ | _ ->
+ parse_padding pct_ind str_ind end_ind
+ !zero !minus !plus !sharp !space !ign
+ end
+ in
+ read_flags (pct_ind + 1)
+
+ (* Try to read a digital or a '*' padding. *)
+ and parse_padding : type e f .
+ int -> int -> int -> bool -> bool -> bool -> bool -> bool -> bool ->
+ (_, _, e, f) fmt_ebb =
+ fun pct_ind str_ind end_ind zero minus plus sharp space ign ->
+ if str_ind = end_ind then unexpected_end_of_format end_ind;
+ let padty = match zero, minus with
+ | false, false -> Right
+ | false, true -> Left
+ | true, false -> Zeros
+ | true, true -> incompatible_flag pct_ind str_ind '-' "0" in
+ match str.[str_ind] with
+ | '0' .. '9' ->
+ let new_ind, width = parse_positive str_ind end_ind 0 in
+ parse_after_padding pct_ind new_ind end_ind plus sharp space ign
+ (Lit_padding (padty, width))
+ | '*' ->
+ parse_after_padding pct_ind (str_ind + 1) end_ind plus sharp space ign
+ (Arg_padding padty)
+ | _ ->
+ match padty with
+ | Left -> invalid_format_without (str_ind - 1) '-' "padding"
+ | Zeros -> invalid_format_without (str_ind - 1) '0' "padding"
+ | Right ->
+ parse_after_padding pct_ind str_ind end_ind plus sharp space ign
+ No_padding
+
+ (* Is precision defined? *)
+ and parse_after_padding : type x e f .
+ int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+ (_, _, e, f) fmt_ebb =
+ fun pct_ind str_ind end_ind plus sharp space ign pad ->
+ if str_ind = end_ind then unexpected_end_of_format end_ind;
+ match str.[str_ind] with
+ | '.' ->
+ parse_precision pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+ | symb ->
+ parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad
+ No_precision symb
+
+ (* Read the digital or '*' precision. *)
+ and parse_precision : type x e f .
+ int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+ (_, _, e, f) fmt_ebb =
+ fun pct_ind str_ind end_ind plus sharp space ign pad ->
+ if str_ind = end_ind then unexpected_end_of_format end_ind;
+ match str.[str_ind] with
+ | '0' .. '9' ->
+ let new_ind, prec = parse_positive str_ind end_ind 0 in
+ parse_conversion pct_ind (new_ind + 1) end_ind plus sharp space ign pad
+ (Lit_precision prec) str.[new_ind]
+ | '*' ->
+ parse_after_precision pct_ind (str_ind + 1) end_ind plus sharp space ign
+ pad Arg_precision
+ | _ ->
+ invalid_format_without (str_ind - 1) '.' "precision"
+
+ (* Try to read the conversion. *)
+ and parse_after_precision : type x z e f .
+ int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding ->
+ (z, _) precision -> (_, _, e, f) fmt_ebb =
+ fun pct_ind str_ind end_ind plus sharp space ign pad prec ->
+ if str_ind = end_ind then unexpected_end_of_format end_ind;
+ parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad prec
+ str.[str_ind]
+
+ (* Case analysis on conversion. *)
+ and parse_conversion : type x y z t e f .
+ int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding ->
+ (z, t) precision -> char -> (_, _, e, f) fmt_ebb =
+ fun pct_ind str_ind end_ind plus sharp space ign pad prec symb ->
+ (* Flags used to check option usages/compatibilities. *)
+ let plus_used = ref false and sharp_used = ref false
+ and space_used = ref false and ign_used = ref false
+ and pad_used = ref false and prec_used = ref false in
+
+ (* Access to options, update flags. *)
+ let get_plus () = plus_used := true; plus
+ and get_sharp () = sharp_used := true; sharp
+ and get_space () = space_used := true; space
+ and get_ign () = ign_used := true; ign
+ and get_pad () = pad_used := true; pad
+ and get_prec () = prec_used := true; prec in
+
+ (* Check that padty <> Zeros. *)
+ let check_no_0 symb = match get_pad () with
+ | No_padding -> ()
+ | Lit_padding ((Left | Right), _) -> ()
+ | Arg_padding (Left | Right) -> ()
+ | Lit_padding (Zeros, _) -> incompatible_flag pct_ind str_ind symb "0"
+ | Arg_padding Zeros -> incompatible_flag pct_ind str_ind symb "0"
+ in
+
+ (* Get padding as an int option (see "%_", "%{", "%(" and "%["). *)
+ let get_pad_opt c = match get_pad () with
+ | No_padding -> None
+ | Lit_padding (Right, width) -> Some width
+ | Lit_padding (Zeros, _) -> incompatible_flag pct_ind str_ind c "'0'"
+ | Lit_padding (Left, _) -> incompatible_flag pct_ind str_ind c "'-'"
+ | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'"
+ in
+
+ (* Get precision as an int option (see "%_f"). *)
+ let get_prec_opt () = match get_prec () with
+ | No_precision -> None
+ | Lit_precision ndec -> Some ndec
+ | Arg_precision -> incompatible_flag pct_ind str_ind '_' "'*'"
+ in
+
+ let fmt_result = match symb with
+ | ',' ->
+ parse str_ind end_ind
+ | 'c' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest))
+ else Fmt_EBB (Char fmt_rest)
+ | 'C' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then Fmt_EBB (Ignored_param (Ignored_caml_char,fmt_rest))
+ else Fmt_EBB (Caml_char fmt_rest)
+ | 's' ->
+ check_no_0 symb;
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then
+ let ignored = Ignored_string (get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padding_fmt_EBB (pad', fmt_rest') =
+ make_padding_fmt_ebb (get_pad ()) fmt_rest in
+ Fmt_EBB (String (pad', fmt_rest'))
+ | 'S' ->
+ check_no_0 symb;
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then
+ let ignored = Ignored_caml_string (get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padding_fmt_EBB (pad', fmt_rest') =
+ make_padding_fmt_ebb (get_pad ()) fmt_rest in
+ Fmt_EBB (Caml_string (pad', fmt_rest'))
+ | 'd' | 'i' | 'x' | 'X' | 'o' | 'u' ->
+ let iconv = compute_int_conv pct_ind str_ind (get_plus ()) (get_sharp ())
+ (get_space ()) symb in
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then
+ let ignored = Ignored_int (iconv, get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+ make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+ Fmt_EBB (Int (iconv, pad', prec', fmt_rest'))
+ | 'N' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Scan_get_counter (Token_counter, fmt_rest))
+ | 'l' | 'n' | 'L' when str_ind=end_ind || not (is_int_base str.[str_ind]) ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Scan_get_counter (counter_of_char symb, fmt_rest))
+ | 'l' ->
+ let iconv =
+ compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+ (get_space ()) str.[str_ind] in
+ let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+ if get_ign () then
+ let ignored = Ignored_int32 (iconv, get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+ make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+ Fmt_EBB (Int32 (iconv, pad', prec', fmt_rest'))
+ | 'n' ->
+ let iconv =
+ compute_int_conv pct_ind (str_ind + 1) (get_plus ())
+ (get_sharp ()) (get_space ()) str.[str_ind] in
+ let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+ if get_ign () then
+ let ignored = Ignored_nativeint (iconv, get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+ make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+ Fmt_EBB (Nativeint (iconv, pad', prec', fmt_rest'))
+ | 'L' ->
+ let iconv =
+ compute_int_conv pct_ind (str_ind + 1) (get_plus ()) (get_sharp ())
+ (get_space ()) str.[str_ind] in
+ let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
+ if get_ign () then
+ let ignored = Ignored_int64 (iconv, get_pad_opt '_') in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+ make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+ Fmt_EBB (Int64 (iconv, pad', prec', fmt_rest'))
+ | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' ->
+ let fconv = compute_float_conv pct_ind str_ind (get_plus ())
+ (get_space ()) symb in
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then
+ let ignored = Ignored_float (get_pad_opt '_', get_prec_opt ()) in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ let Padprec_fmt_EBB (pad', prec', fmt_rest') =
+ make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in
+ Fmt_EBB (Float (fconv, pad', prec', fmt_rest'))
+ | 'b' | 'B' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then Fmt_EBB (Ignored_param (Ignored_bool, fmt_rest))
+ else Fmt_EBB (Bool fmt_rest)
+ | 'a' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Alpha fmt_rest)
+ | 't' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Theta fmt_rest)
+ | 'r' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ if get_ign () then Fmt_EBB (Ignored_param (Ignored_reader, fmt_rest))
+ else Fmt_EBB (Reader fmt_rest)
+ | '!' ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Flush fmt_rest)
+ | ('%' | '@') as c ->
+ let Fmt_EBB fmt_rest = parse str_ind end_ind in
+ Fmt_EBB (Char_literal (c, fmt_rest))
+ | '{' ->
+ let sub_end = search_subformat_end str_ind end_ind '}' in
+ let Fmt_EBB sub_fmt = parse str_ind sub_end in
+ let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in
+ let sub_fmtty = fmtty_of_fmt sub_fmt in
+ if get_ign () then
+ let ignored = Ignored_format_arg (get_pad_opt '_', sub_fmtty) in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ Fmt_EBB (Format_arg (get_pad_opt '{', sub_fmtty, fmt_rest))
+ | '(' ->
+ let sub_end = search_subformat_end str_ind end_ind ')' in
+ let Fmt_EBB fmt_rest = parse (sub_end + 2) end_ind in
+ let Fmt_EBB sub_fmt = parse str_ind sub_end in
+ let sub_fmtty = fmtty_of_fmt sub_fmt in
+ if get_ign () then
+ let ignored = Ignored_format_subst (get_pad_opt '_', sub_fmtty) in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ Fmt_EBB (Format_subst (get_pad_opt '(',
+ reader_nb_unifier_of_fmtty sub_fmtty,
+ sub_fmtty, fmt_rest))
+ | '[' ->
+ let next_ind, char_set = parse_char_set str_ind end_ind in
+ let Fmt_EBB fmt_rest = parse next_ind end_ind in
+ if get_ign () then
+ let ignored = Ignored_scan_char_set (get_pad_opt '_', char_set) in
+ Fmt_EBB (Ignored_param (ignored, fmt_rest))
+ else
+ Fmt_EBB (Scan_char_set (get_pad_opt '[', char_set, fmt_rest))
+ | '-' | '+' | '#' | ' ' | '_' ->
+ failwith_message
+ "invalid format %S: at character number %d, \
+ flag %C is only allowed after the '%%', before padding and precision"
+ str pct_ind symb
+ | _ ->
+ failwith_message
+ "invalid format %S: at character number %d, \
+ invalid conversion \"%%%c\"" str (str_ind - 1) symb
+ in
+ (* Check for unused options, which are consequently incompatibles. *)
+ if not !plu