Revision a7062da6
Added by LĂ©lio Brun over 3 years ago
src/backends/Ada/ada_printer.ml | ||
---|---|---|
1 |
open Utils |
|
1 | 2 |
open Format |
2 | 3 |
|
3 | 4 |
(** Represent the possible mode for a type of a procedure parameter **) |
... | ... | |
78 | 79 |
(** Print the boolean type name. @param fmt the formater to print on **) |
79 | 80 |
let pp_boolean_type fmt = fprintf fmt "Boolean" |
80 | 81 |
|
81 |
let pp_group ~sep pp_list fmt = |
|
82 |
let pp_group ~pp_sep pp_list fmt =
|
|
82 | 83 |
assert (pp_list != []); |
83 |
fprintf fmt "@[%a@]" (Utils.fprintf_list ~sep (fun fmt pp -> pp fmt)) pp_list
|
|
84 |
fprintf fmt "@[%a@]" (pp_print_list ~pp_sep (fun fmt pp -> pp fmt)) pp_list
|
|
84 | 85 |
|
85 |
let pp_args ~sep fmt = function |
|
86 |
let pp_args ~pp_sep fmt = function
|
|
86 | 87 |
| [] -> |
87 | 88 |
fprintf fmt "" |
88 | 89 |
| args -> |
89 | 90 |
fprintf fmt " (@[<v>%a)@]" |
90 |
(Utils.fprintf_list ~sep (fun fmt pp -> pp fmt))
|
|
91 |
(pp_print_list ~pp_sep (fun fmt pp -> pp fmt))
|
|
91 | 92 |
args |
92 | 93 |
|
93 | 94 |
let pp_block fmt pp_item_list = |
94 |
fprintf fmt "%t@[<v>%a@]%t" |
|
95 |
(Utils.pp_final_char_if_non_empty " " pp_item_list) |
|
96 |
(Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) |
|
95 |
pp_print_list |
|
96 |
~pp_open_box:pp_open_vbox0 |
|
97 |
~pp_prologue:(fun fmt () -> pp_print_string fmt " ") |
|
98 |
~pp_epilogue:pp_print_semicolon |
|
99 |
~pp_sep:pp_print_semicolon (fun fmt pp -> pp fmt) |
|
100 |
fmt |
|
97 | 101 |
pp_item_list |
98 |
(Utils.pp_final_char_if_non_empty ";@," pp_item_list) |
|
99 | 102 |
|
100 |
let pp_and l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ and then " l) |
|
103 |
let pp_and l fmt = |
|
104 |
fprintf fmt "(%t)" (pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ and then ") l) |
|
101 | 105 |
|
102 |
let pp_or l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ or " l) |
|
106 |
let pp_or l fmt = |
|
107 |
fprintf fmt "(%t)" (pp_group ~pp_sep:(fun fmt () -> fprintf fmt "@ or ") l) |
|
103 | 108 |
|
104 | 109 |
let pp_ada_with fmt = function |
105 | 110 |
| None -> |
... | ... | |
117 | 122 |
let pp_import fmt = |
118 | 123 |
if not import then fprintf fmt "" |
119 | 124 |
else |
120 |
fprintf fmt " Import%t"
|
|
121 |
(Utils.pp_final_char_if_non_empty ",@," contract)
|
|
125 |
fprintf fmt " Import%a"
|
|
126 |
(if contract = [] then pp_print_nothing else pp_print_comma) ()
|
|
122 | 127 |
in |
123 | 128 |
let pp_aspect aspect fmt pps = |
124 | 129 |
if pps = [] then fprintf fmt "" |
... | ... | |
184 | 189 |
fprintf fmt " is@, @[<v 2>(%t)@]" pp_content |
185 | 190 |
| AdaProcedureContent (local_list, pp_instr_list) -> |
186 | 191 |
fprintf fmt " is@,%abegin@,%aend %t" pp_block |
187 |
(List.map (fun l -> pp_group ~sep:";@;" (List.map pp_local l)) local_list)
|
|
192 |
(List.map (fun l -> pp_group ~pp_sep:pp_print_semicolon (List.map pp_local l)) local_list)
|
|
188 | 193 |
pp_block pp_instr_list pp_name |
189 | 194 |
| AdaRecord var_list -> |
190 | 195 |
assert (var_list != []); |
191 | 196 |
let pp_lists = apply_var_decl_lists var_list in |
192 | 197 |
fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]" pp_block |
193 |
(List.map (pp_group ~sep:";@;") pp_lists)
|
|
198 |
(List.map (pp_group ~pp_sep:pp_print_semicolon) pp_lists)
|
|
194 | 199 |
| AdaPackageInstanciation (pp_name, instanciations) -> |
195 |
fprintf fmt " is new %t%a" pp_name (pp_args ~sep:",@,")
|
|
200 |
fprintf fmt " is new %t%a" pp_name (pp_args ~pp_sep:pp_print_comma)
|
|
196 | 201 |
(List.map pp_generic_instanciation instanciations) |
197 | 202 |
|
198 | 203 |
and pp_def fmt |
199 | 204 |
(pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) = |
200 | 205 |
let pp_arg_lists = apply_var_decl_lists args in |
201 | 206 |
fprintf fmt "%a%a %t%a%a%a%a" pp_generic pp_generics pp_kind_def kind_def |
202 |
pp_name (pp_args ~sep:";@,")
|
|
203 |
(List.map (pp_group ~sep:";@,") pp_arg_lists)
|
|
207 |
pp_name (pp_args ~pp_sep:pp_print_semicolon)
|
|
208 |
(List.map (pp_group ~pp_sep:pp_print_semicolon) pp_arg_lists)
|
|
204 | 209 |
(pp_opt "return") pp_type_opt (pp_content pp_name) content pp_ada_with |
205 | 210 |
pp_with_opt |
206 | 211 |
|
... | ... | |
387 | 392 |
fprintf fmt "-- %s@," s |
388 | 393 |
|
389 | 394 |
let pp_call fmt (pp_name, args) = |
390 |
fprintf fmt "%t%a" pp_name (pp_args ~sep:",@ ")
|
|
391 |
(List.map (pp_group ~sep:",@,") args)
|
|
395 |
fprintf fmt "%t%a" pp_name (pp_args ~pp_sep:pp_print_comma)
|
|
396 |
(List.map (pp_group ~pp_sep:pp_print_comma) args)
|
|
392 | 397 |
|
393 | 398 |
(** Print the complete name of variable. @param m the machine to check if it is |
394 | 399 |
memory @param fmt the formater to print on @param var the variable **) |
Also available in: Unified diff
another step towards refactoring