PR#6418: support "@[<hov %d>" in the new format implementation (Benoît Vaugon)
The bootstrap procedure, as for commit trunk@14973 (see there for detailed build instructions), requires to first commit a temporary patch: > diff -Naur old/typing/typecore.ml new/typing/typecore.ml > --- old/typing/typecore.ml 2014-06-11 18:16:24.851647309 +0200 > +++ new/typing/typecore.ml 2014-06-11 18:15:50.075646418 +0200 > @@ -2758,16 +2758,9 @@ > let mk_int n = mk_cst (Const_int n) > and mk_string str = mk_cst (Const_string (str, None)) > and mk_char chr = mk_cst (Const_char chr) in > - let mk_block_type bty = match bty with > - | Pp_hbox -> mk_constr "Pp_hbox" [] > - | Pp_vbox -> mk_constr "Pp_vbox" [] > - | Pp_hvbox -> mk_constr "Pp_hvbox" [] > - | Pp_hovbox -> mk_constr "Pp_hovbox" [] > - | Pp_box -> mk_constr "Pp_box" [] > - | Pp_fits -> mk_constr "Pp_fits" [] in > 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 ] > + | Open_box _ -> > + assert false > | Close_box -> > mk_constr "Close_box" [] > | Close_tag -> > @@ -2950,6 +2943,19 @@ > mk_constr "Alpha" [ mk_fmt rest ] > | Theta rest -> > mk_constr "Theta" [ mk_fmt rest ] > + | Formatting_lit (Open_box (org, _bty, _idt), rest) -> > + mk_constr "Formatting_gen" [ > + mk_constr "Open_box" [ > + mk_constr "Format" [ > + mk_constr "String_literal" [ > + mk_string "<>"; > + mk_constr "End_of_format" []; > + ]; > + mk_string "@[<>"; > + ] > + ]; > + mk_fmt rest; > + ] > | Formatting_lit (fmting, rest) -> > mk_constr "Formatting_lit" [ mk_formatting_lit fmting; mk_fmt rest ] > | Formatting_gen (fmting, rest) -> git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14984 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
25b93e0823
commit
49d3f7b9f8
2
Changes
2
Changes
|
@ -240,6 +240,8 @@ Bug fixes:
|
||||||
(Alain Frisch and Jacques Garrigue)
|
(Alain Frisch and Jacques Garrigue)
|
||||||
- PR#6405: unsound interaction of -rectypes and GADTs
|
- PR#6405: unsound interaction of -rectypes and GADTs
|
||||||
(Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon)
|
(Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon)
|
||||||
|
- PR#6418: reimplement parametrized Format tags/indentation with GADTs
|
||||||
|
(Benoît Vaugon)
|
||||||
- fix -dsource printing of "external _pipe = ..."
|
- fix -dsource printing of "external _pipe = ..."
|
||||||
(Gabriel Scherer)
|
(Gabriel Scherer)
|
||||||
- bound-checking bug in caml_string_{get,set}{16,32,64}
|
- bound-checking bug in caml_string_{get,set}{16,32,64}
|
||||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamldep
BIN
boot/ocamldep
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -115,6 +115,7 @@ fun ign fmt -> match ign with
|
||||||
|
|
||||||
type ('b, 'c) acc_formatting_gen =
|
type ('b, 'c) acc_formatting_gen =
|
||||||
| Acc_open_tag of ('b, 'c) acc
|
| Acc_open_tag of ('b, 'c) acc
|
||||||
|
| Acc_open_box of ('b, 'c) acc
|
||||||
|
|
||||||
(* Reversed list of printing atoms. *)
|
(* Reversed list of printing atoms. *)
|
||||||
(* Used to accumulate printf arguments. *)
|
(* Used to accumulate printf arguments. *)
|
||||||
|
@ -435,7 +436,6 @@ let bprint_float_fmt buf ign_flag fconv pad prec =
|
||||||
(* Compute the literal string representation of a formatting_lit. *)
|
(* Compute the literal string representation of a formatting_lit. *)
|
||||||
(* Also used by Printf and Scanf where formatting is not interpreted. *)
|
(* Also used by Printf and Scanf where formatting is not interpreted. *)
|
||||||
let string_of_formatting_lit formatting_lit = match formatting_lit with
|
let string_of_formatting_lit formatting_lit = match formatting_lit with
|
||||||
| Open_box (str, _, _) -> str
|
|
||||||
| Close_box -> "@]"
|
| Close_box -> "@]"
|
||||||
| Close_tag -> "@}"
|
| Close_tag -> "@}"
|
||||||
| Break (str, _, _) -> str
|
| Break (str, _, _) -> str
|
||||||
|
@ -453,6 +453,7 @@ let string_of_formatting_gen : type a b c d e f .
|
||||||
(a, b, c, d, e, f) formatting_gen -> string =
|
(a, b, c, d, e, f) formatting_gen -> string =
|
||||||
fun formatting_gen -> match formatting_gen with
|
fun formatting_gen -> match formatting_gen with
|
||||||
| Open_tag (Format (_, str)) -> str
|
| Open_tag (Format (_, str)) -> str
|
||||||
|
| Open_box (Format (_, str)) -> str
|
||||||
|
|
||||||
(***)
|
(***)
|
||||||
|
|
||||||
|
@ -587,6 +588,7 @@ let bprint_fmt buf fmt =
|
||||||
bprint_string_literal buf (string_of_formatting_lit fmting_lit);
|
bprint_string_literal buf (string_of_formatting_lit fmting_lit);
|
||||||
fmtiter rest ign_flag;
|
fmtiter rest ign_flag;
|
||||||
| Formatting_gen (fmting_gen, rest) ->
|
| Formatting_gen (fmting_gen, rest) ->
|
||||||
|
bprint_string_literal buf "@{";
|
||||||
bprint_string_literal buf (string_of_formatting_gen fmting_gen);
|
bprint_string_literal buf (string_of_formatting_gen fmting_gen);
|
||||||
fmtiter rest ign_flag;
|
fmtiter rest ign_flag;
|
||||||
|
|
||||||
|
@ -802,6 +804,7 @@ let rec fmtty_of_formatting_gen : type a b c d e f .
|
||||||
(a, b, c, d, e, f) fmtty =
|
(a, b, c, d, e, f) fmtty =
|
||||||
fun formatting_gen -> match formatting_gen with
|
fun formatting_gen -> match formatting_gen with
|
||||||
| Open_tag (Format (fmt, _)) -> fmtty_of_fmt fmt
|
| Open_tag (Format (fmt, _)) -> fmtty_of_fmt fmt
|
||||||
|
| Open_box (Format (fmt, _)) -> fmtty_of_fmt fmt
|
||||||
|
|
||||||
(* Extract the type representation (an fmtty) of a format. *)
|
(* Extract the type representation (an fmtty) of a format. *)
|
||||||
and fmtty_of_fmt : type a b c d e f .
|
and fmtty_of_fmt : type a b c d e f .
|
||||||
|
@ -1073,6 +1076,10 @@ fun formatting_gen fmt0 fmtty0 -> match formatting_gen with
|
||||||
let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
|
let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in
|
||||||
let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 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)
|
Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3)
|
||||||
|
| Open_box (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. *)
|
(* 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 .
|
and type_ignored_param : type p q x y z t u v a b c d e f .
|
||||||
|
@ -1428,6 +1435,10 @@ fun k o acc fmt -> match fmt with
|
||||||
let k' koc kacc =
|
let k' koc kacc =
|
||||||
make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in
|
make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in
|
||||||
make_printf k' o End_of_acc fmt'
|
make_printf k' o End_of_acc fmt'
|
||||||
|
| Formatting_gen (Open_box (Format (fmt', _)), rest) ->
|
||||||
|
let k' koc kacc =
|
||||||
|
make_printf k koc (Acc_formatting_gen (acc, Acc_open_box kacc)) rest in
|
||||||
|
make_printf k' o End_of_acc fmt'
|
||||||
|
|
||||||
| End_of_format ->
|
| End_of_format ->
|
||||||
k o acc
|
k o acc
|
||||||
|
@ -1607,13 +1618,11 @@ and make_float_padding_precision : type x y a b c d e f .
|
||||||
let rec output_acc o acc = match acc with
|
let rec output_acc o acc = match acc with
|
||||||
| Acc_formatting_lit (p, fmting_lit) ->
|
| Acc_formatting_lit (p, fmting_lit) ->
|
||||||
let s = string_of_formatting_lit fmting_lit in
|
let s = string_of_formatting_lit fmting_lit in
|
||||||
output_acc o p;
|
output_acc o p; output_string o s;
|
||||||
output_string o s;
|
|
||||||
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
||||||
output_acc o p;
|
output_acc o p; output_string o "@{"; output_acc o acc';
|
||||||
output_string o "@{<";
|
| Acc_formatting_gen (p, Acc_open_box acc') ->
|
||||||
output_acc o 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_string (p, s) -> output_acc o p; output_string o s
|
||||||
| Acc_char (p, c) -> output_acc o p; output_char o c
|
| Acc_char (p, c) -> output_acc o p; output_char o c
|
||||||
| Acc_delay (p, f) -> output_acc o p; f o
|
| Acc_delay (p, f) -> output_acc o p; f o
|
||||||
|
@ -1627,13 +1636,11 @@ let rec output_acc o acc = match acc with
|
||||||
let rec bufput_acc b acc = match acc with
|
let rec bufput_acc b acc = match acc with
|
||||||
| Acc_formatting_lit (p, fmting_lit) ->
|
| Acc_formatting_lit (p, fmting_lit) ->
|
||||||
let s = string_of_formatting_lit fmting_lit in
|
let s = string_of_formatting_lit fmting_lit in
|
||||||
bufput_acc b p;
|
bufput_acc b p; Buffer.add_string b s;
|
||||||
Buffer.add_string b s;
|
|
||||||
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
||||||
bufput_acc b p;
|
bufput_acc b p; Buffer.add_string b "@{"; bufput_acc b acc';
|
||||||
Buffer.add_string b "@{<";
|
| Acc_formatting_gen (p, Acc_open_box acc') ->
|
||||||
bufput_acc b 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_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_char (p, c) -> bufput_acc b p; Buffer.add_char b c
|
||||||
| Acc_delay (p, f) -> bufput_acc b p; f b
|
| Acc_delay (p, f) -> bufput_acc b p; f b
|
||||||
|
@ -1648,13 +1655,11 @@ let rec bufput_acc b acc = match acc with
|
||||||
let rec strput_acc b acc = match acc with
|
let rec strput_acc b acc = match acc with
|
||||||
| Acc_formatting_lit (p, fmting_lit) ->
|
| Acc_formatting_lit (p, fmting_lit) ->
|
||||||
let s = string_of_formatting_lit fmting_lit in
|
let s = string_of_formatting_lit fmting_lit in
|
||||||
strput_acc b p;
|
strput_acc b p; Buffer.add_string b s;
|
||||||
Buffer.add_string b s;
|
|
||||||
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
||||||
strput_acc b p;
|
strput_acc b p; Buffer.add_string b "@{"; strput_acc b acc';
|
||||||
Buffer.add_string b "@{<";
|
| Acc_formatting_gen (p, Acc_open_box acc') ->
|
||||||
strput_acc b 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_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_char (p, c) -> strput_acc b p; Buffer.add_char b c
|
||||||
| Acc_delay (p, f) -> strput_acc b p; Buffer.add_string b (f ())
|
| Acc_delay (p, f) -> strput_acc b p; Buffer.add_string b (f ())
|
||||||
|
@ -1671,6 +1676,49 @@ let failwith_message (Format (fmt, _)) =
|
||||||
let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in
|
let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in
|
||||||
make_printf k () End_of_acc fmt
|
make_printf k () End_of_acc fmt
|
||||||
|
|
||||||
|
(******************************************************************************)
|
||||||
|
(* Formatting tools *)
|
||||||
|
|
||||||
|
(* Convert a string to an open block description (indent, block_type) *)
|
||||||
|
let open_box_of_string str =
|
||||||
|
if str = "" then (0, Pp_box) else
|
||||||
|
let len = String.length str in
|
||||||
|
let invalid_box () = failwith_message "invalid box description %S" str in
|
||||||
|
let rec parse_spaces i =
|
||||||
|
if i = len then i else
|
||||||
|
match str.[i] with
|
||||||
|
| ' ' | '\t' -> parse_spaces (i + 1)
|
||||||
|
| _ -> i
|
||||||
|
and parse_lword i j =
|
||||||
|
if j = len then j else
|
||||||
|
match str.[j] with
|
||||||
|
| 'a' .. 'z' -> parse_lword i (j + 1)
|
||||||
|
| _ -> j
|
||||||
|
and parse_int i j =
|
||||||
|
if j = len then j else
|
||||||
|
match str.[j] with
|
||||||
|
| '0' .. '9' | '-' -> parse_int i (j + 1)
|
||||||
|
| _ -> j in
|
||||||
|
let wstart = parse_spaces 0 in
|
||||||
|
let wend = parse_lword wstart wstart in
|
||||||
|
let box_name = String.sub str wstart (wend - wstart) in
|
||||||
|
let nstart = parse_spaces wend in
|
||||||
|
let nend = parse_int nstart nstart in
|
||||||
|
let indent =
|
||||||
|
if nstart = nend then 0 else
|
||||||
|
try int_of_string (String.sub str nstart (nend - nstart))
|
||||||
|
with Failure _ -> invalid_box () in
|
||||||
|
let exp_end = parse_spaces nend in
|
||||||
|
let () = if exp_end <> len then invalid_box () in
|
||||||
|
let box_type = match box_name with
|
||||||
|
| "" | "b" -> Pp_box
|
||||||
|
| "h" -> Pp_hbox
|
||||||
|
| "v" -> Pp_vbox
|
||||||
|
| "hv" -> Pp_hvbox
|
||||||
|
| "hov" -> Pp_hovbox
|
||||||
|
| _ -> invalid_box () in
|
||||||
|
(indent, box_type)
|
||||||
|
|
||||||
(******************************************************************************)
|
(******************************************************************************)
|
||||||
(* Parsing tools *)
|
(* Parsing tools *)
|
||||||
|
|
||||||
|
@ -2154,12 +2202,12 @@ let fmt_ebb_of_string str =
|
||||||
else
|
else
|
||||||
match str.[str_ind] with
|
match str.[str_ind] with
|
||||||
| '[' ->
|
| '[' ->
|
||||||
parse_open_box (str_ind + 1) end_ind
|
parse_tag false (str_ind + 1) end_ind
|
||||||
| ']' ->
|
| ']' ->
|
||||||
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
||||||
Fmt_EBB (Formatting_lit (Close_box, fmt_rest))
|
Fmt_EBB (Formatting_lit (Close_box, fmt_rest))
|
||||||
| '{' ->
|
| '{' ->
|
||||||
parse_open_tag (str_ind + 1) end_ind
|
parse_tag true (str_ind + 1) end_ind
|
||||||
| '}' ->
|
| '}' ->
|
||||||
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
||||||
Fmt_EBB (Formatting_lit (Close_tag, fmt_rest))
|
Fmt_EBB (Formatting_lit (Close_tag, fmt_rest))
|
||||||
|
@ -2195,66 +2243,39 @@ let fmt_ebb_of_string str =
|
||||||
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
let Fmt_EBB fmt_rest = parse (str_ind + 1) end_ind in
|
||||||
Fmt_EBB (Formatting_lit (Scan_indic c, fmt_rest))
|
Fmt_EBB (Formatting_lit (Scan_indic c, fmt_rest))
|
||||||
|
|
||||||
(* Try to read the optionnal <...> after "@[". *)
|
and check_open_box : type a b c d e f . (a, b, c, d, e, f) fmt -> unit =
|
||||||
and parse_open_box : type e f . int -> int -> (_, _, e, f) fmt_ebb =
|
fun fmt -> match fmt with
|
||||||
fun str_ind end_ind ->
|
| String_literal (str, End_of_format) -> (
|
||||||
let next_ind, box_ty, indent =
|
try ignore (open_box_of_string str) with Failure _ ->
|
||||||
try
|
((* Emit warning: invalid open box *))
|
||||||
if str_ind = end_ind then raise Not_found;
|
)
|
||||||
match str.[str_ind] with
|
| _ -> ()
|
||||||
| '<' -> (
|
|
||||||
let str_ind_1 = parse_spaces (str_ind + 1) end_ind in
|
|
||||||
let i = ref str_ind_1 in
|
|
||||||
while !i < end_ind && str.[!i] >= 'a' && str.[!i] <= 'z' do
|
|
||||||
incr i;
|
|
||||||
done;
|
|
||||||
let box_ty = match String.sub str str_ind_1 (!i - str_ind_1) with
|
|
||||||
| "" -> Pp_box
|
|
||||||
| "b" -> Pp_box
|
|
||||||
| "h" -> Pp_hbox
|
|
||||||
| "v" -> Pp_vbox
|
|
||||||
| "hv" -> Pp_hvbox
|
|
||||||
| "hov" -> Pp_hovbox
|
|
||||||
| _ -> raise Not_found
|
|
||||||
in
|
|
||||||
let str_ind_3 = parse_spaces !i end_ind in
|
|
||||||
match str.[str_ind_3] with
|
|
||||||
| '0' .. '9' | '-' ->
|
|
||||||
let str_ind_4, indent = parse_integer str_ind_3 end_ind in
|
|
||||||
let str_ind_5 = parse_spaces str_ind_4 end_ind in
|
|
||||||
if str.[str_ind_5] <> '>' then raise Not_found;
|
|
||||||
str_ind_5 + 1, box_ty, indent
|
|
||||||
| '>' ->
|
|
||||||
str_ind_3 + 1, box_ty, 0
|
|
||||||
| _ ->
|
|
||||||
raise Not_found
|
|
||||||
)
|
|
||||||
| _ -> raise Not_found
|
|
||||||
with Not_found | Failure _ ->
|
|
||||||
str_ind, Pp_box, 0
|
|
||||||
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_lit (Open_box (s, box_ty, indent), fmt_rest))
|
|
||||||
|
|
||||||
(* Try to read the optionnal <name> after "@{". *)
|
(* Try to read the optionnal <name> after "@{" or "@[". *)
|
||||||
and parse_open_tag : type e f . int -> int -> (_, _, e, f) fmt_ebb =
|
and parse_tag : type e f . bool -> int -> int -> (_, _, e, f) fmt_ebb =
|
||||||
fun str_ind end_ind ->
|
fun is_open_tag str_ind end_ind ->
|
||||||
try
|
try
|
||||||
if str_ind = end_ind then raise Not_found;
|
if str_ind = end_ind then raise Not_found;
|
||||||
match str.[str_ind] with
|
match str.[str_ind] with
|
||||||
| '<' ->
|
| '<' ->
|
||||||
let ind = String.index_from str (str_ind + 1) '>' in
|
let ind = String.index_from str (str_ind + 1) '>' in
|
||||||
if ind >= end_ind then raise Not_found;
|
if ind >= end_ind then raise Not_found;
|
||||||
let as_str = String.sub str (str_ind + 1) (ind - str_ind - 1) in
|
let sub_str = String.sub str str_ind (ind - str_ind + 1) in
|
||||||
let Fmt_EBB fmt_rest = parse (ind + 1) end_ind in
|
let Fmt_EBB fmt_rest = parse (ind + 1) end_ind in
|
||||||
let Fmt_EBB sub_fmt = parse (str_ind + 1) ind in
|
let Fmt_EBB sub_fmt = parse str_ind (ind + 1) in
|
||||||
Fmt_EBB (Formatting_gen (Open_tag (Format (sub_fmt, as_str)), fmt_rest))
|
let sub_format = Format (sub_fmt, sub_str) in
|
||||||
|
let formatting = if is_open_tag then Open_tag sub_format else (
|
||||||
|
check_open_box sub_fmt;
|
||||||
|
Open_box sub_format) in
|
||||||
|
Fmt_EBB (Formatting_gen (formatting, fmt_rest))
|
||||||
| _ ->
|
| _ ->
|
||||||
raise Not_found
|
raise Not_found
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
let Fmt_EBB fmt_rest = parse str_ind end_ind in
|
let Fmt_EBB fmt_rest = parse str_ind end_ind in
|
||||||
Fmt_EBB (Formatting_gen (Open_tag (Format (End_of_format, "")), fmt_rest))
|
let sub_format = Format (End_of_format, "") in
|
||||||
|
let formatting =
|
||||||
|
if is_open_tag then Open_tag sub_format else Open_box sub_format in
|
||||||
|
Fmt_EBB (Formatting_gen (formatting, fmt_rest))
|
||||||
|
|
||||||
(* Try to read the optionnal <width offset> after "@;". *)
|
(* Try to read the optionnal <width offset> after "@;". *)
|
||||||
and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb =
|
and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb =
|
||||||
|
|
|
@ -20,6 +20,7 @@ val param_format_of_ignored_format :
|
||||||
|
|
||||||
type ('b, 'c) acc_formatting_gen =
|
type ('b, 'c) acc_formatting_gen =
|
||||||
| Acc_open_tag of ('b, 'c) acc
|
| Acc_open_tag of ('b, 'c) acc
|
||||||
|
| Acc_open_box of ('b, 'c) acc
|
||||||
|
|
||||||
and ('b, 'c) acc =
|
and ('b, 'c) acc =
|
||||||
| Acc_formatting_lit of ('b, 'c) acc * formatting_lit
|
| Acc_formatting_lit of ('b, 'c) acc * formatting_lit
|
||||||
|
@ -74,6 +75,8 @@ val string_of_fmtty :
|
||||||
val string_of_fmt :
|
val string_of_fmt :
|
||||||
('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> string
|
('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> string
|
||||||
|
|
||||||
|
val open_box_of_string : string -> int * block_type
|
||||||
|
|
||||||
val symm :
|
val symm :
|
||||||
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
|
('a1, 'b1, 'c1, 'd1, 'e1, 'f1,
|
||||||
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
|
'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel
|
||||||
|
|
|
@ -211,7 +211,6 @@ type block_type =
|
||||||
|
|
||||||
(* Formatting element used by the Format pretty-printter. *)
|
(* Formatting element used by the Format pretty-printter. *)
|
||||||
type formatting_lit =
|
type formatting_lit =
|
||||||
| Open_box of string * block_type * int (* @[ *)
|
|
||||||
| Close_box (* @] *)
|
| Close_box (* @] *)
|
||||||
| Close_tag (* @} *)
|
| Close_tag (* @} *)
|
||||||
| Break of string * int * int (* @, | @ | @; | @;<> *)
|
| Break of string * int * int (* @, | @ | @; | @;<> *)
|
||||||
|
@ -227,6 +226,8 @@ type formatting_lit =
|
||||||
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
|
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
|
||||||
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @{ *)
|
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @{ *)
|
||||||
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
||||||
|
| Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @[ *)
|
||||||
|
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
||||||
|
|
||||||
(***)
|
(***)
|
||||||
|
|
||||||
|
|
|
@ -32,7 +32,6 @@ type prec_option = int option
|
||||||
type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
|
type block_type = Pp_hbox | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits
|
||||||
|
|
||||||
type formatting_lit =
|
type formatting_lit =
|
||||||
| Open_box of string * block_type * int
|
|
||||||
| Close_box
|
| Close_box
|
||||||
| Close_tag
|
| Close_tag
|
||||||
| Break of string * int * int
|
| Break of string * int * int
|
||||||
|
@ -47,6 +46,8 @@ type formatting_lit =
|
||||||
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
|
type ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen =
|
||||||
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
|
| Open_tag : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
|
||||||
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
||||||
|
| Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 ->
|
||||||
|
('a, 'b, 'c, 'd, 'e, 'f) formatting_gen
|
||||||
|
|
||||||
and ('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,
|
||||||
|
|
|
@ -1058,6 +1058,17 @@ and set_tags =
|
||||||
pp_set_tags std_formatter
|
pp_set_tags std_formatter
|
||||||
;;
|
;;
|
||||||
|
|
||||||
|
(**************************************************************)
|
||||||
|
|
||||||
|
let compute_tag output tag_acc =
|
||||||
|
let buf = Buffer.create 16 in
|
||||||
|
let ppf = formatter_of_buffer buf in
|
||||||
|
let () = output ppf tag_acc in
|
||||||
|
let () = pp_print_flush ppf () in
|
||||||
|
let len = Buffer.length buf in
|
||||||
|
if len < 2 then Buffer.contents buf
|
||||||
|
else Buffer.sub buf 1 (len - 2)
|
||||||
|
|
||||||
(**************************************************************
|
(**************************************************************
|
||||||
|
|
||||||
Defining continuations to be passed as arguments of
|
Defining continuations to be passed as arguments of
|
||||||
|
@ -1070,7 +1081,6 @@ open CamlinternalFormat
|
||||||
|
|
||||||
(* Interpret a formatting entity on a formatter. *)
|
(* Interpret a formatting entity on a formatter. *)
|
||||||
let output_formatting_lit ppf fmting_lit = match fmting_lit 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 ()
|
| Close_box -> pp_close_box ppf ()
|
||||||
| Close_tag -> pp_close_tag ppf ()
|
| Close_tag -> pp_close_tag ppf ()
|
||||||
| Break (_, width, offset) -> pp_print_break ppf width offset
|
| Break (_, width, offset) -> pp_print_break ppf width offset
|
||||||
|
@ -1098,11 +1108,11 @@ let rec output_acc ppf acc = match acc with
|
||||||
output_formatting_lit ppf f;
|
output_formatting_lit ppf f;
|
||||||
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
||||||
output_acc ppf p;
|
output_acc ppf p;
|
||||||
let buf' = Buffer.create 16 in
|
pp_open_tag ppf (compute_tag output_acc acc')
|
||||||
let ppf' = formatter_of_buffer buf' in
|
| Acc_formatting_gen (p, Acc_open_box acc') ->
|
||||||
output_acc ppf' acc';
|
let () = output_acc ppf p in
|
||||||
pp_print_flush ppf' ();
|
let (indent, bty) = open_box_of_string (compute_tag output_acc acc') in
|
||||||
pp_open_tag ppf (Buffer.contents buf');
|
pp_open_box_gen ppf indent bty
|
||||||
| Acc_string (p, s) -> output_acc ppf p; pp_print_string ppf s;
|
| 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_char (p, c) -> output_acc ppf p; pp_print_char ppf c;
|
||||||
| Acc_delay (p, f) -> output_acc ppf p; f ppf;
|
| Acc_delay (p, f) -> output_acc ppf p; f ppf;
|
||||||
|
@ -1129,11 +1139,11 @@ let rec strput_acc ppf acc = match acc with
|
||||||
output_formatting_lit ppf f;
|
output_formatting_lit ppf f;
|
||||||
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
| Acc_formatting_gen (p, Acc_open_tag acc') ->
|
||||||
strput_acc ppf p;
|
strput_acc ppf p;
|
||||||
let buf' = Buffer.create 16 in
|
pp_open_tag ppf (compute_tag strput_acc acc')
|
||||||
let ppf' = formatter_of_buffer buf' in
|
| Acc_formatting_gen (p, Acc_open_box acc') ->
|
||||||
strput_acc ppf' acc';
|
let () = strput_acc ppf p in
|
||||||
pp_print_flush ppf' ();
|
let (indent, bty) = open_box_of_string (compute_tag strput_acc acc') in
|
||||||
pp_open_tag ppf (Buffer.contents buf');
|
pp_open_box_gen ppf indent bty
|
||||||
| Acc_string (p, s) -> strput_acc ppf p; pp_print_string ppf s;
|
| 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_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 ());
|
| Acc_delay (p, f) -> strput_acc ppf p; pp_print_string ppf (f ());
|
||||||
|
|
|
@ -1035,7 +1035,7 @@ fun k fmt -> match fmt with
|
||||||
|
|
||||||
| Formatting_lit (_, 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)
|
| Formatting_gen (Open_tag (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest)
|
||||||
|
| Formatting_gen (Open_box (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest)
|
||||||
|
|
||||||
| Format_arg (_, _, rest) -> take_format_readers k rest
|
| Format_arg (_, _, rest) -> take_format_readers k rest
|
||||||
| Format_subst (_, fmtty, rest) -> take_fmtty_format_readers k (erase_rel (symm fmtty)) rest
|
| Format_subst (_, fmtty, rest) -> take_fmtty_format_readers k (erase_rel (symm fmtty)) rest
|
||||||
|
@ -1229,8 +1229,11 @@ fun ib fmt readers -> match fmt with
|
||||||
String.iter (check_char ib) (string_of_formatting_lit formatting_lit);
|
String.iter (check_char ib) (string_of_formatting_lit formatting_lit);
|
||||||
make_scanf ib rest readers
|
make_scanf ib rest readers
|
||||||
| Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
|
| Formatting_gen (Open_tag (Format (fmt', _)), rest) ->
|
||||||
check_char ib '@'; check_char ib '{'; check_char ib '<';
|
check_char ib '@'; check_char ib '{';
|
||||||
make_scanf ib (concat_fmt fmt' (Char_literal ('<', rest))) readers
|
make_scanf ib (concat_fmt fmt' rest) readers
|
||||||
|
| Formatting_gen (Open_box (Format (fmt', _)), rest) ->
|
||||||
|
check_char ib '@'; check_char ib '[';
|
||||||
|
make_scanf ib (concat_fmt fmt' rest) readers
|
||||||
|
|
||||||
| Ignored_param (ign, rest) ->
|
| Ignored_param (ign, rest) ->
|
||||||
let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
|
let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in
|
||||||
|
|
|
@ -2758,16 +2758,7 @@ and type_format loc str env =
|
||||||
let mk_int n = mk_cst (Const_int n)
|
let mk_int n = mk_cst (Const_int n)
|
||||||
and mk_string str = mk_cst (Const_string (str, None))
|
and mk_string str = mk_cst (Const_string (str, None))
|
||||||
and mk_char chr = mk_cst (Const_char chr) in
|
and mk_char chr = mk_cst (Const_char chr) in
|
||||||
let mk_block_type bty = match bty with
|
|
||||||
| Pp_hbox -> mk_constr "Pp_hbox" []
|
|
||||||
| Pp_vbox -> mk_constr "Pp_vbox" []
|
|
||||||
| Pp_hvbox -> mk_constr "Pp_hvbox" []
|
|
||||||
| Pp_hovbox -> mk_constr "Pp_hovbox" []
|
|
||||||
| Pp_box -> mk_constr "Pp_box" []
|
|
||||||
| Pp_fits -> mk_constr "Pp_fits" [] in
|
|
||||||
let rec mk_formatting_lit 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 ->
|
| Close_box ->
|
||||||
mk_constr "Close_box" []
|
mk_constr "Close_box" []
|
||||||
| Close_tag ->
|
| Close_tag ->
|
||||||
|
@ -2793,6 +2784,8 @@ and type_format loc str env =
|
||||||
fun fmting -> match fmting with
|
fun fmting -> match fmting with
|
||||||
| Open_tag (Format (fmt', str')) ->
|
| Open_tag (Format (fmt', str')) ->
|
||||||
mk_constr "Open_tag" [ mk_format fmt' str' ]
|
mk_constr "Open_tag" [ mk_format fmt' str' ]
|
||||||
|
| Open_box (Format (fmt', str')) ->
|
||||||
|
mk_constr "Open_box" [ mk_format fmt' str' ]
|
||||||
and mk_format : type a b c d e f .
|
and mk_format : type a b c d e f .
|
||||||
(a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
|
(a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string ->
|
||||||
Parsetree.expression = fun fmt str ->
|
Parsetree.expression = fun fmt str ->
|
||||||
|
|
Loading…
Reference in New Issue