Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

PR#6418: fix format regression on "@{<..%d..%s..>" (Benoît Vaugon) 

To be able to compile this patch, you should temporarily apply the
following patch to bootstrap the format type change:

> diff -Naur old/typing/typecore.ml new/typing/typecore.ml
> --- old/typing/typecore.ml	2014-06-06 03:37:03.240926150 +0200
> +++ new/typing/typecore.ml	2014-06-06 03:37:24.696926699 +0200
> @@ -2956,7 +2956,7 @@
>          | Theta rest ->
>            mk_constr "Theta" [ mk_fmt rest ]
>          | Formatting (fmting, rest) ->
> -          mk_constr "Formatting" [ mk_formatting fmting; mk_fmt rest ]
> +          mk_constr "Formatting_lit" [ mk_formatting fmting; mk_fmt rest ]
>          | Reader rest ->
>            mk_constr "Reader" [ mk_fmt rest ]
>          | Scan_char_set (width_opt, char_set, rest) ->

Bootstrap process:

  make core
  apply the patch above
  make core
  make promote-cross
  make partialclean
  revert the patch above, apply the commit
  make partialclean
  make core
  make coreboot

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14973 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Gabriel Scherer 2014-06-09 13:53:47 +00:00
parent bb313fa192
commit 7cb9d0d84e
10 changed files with 552 additions and 409 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

380
stdlib/camlinternalFormat.ml
View File

