Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

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
  • Loading branch information...
commit 7cb9d0d84ea13ae0f984b45f6b9ddae5ca4a5198 1 parent bb313fa
Gabriel Scherer authored
View
BIN  boot/ocamlc
Binary file not shown
View
BIN  boot/ocamldep
Binary file not shown
View
BIN  boot/ocamllex
Binary file not shown
View
382 stdlib/camlinternalFormat.ml
@@ -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)
-
- | 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)
+ 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), 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
View
22 stdlib/camlinternalFormat.mli
@@ -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
View
79 stdlib/camlinternalFormatBasics.ml
@@ -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
View
386 stdlib/camlinternalFormatBasics.mli
@@ -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
View
35 stdlib/format.ml
@@ -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 ());
View
23 stdlib/scanf.ml
@@ -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
View
36 typing/typecore.ml
@@ -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 ]
))
Please sign in to comment.
Something went wrong with that request. Please try again.