diff --git a/Changes b/Changes index 2abfe9720..c832c2eb0 100644 --- a/Changes +++ b/Changes @@ -240,6 +240,8 @@ Bug fixes: (Alain Frisch and Jacques Garrigue) - PR#6405: unsound interaction of -rectypes and GADTs (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 = ..." (Gabriel Scherer) - bound-checking bug in caml_string_{get,set}{16,32,64} diff --git a/boot/ocamlc b/boot/ocamlc index 9fafcf9e0..3e07b4a91 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 5f273c691..edeaf1ce4 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 801b469bd..f8605eb0d 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 2a7e3aeba..f28e05f18 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -115,6 +115,7 @@ fun ign fmt -> match ign with type ('b, 'c) acc_formatting_gen = | Acc_open_tag of ('b, 'c) acc + | Acc_open_box of ('b, 'c) acc (* Reversed list of printing atoms. *) (* 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. *) (* Also used by Printf and Scanf where formatting is not interpreted. *) let string_of_formatting_lit formatting_lit = match formatting_lit with - | Open_box (str, _, _) -> str | Close_box -> "@]" | Close_tag -> "@}" | 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 = fun formatting_gen -> match formatting_gen with | 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); fmtiter rest ign_flag; | Formatting_gen (fmting_gen, rest) -> + bprint_string_literal buf "@{"; bprint_string_literal buf (string_of_formatting_gen fmting_gen); 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 = fun formatting_gen -> match formatting_gen with | 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. *) 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 (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in 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. *) 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 = make_printf k koc (Acc_formatting_gen (acc, Acc_open_tag kacc)) rest in 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 -> 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 | Acc_formatting_lit (p, fmting_lit) -> let s = string_of_formatting_lit fmting_lit in - output_acc o p; - output_string o s; + 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 '>'; + output_acc o p; output_string o "@{"; output_acc o acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + output_acc o p; output_string o "@["; output_acc o acc'; | 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 @@ -1627,13 +1636,11 @@ let rec output_acc o acc = match acc with let rec bufput_acc b acc = match acc with | Acc_formatting_lit (p, fmting_lit) -> let s = string_of_formatting_lit fmting_lit in - bufput_acc b p; - Buffer.add_string b s; + 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 '>'; + bufput_acc b p; Buffer.add_string b "@{"; bufput_acc b acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + bufput_acc b p; Buffer.add_string b "@["; bufput_acc b acc'; | 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 @@ -1648,13 +1655,11 @@ let rec bufput_acc b acc = match acc with let rec strput_acc b acc = match acc with | Acc_formatting_lit (p, fmting_lit) -> let s = string_of_formatting_lit fmting_lit in - strput_acc b p; - Buffer.add_string b s; + 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 '>'; + strput_acc b p; Buffer.add_string b "@{"; strput_acc b acc'; + | Acc_formatting_gen (p, Acc_open_box acc') -> + strput_acc b p; Buffer.add_string b "@["; strput_acc b acc'; | 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 ()) @@ -1671,6 +1676,49 @@ let failwith_message (Format (fmt, _)) = let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in 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 *) @@ -2154,12 +2202,12 @@ let fmt_ebb_of_string str = else 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 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 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 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 = - fun str_ind end_ind -> - let next_ind, box_ty, indent = - try - 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)) + and check_open_box : type a b c d e f . (a, b, c, d, e, f) fmt -> unit = + fun fmt -> match fmt with + | String_literal (str, End_of_format) -> ( + try ignore (open_box_of_string str) with Failure _ -> + ((* Emit warning: invalid open box *)) + ) + | _ -> () - (* Try to read the optionnal after "@{". *) - and parse_open_tag : type e f . int -> int -> (_, _, e, f) fmt_ebb = - fun str_ind end_ind -> + (* Try to read the optionnal after "@{" or "@[". *) + and parse_tag : type e f . bool -> int -> int -> (_, _, e, f) fmt_ebb = + fun is_open_tag str_ind end_ind -> 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 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 sub_fmt = parse (str_ind + 1) ind in - Fmt_EBB (Formatting_gen (Open_tag (Format (sub_fmt, as_str)), fmt_rest)) + let Fmt_EBB sub_fmt = parse str_ind (ind + 1) in + 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 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)) + 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 after "@;". *) and parse_good_break : type e f . int -> int -> (_, _, e, f) fmt_ebb = diff --git a/stdlib/camlinternalFormat.mli b/stdlib/camlinternalFormat.mli index df4c0c0e7..728dc865a 100644 --- a/stdlib/camlinternalFormat.mli +++ b/stdlib/camlinternalFormat.mli @@ -20,6 +20,7 @@ val param_format_of_ignored_format : type ('b, 'c) acc_formatting_gen = | Acc_open_tag of ('b, 'c) acc + | Acc_open_box of ('b, 'c) acc and ('b, 'c) acc = | Acc_formatting_lit of ('b, 'c) acc * formatting_lit @@ -74,6 +75,8 @@ val string_of_fmtty : val string_of_fmt : ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -> string +val open_box_of_string : string -> int * block_type + val symm : ('a1, 'b1, 'c1, 'd1, 'e1, 'f1, 'a2, 'b2, 'c2, 'd2, 'e2, 'f2) fmtty_rel diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml index 47e661fe4..e51e4e2ce 100644 --- a/stdlib/camlinternalFormatBasics.ml +++ b/stdlib/camlinternalFormatBasics.ml @@ -211,7 +211,6 @@ type block_type = (* 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 (* @, | @ | @; | @;<> *) @@ -227,6 +226,8 @@ type formatting_lit = 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 + | Open_box : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> (* @[ *) + ('a, 'b, 'c, 'd, 'e, 'f) formatting_gen (***) diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli index 850bf6bc6..52f428ad8 100644 --- a/stdlib/camlinternalFormatBasics.mli +++ b/stdlib/camlinternalFormatBasics.mli @@ -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 formatting_lit = - | Open_box of string * block_type * int | Close_box | Close_tag | Break of string * int * int @@ -47,6 +46,8 @@ type formatting_lit = 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 + | 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 = ('a, 'b, 'c, 'd, 'e, 'f, diff --git a/stdlib/format.ml b/stdlib/format.ml index 7f9b959a2..55674d179 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -1058,6 +1058,17 @@ and set_tags = 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 @@ -1070,7 +1081,6 @@ open CamlinternalFormat (* Interpret a formatting entity on a formatter. *) 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_tag -> pp_close_tag ppf () | 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; | 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'); + pp_open_tag ppf (compute_tag output_acc acc') + | Acc_formatting_gen (p, Acc_open_box acc') -> + let () = output_acc ppf p in + let (indent, bty) = open_box_of_string (compute_tag output_acc acc') in + pp_open_box_gen ppf indent bty | 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; @@ -1129,11 +1139,11 @@ let rec strput_acc ppf acc = match acc with 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'); + pp_open_tag ppf (compute_tag strput_acc acc') + | Acc_formatting_gen (p, Acc_open_box acc') -> + let () = strput_acc ppf p in + let (indent, bty) = open_box_of_string (compute_tag strput_acc acc') in + pp_open_box_gen ppf indent bty | 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 ()); diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index b9592ae2b..c21de7248 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1035,7 +1035,7 @@ fun k fmt -> match fmt with | 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_box (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 @@ -1229,8 +1229,11 @@ fun ib fmt readers -> match fmt with 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 + check_char ib '@'; check_char ib '{'; + 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) -> let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in diff --git a/typing/typecore.ml b/typing/typecore.ml index 02d6e0208..ed4352fe9 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2758,16 +2758,7 @@ and type_format loc str env = 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 ] | Close_box -> mk_constr "Close_box" [] | Close_tag -> @@ -2793,6 +2784,8 @@ and type_format loc str env = fun fmting -> match fmting with | Open_tag (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 . (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> string -> Parsetree.expression = fun fmt str ->