@ -113,15 +113,19 @@ fun ign fmt -> match ign with
(******************************************************************************)
(* Types *)
type ('b, 'c) acc_formatting_gen =
| Acc_open_tag of ('b, 'c) acc
(* 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 *)
and ('b, 'c) acc =
| Acc_formatting_lit of ('b, 'c) acc * formatting_lit(* Special fmtting (box) *)
| Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen (* Special fmtting (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. *)
@ -149,34 +153,41 @@ type ('a, 'b, 'c, 'd, 'e, 'f) padprec_fmtty_ebb = Padprec_fmtty_EBB :
(* 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 ->
('a, 'b, 'c, 'd, 'e, 'f) 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 ->
('a, 'b, 'c, 'd, 'e, 'f) 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 ->
('a, 'b, 'c, 'd, 'e, 'f) 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 ->
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
('b, 'c, 'e, 'f) fmt_ebb
(* GADT type associating an fmtty and an fmt. *)
(* See the type_format_gen function. *)
type ('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_ebb = Fmt_fmtty_EBB :
('a, 'b, 'c, 'd, 'y, 'x) fmt *
('x, 'b, 'c, 'y, 'e, 'f) fmtty ->
('a, 'b, 'c, 'd, 'e, 'f) fmt_fmtty_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 ->
('x, 'b, 'c, 'y, 'e, 'f) fmt_fmtty_ebb ->
('a, 'b, 'c, 'd, 'e, 'f) fmtty_fmt_ebb
(* Abstract all fmtty type parameters. *)
@ -421,12 +432,11 @@ let bprint_float_fmt buf ign_flag fconv pad prec =
bprint_precision buf prec;
buffer_add_char buf (char_of_fconv fconv)
(* Compute the literal string representation of a formatting. *)
(* Compute the literal string representation of a formatting_lit. *)
(* Also used by Printf and Scanf where formatting is not interpreted. *)
let string_of_formatting formatting = match formatting with
let string_of_formatting_lit formatting_lit = match formatting_lit with
| Open_box (str, _, _) -> str
| Close_box -> "@]"
| Open_tag (str, _) -> str
| Close_tag -> "@}"
| Break (str, _, _) -> str
| FFlush -> "@?"
@ -437,6 +447,13 @@ let string_of_formatting formatting = match formatting with
| Escaped_percent -> "@%"
| Scan_indic c -> "@" ^ (String.make 1 c)
(* Compute the literal string representation of a formatting. *)
(* Also used by Printf and Scanf where formatting is not interpreted. *)
let string_of_formatting_gen : type a b c d e f .
(a, b, c, d, e, f) formatting_gen -> string =
fun formatting_gen -> match formatting_gen with
| Open_tag (Format (_, str)) -> str
(***)
(* Print a literal char in a buffer, escape '%' by "%%". *)
@ -566,8 +583,11 @@ let bprint_fmt buf fmt =
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);
| Formatting_lit (fmting_lit, rest) ->
bprint_string_literal buf (string_of_formatting_lit fmting_lit);
fmtiter rest ign_flag;
| Formatting_gen (fmting_gen, rest) ->
bprint_string_literal buf (string_of_formatting_gen fmting_gen);
fmtiter rest ign_flag;
| End_of_format -> ()
@ -777,10 +797,15 @@ and trans : type
| End_of_fmtty, _ -> assert false
| _, End_of_fmtty -> assert false
let rec fmtty_of_formatting_gen : type a b c d e f .
(a, b, c, d, e, f) formatting_gen ->
(a, b, c, d, e, f) fmtty =
fun formatting_gen -> match formatting_gen with
| Open_tag (Format (fmt, _)) -> fmtty_of_fmt fmt
(* 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 =
and fmtty_of_fmt : type a b c d e f .
(a, b, c, d, e, f) 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))
@ -827,7 +852,9 @@ fun fmtty -> match fmtty with
| 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
| Formatting_lit (_, rest) -> fmtty_of_fmt rest
| Formatting_gen (fmting_gen, rest) ->
concat_fmtty (fmtty_of_formatting_gen fmting_gen) (fmtty_of_fmt rest)
| End_of_format -> End_of_fmtty
@ -835,7 +862,7 @@ fun fmtty -> match fmtty with
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 ->
(x, b, c, y, e, f) fmt ->
(a, b, c, d, e, f) fmtty =
fun ign fmt -> match ign with
| Ignored_char -> fmtty_of_fmt fmt
@ -907,142 +934,192 @@ fun pad prec fmtty -> match prec, type_padding pad fmtty with
(* 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 a1 b1 c1 d1 e1 f1
a2 b2 c2 d2 e2 f2 .
(a1, b1, c1, d1, e1, f1) fmt
-> (a2, b2, c2, d2, e2, f2) fmtty
-> (a2, b2, c2, d2, e2, f2) fmt
= fun fmt fmtty -> match type_format_gen fmt fmtty with
| Fmt_fmtty_EBB (fmt', End_of_fmtty) -> fmt'
| _ -> raise Type_mismatch
and type_format_gen :
type a1 b1 c1 d1 e1 f1
a2 b2 c2 d2 e2 f2 .
(a1, b1, c1, d1, e1, f1) fmt
-> (a2, b2, c2, d2, e2, f2) fmtty
-> (a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb
= fun fmt fmtty -> match fmt, fmtty with
| Char fmt_rest, Char_ty fmtty_rest ->
Char (type_format fmt_rest fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Char fmt', fmtty')
| Caml_char fmt_rest, Char_ty fmtty_rest ->
Caml_char (type_format fmt_rest fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Caml_char fmt', fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (String (pad, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Caml_string (pad, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Int (iconv, pad, prec, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Int32 (iconv, pad, prec, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Nativeint (iconv, pad, prec, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Int64 (iconv, pad, prec, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Float (fconv, pad, prec, fmt'), fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Bool fmt', fmtty')
| Flush fmt_rest, fmtty_rest ->
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Flush fmt', 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)
| String_literal (str, fmt_rest), fmtty_rest ->
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (String_literal (str, fmt'), fmtty')
| Char_literal (chr, fmt_rest), fmtty_rest ->
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Char_literal (chr, fmt'), 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Format_arg (pad_opt, sub_fmtty', fmt'), fmtty')
| Format_subst (pad_opt, sub_fmtty, fmt_rest),
Format_subst_ty (sub_fmtty1, _sub_fmtty2, fmtty_rest) ->
if Fmtty_EBB (erase_rel sub_fmtty) <> Fmtty_EBB (erase_rel sub_fmtty1) then
raise Type_mismatch;
Format_subst (pad_opt, sub_fmtty1, type_format fmt_rest (erase_rel fmtty_rest))
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest (erase_rel fmtty_rest) in
Fmt_fmtty_EBB (Format_subst (pad_opt, sub_fmtty1, fmt'), fmtty')
(* Printf and Format specific constructors: *)
| Alpha fmt_rest, Alpha_ty fmtty_rest ->
Alpha (type_format fmt_rest fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Alpha fmt', fmtty')
| Theta fmt_rest, Theta_ty fmtty_rest ->
Theta (type_format fmt_rest fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Theta fmt', fmtty')
(* Format specific constructors: *)
| Formatting (formatting, fmt_rest), _ ->
Formatting (formatting, type_format fmt_rest fmtty)
| Formatting_lit (formatting_lit, fmt_rest), fmtty_rest ->
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Formatting_lit (formatting_lit, fmt'), fmtty')
| Formatting_gen (formatting_gen, fmt_rest), fmtty_rest ->
type_formatting_gen formatting_gen fmt_rest fmtty_rest
(* Scanf specific constructors: *)
| Reader fmt_rest, Reader_ty fmtty_rest ->
Reader (type_format fmt_rest fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Reader fmt', fmtty')
| 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)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Scan_char_set (width_opt, char_set, fmt'), fmtty')
| 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
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt_rest fmtty_rest in
Fmt_fmtty_EBB (Scan_get_counter (counter, fmt'), fmtty')
| Ignored_param (ign, rest), fmtty_rest ->
type_ignored_param ign rest fmtty_rest
| End_of_format, End_of_fmtty -> End_of_format
| End_of_format, fmtty_rest -> Fmt_fmtty_EBB (End_of_format, fmtty_rest)
| _ -> raise Type_mismatch
and type_formatting_gen : type a1 a3 b1 b3 c1 c3 d1 d3 e1 e2 e3 f1 f2 f3 .
(a1, b1, c1, d1, e1, f1) formatting_gen ->
(f1, b1, c1, e1, e2, f2) fmt ->
(a3, b3, c3, d3, e3, f3) fmtty ->
(a3, b3, c3, d3, e3, f3) fmt_fmtty_ebb =
fun formatting_gen fmt0 fmtty0 -> match formatting_gen with
| Open_tag (Format (fmt1, str)) ->
let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in
Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3)
(* Type an Ignored_param node according to an fmtty. *)
and type_ignored_param : type p q x y z t u v a b c d e f .
(x, y, z, t, q, p) ignored ->
(p, y, z, q, u, v) CamlinternalFormatBasics.fmt ->
(p, y, z, q, u, v) fmt ->
(a, b, c, d, e, f) fmtty ->
(a, b, c, d, e, f) CamlinternalFormatBasics.fmt =
(a, b, c, d, e, f) fmt_fmtty_ebb =
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_char as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_caml_char as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_string _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_caml_string _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_int _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_int32 _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_nativeint _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_int64 _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_float _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_bool as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_scan_char_set _ as ign' -> type_ignored_param_one ign' fmt fmtty
| Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' 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)
type_ignored_param_one (Ignored_format_arg (pad_opt, sub_fmtty)) fmt fmtty
| Ignored_format_subst (pad_opt, sub_fmtty) ->
let Fmtty_fmt_EBB (sub_fmtty', fmt') =
let Fmtty_fmt_EBB (sub_fmtty', Fmt_fmtty_EBB (fmt', fmtty')) =
type_ignored_format_substitution sub_fmtty fmt fmtty in
Ignored_param (Ignored_format_subst (pad_opt, erase_rel (symm sub_fmtty')), fmt')
| Ignored_reader ->
begin match fmtty with
Fmt_fmtty_EBB (Ignored_param (Ignored_format_subst (pad_opt, sub_fmtty'), fmt'), fmtty')
| Ignored_reader -> (
match fmtty with
| Ignored_reader_ty fmtty_rest ->
Ignored_param (Ignored_reader, type_format fmt fmtty_rest)
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty_rest in
Fmt_fmtty_EBB (Ignored_param (Ignored_reader, fmt'), fmtty')
| _ -> raise Type_mismatch
end
| Ignored_scan_get_counter _ as ign' ->
Ignored_param (ign', type_format fmt fmtty)
)
and type_ignored_param_one : type a1 a2 b1 b2 c1 c2 d1 d2 e1 e2 f1 f2 .
(a2, b2, c2, d2, d2, a2) ignored ->
(a1, b1, c1, d1, e1, f1) fmt ->
(a2, b2, c2, d2, e2, f2) fmtty ->
(a2, b2, c2, d2, e2, f2) fmt_fmtty_ebb
= fun ign fmt fmtty ->
let Fmt_fmtty_EBB (fmt', fmtty') = type_format_gen fmt fmtty in
Fmt_fmtty_EBB (Ignored_param (ign, fmt'), fmtty')
(* Typing of the complex case: "%_(...%)". *)
and type_ignored_format_substitution : type w x y z p s t u a b c d e f .
(w, x, y, z, s, p) fmtty ->
(p, x, y, s, t, u) CamlinternalFormatBasics.fmt ->
(p, x, y, s, t, u) 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 ->
@ -1113,11 +1190,9 @@ fun sub_fmtty fmt fmtty -> match sub_fmtty, fmtty with
type_ignored_format_substitution (erase_rel sub_fmtty_rest) fmt fmtty_rest in
Fmtty_fmt_EBB (Format_subst_ty (sub1_fmtty', sub2_fmtty', symm sub_fmtty_rest'), fmt')
| End_of_fmtty, fmtty ->
Fmtty_fmt_EBB (End_of_fmtty, type_format fmt fmtty)
Fmtty_fmt_EBB (End_of_fmtty, type_format_gen fmt fmtty)
| _ -> raise Type_mismatch
(* This implementation of `recast` is a bit disappointing. The
invariant provided by the type are very strong: the input format's
type is in relation to the output type's as witnessed by the
@ -1275,9 +1350,9 @@ let string_of_fmtty fmtty =
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 =
let rec make_printf : type a b c d e f .
(b -> (b, c) acc -> f) -> b -> (b, c) acc ->
(a, b, c, d, e, f) fmt -> a =
fun k o acc fmt -> match fmt with
| Char rest ->
fun c ->
@ -1347,18 +1422,22 @@ fun k o acc fmt -> match fmt with
| Ignored_param (ign, rest) ->
make_ignored_param k o acc ign rest
| Formatting (fmting, rest) ->
make_printf k o (Acc_formatting (acc, fmting)) rest
| Formatting_lit (fmting_lit, rest) ->
make_printf k o (Acc_formatting_lit (acc, fmting_lit)) rest
| Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
let k' koc kacc =
make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in
make_printf k' o End_of_acc fmt'
| 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 .
and make_ignored_param : type x y a b c d e 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 =
(a, b, c, d, y, x) ignored ->
(x, b, c, y, e, f) 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
@ -1378,10 +1457,10 @@ fun k o acc ign fmt -> match ign with
(* Special case of printf "%_(". *)
and make_from_fmtty : type x y a b c f .
and make_from_fmtty : type x y a b c d e 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 =
(a, b, c, d, y, x) fmtty ->
(x, b, c, y, e, f) 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
@ -1403,16 +1482,16 @@ fun k o acc fmtty fmt -> match fmtty with
(* 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 .
and make_invalid_arg : type a b c d e f .
(b -> (b, c) acc -> f) -> b -> (b, c) acc ->
(a, b, c, c, c, f) CamlinternalFormatBasics.fmt -> a =
(a, b, c, d, e, f) 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 ->
and make_string_padding : type x z a b c d e f .
(b -> (b, c) acc -> f) -> b -> (b, c) acc ->
(a, b, c, d, e, f) fmt ->
(x, z -> a) padding -> (z -> string) -> x =
fun k o acc fmt pad trans -> match pad with
| No_padding ->
@ -1430,9 +1509,9 @@ and make_string_padding : type x z a b c d .
(* 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 ->
and make_int_padding_precision : type x y z a b c d e f .
(b -> (b, c) acc -> f) -> b -> (b, c) acc ->
(a, b, c, d, e, f) 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
@ -1475,9 +1554,9 @@ and make_int_padding_precision : type x y z a b c d .
(* 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 ->
and make_float_padding_precision : type x y a b c d e f .
(b -> (b, c) acc -> f) -> b -> (b, c) acc ->
(a, b, c, d, e, f) 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 ->
@ -1526,10 +1605,15 @@ and make_float_padding_precision : type x y a b c d .
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
| Acc_formatting_lit (p, fmting_lit) ->
let s = string_of_formatting_lit fmting_lit in
output_acc o p;
output_string o s;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
output_acc o p;
output_string o "@{<";
output_acc o acc';
output_char o '>';
| 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
@ -1541,10 +1625,15 @@ let rec output_acc o acc = match acc with
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
| Acc_formatting_lit (p, fmting_lit) ->
let s = string_of_formatting_lit fmting_lit in
bufput_acc b p;
Buffer.add_string b s;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
bufput_acc b p;
Buffer.add_string b "@{<";
bufput_acc b acc';
Buffer.add_char b '>';
| 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
@ -1557,10 +1646,15 @@ let rec bufput_acc b acc = match acc with
(* 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
| Acc_formatting_lit (p, fmting_lit) ->
let s = string_of_formatting_lit fmting_lit in
strput_acc b p;
Buffer.add_string b s;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
strput_acc b p;
Buffer.add_string b "@{<";
strput_acc b acc';
Buffer.add_char b '>';
| 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 ())
@ -1583,7 +1677,7 @@ let failwith_message (Format (fmt, _)) =
(* 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 ->
(x, y) padding -> (_, _, _, _, _, _) fmt ->
(_, _, _, _, _) padding_fmt_ebb =
fun pad fmt -> match pad with
| No_padding -> Padding_fmt_EBB (No_padding, fmt)
@ -1593,7 +1687,7 @@ fun pad fmt -> match pad with
(* 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 ->
(x, y) precision -> (_, _, _, _, _, _) fmt ->
(_, _, _, _, _) precision_fmt_ebb =
fun prec fmt -> match prec with
| No_precision -> Precision_fmt_EBB (No_precision, fmt)
@ -1605,7 +1699,7 @@ fun prec fmt -> match prec with
and result. *)
let make_padprec_fmt_ebb : type x y z t .
(x, y) padding -> (z, t) precision ->
(_, _, _, _, _, _) CamlinternalFormatBasics.fmt ->
(_, _, _, _, _, _) fmt ->
(_, _, _, _, _) padprec_fmt_ebb =
fun pad prec fmt ->
let Precision_fmt_EBB (prec, fmt') = make_precision_fmt_ebb prec fmt in
@ -2004,9 +2098,7 @@ let fmt_ebb_of_string str =
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 '(',
sub_fmtty,
fmt_rest))
Fmt_EBB (Format_subst (get_pad_opt '(', 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
@ -2065,43 +2157,43 @@ let fmt_ebb_of_string str =
parse_open_box (str_ind + 1) end_ind
| ']' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Close_box, fmt_rest))
Fmt_EBB (Formatting_lit (Close_box, fmt_rest))
| '{' ->
parse_open_tag (str_ind + 1) end_ind
| '}' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Close_tag, fmt_rest))
Fmt_EBB (Formatting_lit (Close_tag, fmt_rest))
| ',' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Break ("@,", 0, 0), fmt_rest))
Fmt_EBB (Formatting_lit (Break ("@,", 0, 0), fmt_rest))
| ' ' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Break ("@ ", 1, 0), fmt_rest))
Fmt_EBB (Formatting_lit (Break ("@ ", 1, 0), fmt_rest))
| ';' ->
parse_good_break (str_ind + 1) end_ind
| '?' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (FFlush, fmt_rest))
Fmt_EBB (Formatting_lit (FFlush, fmt_rest))
| '\n' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Force_newline, fmt_rest))
Fmt_EBB (Formatting_lit (Force_newline, fmt_rest))
| '.' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Flush_newline, fmt_rest))
Fmt_EBB (Formatting_lit (Flush_newline, fmt_rest))
| '<' ->
parse_magic_size (str_ind + 1) end_ind
| '@' ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Escaped_at, fmt_rest))
Fmt_EBB (Formatting_lit (Escaped_at, fmt_rest))
| '%' when str_ind + 1 < end_ind && str.[str_ind + 1] = '%' ->
let Fmt_EBB fmt_rest = parse (str_ind + 2) end_ind in
Fmt_EBB (Formatting (Escaped_percent, fmt_rest))
Fmt_EBB (Formatting_lit (Escaped_percent, fmt_rest))
| '%' ->
let Fmt_EBB fmt_rest = parse str_ind end_ind in
Fmt_EBB (Char_literal ('@', fmt_rest))
| c ->
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
Fmt_EBB (Formatting (Scan_indic c, fmt_rest))
Fmt_EBB (Formatting_lit (Scan_indic c, fmt_rest))
(* Try to read the optionnal <...> after "@[". *)
and parse_open_box : type e f . int -> int -> (_, _, e, f) fmt_ebb =
@ -2143,31 +2235,31 @@ let fmt_ebb_of_string str =
in
let s = String.sub str (str_ind - 2) (next_ind - str_ind + 2) in
let Fmt_EBB fmt_rest = parse next_ind end_ind in
Fmt_EBB (Formatting (Open_box (s, box_ty, indent), fmt_rest))
Fmt_EBB (Formatting_lit (Open_box (s, box_ty, indent), fmt_rest))
(* Try to read the optionnal <name> after "@{". *)
and parse_open_tag : type e f . int -> int -> (_, _, e, f) fmt_ebb =
fun str_ind end_ind ->
let next_ind, lit, name =
try
if str_ind = end_ind then raise Not_found;
match str.[str_ind] with
| '<' ->
let ind = String.index_from str (str_ind + 1) '>' in
if ind >= end_ind then raise Not_found;
let lit = String.sub str (str_ind - 1) (ind - str_ind + 2) in
let name = String.sub str (str_ind + 1) (ind - str_ind - 1) in
ind + 1, lit, name
| _ -> raise Not_found
with Not_found -> str_ind, "@{", ""
in
let Fmt_EBB fmt_rest = parse next_ind end_ind in
Fmt_EBB (Formatting (Open_tag (lit, name), fmt_rest))
try
if str_ind = end_ind then raise Not_found;
match str.[str_ind] with
| '<' ->
let ind = String.index_from str (str_ind + 1) '>' in
if ind >= end_ind then raise Not_found;
let as_str = String.sub str (str_ind + 1) (ind - str_ind - 1) in
let Fmt_EBB fmt_rest = parse (ind + 1) end_ind in
let Fmt_EBB sub_fmt = parse (str_ind + 1) ind in
Fmt_EBB (Formatting_gen (Open_tag (Format (sub_fmt, as_str)), fmt_rest))
| _ ->
raise Not_found
with Not_found ->
let Fmt_EBB fmt_rest = parse str_ind end_ind in
Fmt_EBB (Formatting_gen (Open_tag (Format (End_of_format, "")), fmt_rest))
(* Try to read the optionnal <width offset> after "@;". *)
and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb =
fun str_ind end_ind ->
let next_ind, formatting =
let next_ind, formatting_lit =
try
if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found;
let str_ind_1 = parse_spaces (str_ind + 1) end_ind in
@ -2192,7 +2284,7 @@ let fmt_ebb_of_string str =
str_ind, Break ("@;", 1, 0)
in
let Fmt_EBB fmt_rest = parse next_ind end_ind in
Fmt_EBB (Formatting (formatting, fmt_rest))
Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest))
(* Parse the size in a <n>. *)
and parse_magic_size : type e f . int -> int -> (_, _, e, f) fmt_ebb =
@ -2211,12 +2303,12 @@ let fmt_ebb_of_string str =
with Not_found | Failure _ ->
None
with
| Some (next_ind, formatting) ->
| Some (next_ind, formatting_lit) ->
let Fmt_EBB fmt_rest = parse next_ind end_ind in
Fmt_EBB (Formatting (formatting, fmt_rest))
Fmt_EBB (Formatting_lit (formatting_lit, fmt_rest))
| None ->
let Fmt_EBB fmt_rest = parse str_ind end_ind in
Fmt_EBB (Formatting (Scan_indic '<', fmt_rest))
Fmt_EBB (Formatting_lit (Scan_indic '<', fmt_rest))
(* Parse and construct a char set. *)
and parse_char_set str_ind end_ind =
@ -2342,7 +2434,7 @@ let fmt_ebb_of_string str =
(* Add a literal to a format from a literal character sub-sequence. *)
and add_literal : type a d e f .
int -> int -> (a, _, _, d, e, f) CamlinternalFormatBasics.fmt ->
int -> int -> (a, _, _, d, e, f) fmt ->
(_, _, e, f) fmt_ebb =
fun lit_start str_ind fmt -> match str_ind - lit_start with
| 0 -> Fmt_EBB fmt

22
stdlib/camlinternalFormat.mli
View File

@ -18,13 +18,17 @@ val param_format_of_ignored_format :
('a, 'b, 'c, 'd, 'y, 'x) ignored -> ('x, 'b, 'c, 'y, 'e, 'f) fmt ->
('a, 'b, 'c, 'd, 'e, 'f) param_format_ebb
type ('b, 'c) acc =
| Acc_formatting of ('b, 'c) acc * formatting
| Acc_string of ('b, 'c) acc * string
| Acc_char of ('b, 'c) acc * char
| Acc_delay of ('b, 'c) acc * ('b -> 'c)
| Acc_flush of ('b, 'c) acc
| Acc_invalid_arg of ('b, 'c) acc * string
type ('b, 'c) acc_formatting_gen =
| Acc_open_tag of ('b, 'c) acc
and ('b, 'c) acc =
| Acc_formatting_lit of ('b, 'c) acc * formatting_lit
| Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen
| Acc_string of ('b, 'c) acc * string
| Acc_char of ('b, 'c) acc * char
| Acc_delay of ('b, 'c) acc * ('b -> 'c)
| Acc_flush of ('b, 'c) acc
| Acc_invalid_arg of ('b, 'c) acc * string
| End_of_acc
type ('a, 'b) heter_list =
@ -61,7 +65,9 @@ val format_of_string_format :
('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
val char_of_iconv : CamlinternalFormatBasics.int_conv -> char
val string_of_formatting : CamlinternalFormatBasics.formatting -> string
val string_of_formatting_lit : CamlinternalFormatBasics.formatting_lit -> string
val string_of_formatting_gen :
('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.formatting_gen -> string
val string_of_fmtty :
('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> string

79
stdlib/camlinternalFormatBasics.ml
View File

@ -1,33 +1,3 @@
(* 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). *)
@ -226,9 +196,43 @@ does assume that the two input have exactly the same term structure
Format_subst_ty constructor).
*)
(* 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_lit =
| Open_box of string * block_type * int (* @[ *)
| Close_box (* @] *)
| 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 *)
(* Formatting element used by the Format pretty-printter. *)
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @{ *)
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
(***)
(* List of format type elements. *)
(* In particular used to represent %(...%) and %{...%} contents. *)
type ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
and ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
('a, 'b, 'c, 'd, 'e, 'f,
'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel
and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
@ -388,9 +392,12 @@ and ('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 ->
| Formatting_lit : (* @_ *)
formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
('a, 'b, 'c, 'd, 'e, 'f) fmt
| Formatting_gen : (* @_ *)
('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen *
('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) fmt
(* Scanf specific constructors: *)
| Reader : (* %r *)
@ -597,8 +604,10 @@ fun fmt1 fmt2 -> match fmt1 with
| Ignored_param (ign, rest) ->
Ignored_param (ign, concat_fmt rest fmt2)
| Formatting (fmting, rest) ->
Formatting (fmting, concat_fmt rest fmt2)
| Formatting_lit (fmting_lit, rest) ->
Formatting_lit (fmting_lit, concat_fmt rest fmt2)
| Formatting_gen (fmting_gen, rest) ->
Formatting_gen (fmting_gen, concat_fmt rest fmt2)
| End_of_format ->
fmt2

386
stdlib/camlinternalFormatBasics.mli
View File

@ -1,21 +1,5 @@
(* No comments, OCaml stdlib internal use only. *)
type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
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
| Flush_newline
| Magic_size of string * int
| Escaped_at
| Escaped_percent
| Scan_indic of char
type padty = Left | Right | Zeros
type int_conv =
@ -45,184 +29,206 @@ type ('a, 'b) precision =
type prec_option = int option
type ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
type formatting_lit =
| Open_box of string * block_type * int
| Close_box
| Close_tag
| Break of string * int * int
| FFlush
| Force_newline
| Flush_newline
| Magic_size of string * int
| Escaped_at
| Escaped_percent
| Scan_indic of char
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
and ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
('a, 'b, 'c, 'd, 'e, 'f,
'a, 'b, 'c, 'd, 'e, 'f) fmtty_rel
and ('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel =
| Char_ty : (* %c *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| String_ty : (* %s *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int_ty : (* %d *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int32_ty : (* %ld *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Nativeint_ty : (* %nd *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int64_ty : (* %Ld *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Float_ty : (* %f *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Bool_ty : (* %B *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Format_arg_ty : (* %{...%} *)
('g, 'h, 'i, 'j, 'k, 'l) fmtty *
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Format_subst_ty : (* %(...%) *)
('g, 'h, 'i, 'j, 'k, 'l,
'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel *
('g, 'h, 'i, 'j, 'k, 'l,
'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel *
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1,
('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel =
| Char_ty : (* %c *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(char -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
char -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| String_ty : (* %s *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(string -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
string -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int_ty : (* %d *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int32_ty : (* %ld *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int32 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int32 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Nativeint_ty : (* %nd *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(nativeint -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
nativeint -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Int64_ty : (* %Ld *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(int64 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
int64 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Float_ty : (* %f *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(float -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
float -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Bool_ty : (* %B *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(bool -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
bool -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Format_arg_ty : (* %{...%} *)
('g, 'h, 'i, 'j, 'k, 'l) fmtty *
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Format_subst_ty : (* %(...%) *)
('g, 'h, 'i, 'j, 'k, 'l,
'g1, 'b1, 'c1, 'j1, 'd1, 'a1) fmtty_rel *
('g, 'h, 'i, 'j, 'k, 'l,
'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel *
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g1, 'b1, 'c1, 'j1, 'e1, 'f1,
('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
(* Printf and Format specific constructors. *)
| Alpha_ty : (* %a *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Theta_ty : (* %t *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
(* Printf and Format specific constructors. *)
| Alpha_ty : (* %a *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('b1 -> 'x -> 'c1) -> 'x -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('b2 -> 'x -> 'c2) -> 'x -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
| Theta_ty : (* %t *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
(('b1 -> 'c1) -> 'a1, 'b1, 'c1, 'd1, 'e1, 'f1,
('b2 -> 'c2) -> 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
(* Scanf specific constructor. *)
| Reader_ty : (* %r *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
| Ignored_reader_ty : (* %_r *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
(* Scanf specific constructor. *)
| Reader_ty : (* %r *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('x -> 'a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
'x -> 'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
| Ignored_reader_ty : (* %_r *)
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('a1, 'b1, 'c1, ('b1 -> 'x) -> 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, ('b2 -> 'x) -> 'd2, 'e2, 'f2) fmtty_rel
| End_of_fmtty :
('f1, 'b1, 'c1, 'd1, 'd1, 'f1,
'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel
| End_of_fmtty :
('f1, 'b1, 'c1, 'd1, 'd1, 'f1,
'f2, 'b2, 'c2, 'd2, 'd2, 'f2) fmtty_rel
(***)
(**)
(* List of format elements. *)
(** 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
| 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
| 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 : (* %{...%} *)
pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
| Format_subst : (* %(...%) *)
pad_option *
('g, 'h, 'i, 'j, 'k, 'l,
'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel *
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, 'f) fmt
| Format_arg : (* %{...%} *)
pad_option * ('g, 'h, 'i, 'j, 'k, 'l) fmtty *
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'a, 'b, 'c, 'd, 'e, 'f) fmt
| Format_subst : (* %(...%) *)
pad_option *
('g, 'h, 'i, 'j, 'k, 'l,
'g2, 'b, 'c, 'j2, 'd, 'a) fmtty_rel *
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
(('g, 'h, 'i, 'j, 'k, 'l) format6 -> 'g2, 'b, 'c, 'j2, 'e, '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
(* 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
(* Format specific constructor: *)
| Formatting_lit : (* @_ *)
formatting_lit * ('a, 'b, 'c, 'd, 'e, 'f) fmt ->
('a, 'b, 'c, 'd, 'e, 'f) fmt
| Formatting_gen : (* @_ *)
('a1, 'b, 'c, 'd1, 'e1, 'f1) formatting_gen *
('f1, 'b, 'c, 'e1, 'e2, 'f2) fmt -> ('a1, 'b, 'c, 'd1, 'e2, 'f2) 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 : (* %[...] *)
pad_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
(* 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 : (* %[...] *)
pad_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 :
| End_of_format :
('f, 'b, 'c, 'e, 'e, 'f) fmt
and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
@ -260,21 +266,21 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
val concat_fmtty :
('g1, 'b1, 'c1, 'j1, 'd1, 'a1,
'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel ->
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('g1, 'b1, 'c1, 'j1, 'e1, 'f1,
'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
('g1, 'b1, 'c1, 'j1, 'd1, 'a1,
'g2, 'b2, 'c2, 'j2, 'd2, 'a2) fmtty_rel ->
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel ->
('g1, 'b1, 'c1, 'j1, 'e1, 'f1,
'g2, 'b2, 'c2, 'j2, 'e2, 'f2) fmtty_rel
val erase_rel :
('a, 'b, 'c, 'd, 'e, 'f,
'g, 'h, 'i, 'j, 'k, 'l) fmtty_rel -> ('a, 'b, 'c, 'd, 'e, 'f) fmtty
('a, 'b, 'c, 'd, 'e, 'f,
'g, 'h, 'i, 'j, 'k, 'l) fmtty_rel -> ('a, 'b, 'c, 'd, 'e, 'f) fmtty
val concat_fmt :
('a, 'b, 'c, 'd, 'e, 'f) fmt ->
('f, 'b, 'c, 'e, 'g, 'h) fmt ->
('a, 'b, 'c, 'd, 'g, 'h) fmt
('f, 'b, 'c, 'e, 'g, 'h) fmt ->
('a, 'b, 'c, 'd, 'g, 'h) fmt

35
stdlib/format.ml
View File

@ -1069,10 +1069,9 @@ open CamlinternalFormatBasics
open CamlinternalFormat
(* Interpret a formatting entity on a formatter. *)
let output_formatting ppf fmting = match fmting with
let output_formatting_lit ppf fmting_lit = match fmting_lit with
| Open_box (_, bty, indent) -> pp_open_box_gen ppf indent bty
| Close_box -> pp_close_box ppf ()
| Open_tag (_, name) -> pp_open_tag ppf name
| Close_tag -> pp_close_tag ppf ()
| Break (_, width, offset) -> pp_print_break ppf width offset
| FFlush -> pp_print_flush ppf ()
@ -1088,13 +1087,22 @@ let output_formatting ppf fmting = match fmting with
(* Differ from Printf.output_acc by the interpretation of formatting. *)
(* Used as a continuation of CamlinternalFormat.make_printf. *)
let rec output_acc ppf acc = match acc with
| Acc_string (Acc_formatting (p, Magic_size (_, size)), s) ->
| Acc_string (Acc_formatting_lit (p, Magic_size (_, size)), s) ->
output_acc ppf p;
pp_print_as_size ppf (size_of_int size) s;
| Acc_char (Acc_formatting (p, Magic_size (_, size)), c) ->
| Acc_char (Acc_formatting_lit (p, Magic_size (_, size)), c) ->
output_acc ppf p;
pp_print_as_size ppf (size_of_int size) (String.make 1 c);
| Acc_formatting (p, f) -> output_acc ppf p; output_formatting ppf f;
| Acc_formatting_lit (p, f) ->
output_acc ppf p;
output_formatting_lit ppf f;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
output_acc ppf p;
let buf' = Buffer.create 16 in
let ppf' = formatter_of_buffer buf' in
output_acc ppf' acc';
pp_print_flush ppf' ();
pp_open_tag ppf (Buffer.contents buf');
| Acc_string (p, s) -> output_acc ppf p; pp_print_string ppf s;
| Acc_char (p, c) -> output_acc ppf p; pp_print_char ppf c;
| Acc_delay (p, f) -> output_acc ppf p; f ppf;
@ -1107,16 +1115,25 @@ let rec output_acc ppf acc = match acc with
(* Differ from Printf.bufput_acc by the interpretation of formatting. *)
(* Used as a continuation of CamlinternalFormat.make_printf. *)
let rec strput_acc ppf acc = match acc with
| Acc_string (Acc_formatting (p, Magic_size (_, size)), s) ->
| Acc_string (Acc_formatting_lit (p, Magic_size (_, size)), s) ->
strput_acc ppf p;
pp_print_as_size ppf (size_of_int size) s;
| Acc_char (Acc_formatting (p, Magic_size (_, size)), c) ->
| Acc_char (Acc_formatting_lit (p, Magic_size (_, size)), c) ->
strput_acc ppf p;
pp_print_as_size ppf (size_of_int size) (String.make 1 c);
| Acc_delay (Acc_formatting (p, Magic_size (_, size)), f) ->
| Acc_delay (Acc_formatting_lit (p, Magic_size (_, size)), f) ->
strput_acc ppf p;
pp_print_as_size ppf (size_of_int size) (f ());
| Acc_formatting (p, f) -> strput_acc ppf p; output_formatting ppf f;
| Acc_formatting_lit (p, f) ->
strput_acc ppf p;
output_formatting_lit ppf f;
| Acc_formatting_gen (p, Acc_open_tag acc') ->
strput_acc ppf p;
let buf' = Buffer.create 16 in
let ppf' = formatter_of_buffer buf' in
strput_acc ppf' acc';
pp_print_flush ppf' ();
pp_open_tag ppf (Buffer.contents buf');
| Acc_string (p, s) -> strput_acc ppf p; pp_print_string ppf s;
| Acc_char (p, c) -> strput_acc ppf p; pp_print_char ppf c;
| Acc_delay (p, f) -> strput_acc ppf p; pp_print_string ppf (f ());

23
stdlib/scanf.ml
View File

@ -992,9 +992,9 @@ let width_of_pad_opt pad_opt = match pad_opt with
| None -> max_int
| Some width -> width
let stopper_of_formatting fmting =
let stopper_of_formatting_lit fmting =
if fmting = Escaped_percent then '%', "" else
let str = string_of_formatting fmting in
let str = string_of_formatting_lit fmting in
let stp = str.[1] in
let sub_str = String.sub str 2 (String.length str - 2) in
stp, sub_str
@ -1033,7 +1033,9 @@ fun k fmt -> match fmt with
| Scan_char_set (_, _, rest) -> take_format_readers k rest
| Scan_get_counter (_, rest) -> take_format_readers k rest
| Formatting (_, rest) -> take_format_readers k rest
| Formatting_lit (_, rest) -> take_format_readers k rest
| Formatting_gen (Open_tag (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest)
| Format_arg (_, _, rest) -> take_format_readers k rest
| Format_subst (_, fmtty, rest) -> take_fmtty_format_readers k (erase_rel (symm fmtty)) rest
@ -1115,8 +1117,8 @@ fun ib fmt readers -> match fmt with
let c = token_char ib in
Cons (c, make_scanf ib rest readers)
| String (pad, Formatting (fmting, rest)) ->
let stp, str = stopper_of_formatting fmting in
| String (pad, Formatting_lit (fmting_lit, rest)) ->
let stp, str = stopper_of_formatting_lit fmting_lit in
let scan width _ ib = scan_string (Some stp) width ib in
let str_rest = String_literal (str, rest) in
pad_prec_scanf ib str_rest readers pad No_precision scan token_string
@ -1207,8 +1209,8 @@ fun ib fmt readers -> match fmt with
Cons (Format (fmt, s),
make_scanf ib (concat_fmt fmt' rest) readers)
| Scan_char_set (width_opt, char_set, Formatting (fmting, rest)) ->
let stp, str = stopper_of_formatting fmting in
| Scan_char_set (width_opt, char_set, Formatting_lit (fmting_lit, rest)) ->
let stp, str = stopper_of_formatting_lit fmting_lit in
let width = width_of_pad_opt width_opt in
let _ = scan_chars_in_char_set char_set (Some stp) width ib in
let s = token_string ib in
@ -1223,9 +1225,12 @@ fun ib fmt readers -> match fmt with
let count = get_counter ib counter in
Cons (count, make_scanf ib rest readers)
| Formatting (formatting, rest) ->
String.iter (check_char ib) (string_of_formatting formatting);
| Formatting_lit (formatting_lit, rest) ->
String.iter (check_char ib) (string_of_formatting_lit formatting_lit);
make_scanf ib rest readers
| Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
check_char ib '@'; check_char ib '{'; check_char ib '<';
make_scanf ib (concat_fmt fmt' (Char_literal ('<', rest))) readers
| Ignored_param (ign, rest) ->
let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in

36
typing/typecore.ml
View File

@ -2765,13 +2765,11 @@ and type_format loc str env =
| Pp_hovbox -> mk_constr "Pp_hovbox" []
| Pp_box -> mk_constr "Pp_box" []
| Pp_fits -> mk_constr "Pp_fits" [] in
let mk_formatting fmting = match fmting with
let rec mk_formatting_lit fmting = match fmting with
| Open_box (org, bty, idt) ->
mk_constr "Open_box" [ mk_string org; mk_block_type bty; mk_int idt ]
| Close_box ->
mk_constr "Close_box" []
| Open_tag (org, name) ->
mk_constr "Open_tag" [ mk_string org; mk_string name ]
| Close_tag ->
mk_constr "Close_tag" []
| Break (org, ns, ni) ->
@ -2790,6 +2788,15 @@ and type_format loc str env =
mk_constr "Escaped_percent" []
| Scan_indic c ->
mk_constr "Scan_indic" [ mk_char c ]
and mk_formatting_gen : type a b c d e f .
(a, b, c, d, e, f) formatting_gen -> Parsetree.expression =
fun fmting -> match fmting with
| Open_tag (Format (fmt', str')) ->
mk_constr "Open_tag" [ mk_format fmt' str' ]
and mk_format : type a b c d e f .
(a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
Parsetree.expression = fun fmt str ->
mk_constr "Format" [ mk_fmt fmt; mk_string str ]
and mk_side side = match side with
| Left -> mk_constr "Left" []
| Right -> mk_constr "Right" []
@ -2829,8 +2836,8 @@ and type_format loc str env =
mk_exp_loc (Pexp_construct (lid_loc, None))
| Some n ->
let lid_loc = mk_lid_loc (Longident.Lident "Some") in
mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n))) in
let rec mk_fmtty : type a b c d e f g h i j k l .
mk_exp_loc (Pexp_construct (lid_loc, Some (mk_int n)))
and mk_fmtty : type a b c d e f g h i j k l .
(a, b, c, d, e, f, g, h, i, j, k, l) fmtty_rel -> Parsetree.expression =
fun fmtty -> match fmtty with
| Char_ty rest -> mk_constr "Char_ty" [ mk_fmtty rest ]
@ -2852,8 +2859,7 @@ and type_format loc str env =
mk_constr "Format_subst_ty"
[ mk_fmtty sub_fmtty1; mk_fmtty sub_fmtty2; mk_fmtty rest ]
| End_of_fmtty -> mk_constr "End_of_fmtty" []
in
let mk_ignored : type a b c d e f .
and mk_ignored : type a b c d e f .
(a, b, c, d, e, f) ignored -> Parsetree.expression =
fun ign -> match ign with
| Ignored_char ->
@ -2890,8 +2896,7 @@ and type_format loc str env =
mk_constr "Ignored_scan_get_counter" [
mk_counter counter
]
in
let mk_padding : type x y . (x, y) padding -> Parsetree.expression =
and mk_padding : type x y . (x, y) padding -> Parsetree.expression =
fun pad -> match pad with
| No_padding -> mk_constr "No_padding" []
| Lit_padding (s, w) -> mk_constr "Lit_padding" [ mk_side s; mk_int w ]
@ -2900,8 +2905,8 @@ and type_format loc str env =
fun prec -> match prec with
| No_precision -> mk_constr "No_precision" []
| Lit_precision w -> mk_constr "Lit_precision" [ mk_int w ]
| Arg_precision -> mk_constr "Arg_precision" [] in
let rec mk_fmt : type a b c d e f .
| Arg_precision -> mk_constr "Arg_precision" []
and mk_fmt : type a b c d e f .
(a, b, c, d, e, f) fmt -> Parsetree.expression =
fun fmt -> match fmt with
| Char rest ->
@ -2945,8 +2950,10 @@ and type_format loc str env =
mk_constr "Alpha" [ mk_fmt rest ]
| Theta rest ->
mk_constr "Theta" [ mk_fmt rest ]
| Formatting (fmting, rest) ->
mk_constr "Formatting" [ mk_formatting fmting; mk_fmt rest ]
| Formatting_lit (fmting, rest) ->
mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ]
| Formatting_gen (fmting, rest) ->
mk_constr "Formatting_gen" [ mk_formatting_gen fmting; mk_fmt rest ]
| Reader rest ->
mk_constr "Reader" [ mk_fmt rest ]
| Scan_char_set (width_opt, char_set, rest) ->
@ -2957,7 +2964,8 @@ and type_format loc str env =
| Ignored_param (ign, rest) ->
mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ]
| End_of_format ->
mk_constr "End_of_format" [] in
mk_constr "End_of_format" []
in
let Fmt_EBB fmt = fmt_ebb_of_string str in
mk_constr "Format" [ mk_fmt fmt; mk_string str ]
))