Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/backends/Ada/ada_printer.ml | ||
---|---|---|
3 | 3 |
(** Represent the possible mode for a type of a procedure parameter **) |
4 | 4 |
type parameter_mode = AdaNoMode | AdaIn | AdaOut | AdaInOut |
5 | 5 |
|
6 |
type kind_def = AdaType | AdaProcedure | AdaFunction | AdaPackageDecl | AdaPackageBody |
|
6 |
type kind_def = |
|
7 |
| AdaType |
|
8 |
| AdaProcedure |
|
9 |
| AdaFunction |
|
10 |
| AdaPackageDecl |
|
11 |
| AdaPackageBody |
|
7 | 12 |
|
8 | 13 |
type visibility = AdaNoVisibility | AdaPrivate | AdaLimitedPrivate |
9 | 14 |
|
10 | 15 |
type printer = Format.formatter -> unit |
11 | 16 |
|
12 |
type ada_with = (bool * bool * (printer list) * (printer list)) option
|
|
17 |
type ada_with = (bool * bool * printer list * printer list) option
|
|
13 | 18 |
|
14 | 19 |
type ada_var_decl = parameter_mode * printer * printer * ada_with |
15 | 20 |
|
16 | 21 |
type ada_local_decl = |
17 | 22 |
| AdaLocalVar of ada_var_decl |
18 |
| AdaLocalPackage of (printer * printer * ((printer*printer) list))
|
|
23 |
| AdaLocalPackage of (printer * printer * (printer * printer) list)
|
|
19 | 24 |
|
20 | 25 |
type def_content = |
21 | 26 |
| AdaNoContent |
22 | 27 |
| AdaPackageContent of printer |
23 | 28 |
| AdaSimpleContent of printer |
24 | 29 |
| AdaVisibilityDefinition of visibility |
25 |
| AdaProcedureContent of ((ada_local_decl list list) * (printer list))
|
|
26 |
| AdaRecord of ((ada_var_decl list) list)
|
|
30 |
| AdaProcedureContent of (ada_local_decl list list * printer list)
|
|
31 |
| AdaRecord of ada_var_decl list list
|
|
27 | 32 |
| AdaPackageInstanciation of (printer * (printer * printer) list) |
28 | 33 |
|
29 |
(** Print a parameter_mode. |
|
30 |
@param fmt the formater to print on |
|
31 |
@param mode the modifier |
|
32 |
**) |
|
34 |
(** Print a parameter_mode. @param fmt the formater to print on @param mode the |
|
35 |
modifier **) |
|
33 | 36 |
let pp_parameter_mode fmt mode = |
34 |
fprintf fmt "%s" (match mode with |
|
35 |
| AdaNoMode -> "" |
|
36 |
| AdaIn -> "in" |
|
37 |
| AdaOut -> "out" |
|
38 |
| AdaInOut -> "in out") |
|
37 |
fprintf fmt "%s" |
|
38 |
(match mode with |
|
39 |
| AdaNoMode -> |
|
40 |
"" |
|
41 |
| AdaIn -> |
|
42 |
"in" |
|
43 |
| AdaOut -> |
|
44 |
"out" |
|
45 |
| AdaInOut -> |
|
46 |
"in out") |
|
39 | 47 |
|
40 | 48 |
let pp_kind_def fmt kind_def = |
41 |
fprintf fmt "%s" (match kind_def with |
|
42 |
| AdaType -> "type" |
|
43 |
| AdaProcedure -> "procedure" |
|
44 |
| AdaFunction -> "function" |
|
45 |
| AdaPackageDecl -> "package" |
|
46 |
| AdaPackageBody -> "package body") |
|
49 |
fprintf fmt "%s" |
|
50 |
(match kind_def with |
|
51 |
| AdaType -> |
|
52 |
"type" |
|
53 |
| AdaProcedure -> |
|
54 |
"procedure" |
|
55 |
| AdaFunction -> |
|
56 |
"function" |
|
57 |
| AdaPackageDecl -> |
|
58 |
"package" |
|
59 |
| AdaPackageBody -> |
|
60 |
"package body") |
|
47 | 61 |
|
48 | 62 |
let pp_visibility fmt visibility = |
49 |
fprintf fmt "%s" (match visibility with |
|
50 |
| AdaNoVisibility -> "" |
|
51 |
| AdaPrivate -> "private" |
|
52 |
| AdaLimitedPrivate -> "limited private") |
|
53 |
|
|
54 |
(** Print the integer type name. |
|
55 |
@param fmt the formater to print on |
|
56 |
**) |
|
63 |
fprintf fmt "%s" |
|
64 |
(match visibility with |
|
65 |
| AdaNoVisibility -> |
|
66 |
"" |
|
67 |
| AdaPrivate -> |
|
68 |
"private" |
|
69 |
| AdaLimitedPrivate -> |
|
70 |
"limited private") |
|
71 |
|
|
72 |
(** Print the integer type name. @param fmt the formater to print on **) |
|
57 | 73 |
let pp_integer_type fmt = fprintf fmt "Integer" |
58 | 74 |
|
59 |
(** Print the float type name. |
|
60 |
@param fmt the formater to print on |
|
61 |
**) |
|
75 |
(** Print the float type name. @param fmt the formater to print on **) |
|
62 | 76 |
let pp_float_type fmt = fprintf fmt "Float" |
63 | 77 |
|
64 |
(** Print the boolean type name. |
|
65 |
@param fmt the formater to print on |
|
66 |
**) |
|
78 |
(** Print the boolean type name. @param fmt the formater to print on **) |
|
67 | 79 |
let pp_boolean_type fmt = fprintf fmt "Boolean" |
68 | 80 |
|
69 |
let pp_group ~sep:sep pp_list fmt = |
|
70 |
assert(pp_list != []); |
|
71 |
fprintf fmt "@[%a@]" |
|
72 |
(Utils.fprintf_list ~sep:sep (fun fmt pp->pp fmt)) pp_list |
|
81 |
let pp_group ~sep pp_list fmt = |
|
82 |
assert (pp_list != []); |
|
83 |
fprintf fmt "@[%a@]" (Utils.fprintf_list ~sep (fun fmt pp -> pp fmt)) pp_list |
|
73 | 84 |
|
74 |
let pp_args ~sep:sep fmt = function |
|
75 |
| [] -> fprintf fmt "" |
|
76 |
| args -> fprintf fmt " (@[<v>%a)@]" (Utils.fprintf_list ~sep:sep (fun fmt pp->pp fmt)) args |
|
85 |
let pp_args ~sep fmt = function |
|
86 |
| [] -> |
|
87 |
fprintf fmt "" |
|
88 |
| args -> |
|
89 |
fprintf fmt " (@[<v>%a)@]" |
|
90 |
(Utils.fprintf_list ~sep (fun fmt pp -> pp fmt)) |
|
91 |
args |
|
77 | 92 |
|
78 | 93 |
let pp_block fmt pp_item_list = |
79 | 94 |
fprintf fmt "%t@[<v>%a@]%t" |
80 | 95 |
(Utils.pp_final_char_if_non_empty " " pp_item_list) |
81 |
(Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) pp_item_list |
|
96 |
(Utils.fprintf_list ~sep:";@," (fun fmt pp -> pp fmt)) |
|
97 |
pp_item_list |
|
82 | 98 |
(Utils.pp_final_char_if_non_empty ";@," pp_item_list) |
83 | 99 |
|
84 | 100 |
let pp_and l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ and then " l) |
101 |
|
|
85 | 102 |
let pp_or l fmt = fprintf fmt "(%t)" (pp_group ~sep:"@ or " l) |
86 | 103 |
|
87 | 104 |
let pp_ada_with fmt = function |
88 |
| None -> fprintf fmt "" |
|
105 |
| None -> |
|
106 |
fprintf fmt "" |
|
89 | 107 |
| Some (ghost, import, pres, posts) -> |
90 |
assert(ghost || import || (pres != []) || (posts != [])); |
|
91 |
let contract = pres@posts in |
|
92 |
let pp_ghost fmt = if not ghost then fprintf fmt "" else |
|
93 |
fprintf fmt " Ghost%t" (fun fmt -> if (contract != []) || import then fprintf fmt ",@," else fprintf fmt "") |
|
94 |
in |
|
95 |
let pp_import fmt = if not import then fprintf fmt "" else |
|
96 |
fprintf fmt " Import%t" (Utils.pp_final_char_if_non_empty ",@," contract) |
|
97 |
in |
|
98 |
let pp_aspect aspect fmt pps = if pps = [] then fprintf fmt "" else |
|
99 |
fprintf fmt "%s => %t" aspect (pp_and pps) |
|
100 |
in |
|
101 |
let pp_contract fmt = if contract = [] then fprintf fmt "" else |
|
102 |
let sep fmt = if pres != [] && posts != [] then fprintf fmt ",@," else fprintf fmt "" in |
|
103 |
fprintf fmt "@, @[<v>%a%t%a@]" |
|
104 |
(pp_aspect "Pre") pres |
|
105 |
sep |
|
108 |
assert (ghost || import || pres != [] || posts != []); |
|
109 |
let contract = pres @ posts in |
|
110 |
let pp_ghost fmt = |
|
111 |
if not ghost then fprintf fmt "" |
|
112 |
else |
|
113 |
fprintf fmt " Ghost%t" (fun fmt -> |
|
114 |
if contract != [] || import then fprintf fmt ",@," |
|
115 |
else fprintf fmt "") |
|
116 |
in |
|
117 |
let pp_import fmt = |
|
118 |
if not import then fprintf fmt "" |
|
119 |
else |
|
120 |
fprintf fmt " Import%t" |
|
121 |
(Utils.pp_final_char_if_non_empty ",@," contract) |
|
122 |
in |
|
123 |
let pp_aspect aspect fmt pps = |
|
124 |
if pps = [] then fprintf fmt "" |
|
125 |
else fprintf fmt "%s => %t" aspect (pp_and pps) |
|
126 |
in |
|
127 |
let pp_contract fmt = |
|
128 |
if contract = [] then fprintf fmt "" |
|
129 |
else |
|
130 |
let sep fmt = |
|
131 |
if pres != [] && posts != [] then fprintf fmt ",@," |
|
132 |
else fprintf fmt "" |
|
133 |
in |
|
134 |
fprintf fmt "@, @[<v>%a%t%a@]" (pp_aspect "Pre") pres sep |
|
106 | 135 |
(pp_aspect "Post") posts |
107 |
in |
|
108 |
fprintf fmt " with%t%t%t" |
|
109 |
pp_ghost |
|
110 |
pp_import |
|
111 |
pp_contract |
|
112 |
|
|
113 |
(** Print instanciation of a generic type in a new statement. |
|
114 |
@param fmt the formater to print on |
|
115 |
@param id id of the polymorphic type |
|
116 |
@param typ the new type |
|
117 |
**) |
|
136 |
in |
|
137 |
fprintf fmt " with%t%t%t" pp_ghost pp_import pp_contract |
|
138 |
|
|
139 |
(** Print instanciation of a generic type in a new statement. @param fmt the |
|
140 |
formater to print on @param id id of the polymorphic type @param typ the new |
|
141 |
type **) |
|
118 | 142 |
let pp_generic_instanciation (pp_name, pp_type) fmt = |
119 | 143 |
fprintf fmt "%t => %t" pp_name pp_type |
120 | 144 |
|
121 |
(** Print a variable declaration with mode |
|
122 |
@param mode input/output mode of the parameter |
|
123 |
@param pp_name a format printer wich print the variable name |
|
124 |
@param pp_type a format printer wich print the variable type |
|
125 |
@param fmt the formater to print on |
|
126 |
@param id the variable |
|
127 |
**) |
|
145 |
(** Print a variable declaration with mode @param mode input/output mode of the |
|
146 |
parameter @param pp_name a format printer wich print the variable name |
|
147 |
@param pp_type a format printer wich print the variable type @param fmt the |
|
148 |
formater to print on @param id the variable **) |
|
128 | 149 |
let pp_var_decl (mode, pp_name, pp_type, with_statement) fmt = |
129 |
fprintf fmt "%t: %a%s%t%a" |
|
130 |
pp_name |
|
131 |
pp_parameter_mode mode |
|
150 |
fprintf fmt "%t: %a%s%t%a" pp_name pp_parameter_mode mode |
|
132 | 151 |
(if mode = AdaNoMode then "" else " ") |
133 |
pp_type |
|
134 |
pp_ada_with with_statement |
|
152 |
pp_type pp_ada_with with_statement |
|
135 | 153 |
|
136 | 154 |
let apply_var_decl_lists var_list = |
137 |
List.map (fun l-> List.map pp_var_decl l) var_list |
|
155 |
List.map (fun l -> List.map pp_var_decl l) var_list
|
|
138 | 156 |
|
139 | 157 |
let pp_generic fmt = function |
140 |
| [] -> fprintf fmt "" |
|
141 |
| l -> fprintf fmt "generic@,%a" pp_block l |
|
158 |
| [] -> |
|
159 |
fprintf fmt "" |
|
160 |
| l -> |
|
161 |
fprintf fmt "generic@,%a" pp_block l |
|
142 | 162 |
|
143 | 163 |
let pp_opt intro fmt = function |
144 |
| None -> fprintf fmt "" |
|
145 |
| Some pp -> fprintf fmt " %s %t" intro pp |
|
164 |
| None -> |
|
165 |
fprintf fmt "" |
|
166 |
| Some pp -> |
|
167 |
fprintf fmt " %s %t" intro pp |
|
146 | 168 |
|
147 | 169 |
let rec pp_local local fmt = |
148 | 170 |
match local with |
149 |
| AdaLocalVar var -> pp_var_decl var fmt |
|
150 |
| AdaLocalPackage (pp_name, pp_base_name, instanciations) -> |
|
151 |
pp_package_instanciation pp_name pp_base_name fmt instanciations |
|
171 |
| AdaLocalVar var -> |
|
172 |
pp_var_decl var fmt |
|
173 |
| AdaLocalPackage (pp_name, pp_base_name, instanciations) -> |
|
174 |
pp_package_instanciation pp_name pp_base_name fmt instanciations |
|
175 |
|
|
152 | 176 |
and pp_content pp_name fmt = function |
153 | 177 |
| AdaNoContent -> |
154 |
fprintf fmt ""
|
|
178 |
fprintf fmt "" |
|
155 | 179 |
| AdaVisibilityDefinition visbility -> |
156 |
fprintf fmt " is %a" pp_visibility visbility
|
|
180 |
fprintf fmt " is %a" pp_visibility visbility |
|
157 | 181 |
| AdaPackageContent pp_package -> |
158 |
fprintf fmt " is@, @[<v>%t;@]@,end %t" pp_package pp_name
|
|
182 |
fprintf fmt " is@, @[<v>%t;@]@,end %t" pp_package pp_name |
|
159 | 183 |
| AdaSimpleContent pp_content -> |
160 |
fprintf fmt " is@, @[<v 2>(%t)@]" pp_content
|
|
184 |
fprintf fmt " is@, @[<v 2>(%t)@]" pp_content |
|
161 | 185 |
| AdaProcedureContent (local_list, pp_instr_list) -> |
162 |
fprintf fmt " is@,%abegin@,%aend %t" |
|
163 |
pp_block (List.map (fun l -> pp_group ~sep:";@;" (List.map pp_local l)) local_list) |
|
164 |
pp_block pp_instr_list |
|
165 |
pp_name |
|
186 |
fprintf fmt " is@,%abegin@,%aend %t" pp_block |
|
187 |
(List.map (fun l -> pp_group ~sep:";@;" (List.map pp_local l)) local_list) |
|
188 |
pp_block pp_instr_list pp_name |
|
166 | 189 |
| AdaRecord var_list -> |
167 |
assert(var_list != []);
|
|
168 |
let pp_lists = apply_var_decl_lists var_list in
|
|
169 |
fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]"
|
|
170 |
pp_block (List.map (pp_group ~sep:";@;") pp_lists)
|
|
190 |
assert (var_list != []);
|
|
191 |
let pp_lists = apply_var_decl_lists var_list in |
|
192 |
fprintf fmt " is@, @[<v>record@, @[<v>%a@]@,end record@]" pp_block
|
|
193 |
(List.map (pp_group ~sep:";@;") pp_lists) |
|
171 | 194 |
| AdaPackageInstanciation (pp_name, instanciations) -> |
172 |
fprintf fmt " is new %t%a" |
|
173 |
pp_name |
|
174 |
(pp_args ~sep:",@,") (List.map pp_generic_instanciation instanciations) |
|
175 |
and pp_def fmt (pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) = |
|
195 |
fprintf fmt " is new %t%a" pp_name (pp_args ~sep:",@,") |
|
196 |
(List.map pp_generic_instanciation instanciations) |
|
197 |
|
|
198 |
and pp_def fmt |
|
199 |
(pp_generics, kind_def, pp_name, args, pp_type_opt, content, pp_with_opt) = |
|
176 | 200 |
let pp_arg_lists = apply_var_decl_lists args in |
177 |
fprintf fmt "%a%a %t%a%a%a%a" |
|
178 |
pp_generic pp_generics |
|
179 |
pp_kind_def kind_def |
|
180 |
pp_name |
|
181 |
(pp_args ~sep:";@,") (List.map (pp_group ~sep:";@,") pp_arg_lists) |
|
182 |
(pp_opt "return") pp_type_opt |
|
183 |
(pp_content pp_name) content |
|
184 |
pp_ada_with pp_with_opt |
|
201 |
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) |
|
204 |
(pp_opt "return") pp_type_opt (pp_content pp_name) content pp_ada_with |
|
205 |
pp_with_opt |
|
206 |
|
|
185 | 207 |
and pp_package_instanciation pp_name pp_base_name fmt instanciations = |
186 |
pp_def fmt ([], AdaPackageDecl, pp_name, [], None, (AdaPackageInstanciation (pp_base_name, instanciations)), None) |
|
208 |
pp_def fmt |
|
209 |
( [], |
|
210 |
AdaPackageDecl, |
|
211 |
pp_name, |
|
212 |
[], |
|
213 |
None, |
|
214 |
AdaPackageInstanciation (pp_base_name, instanciations), |
|
215 |
None ) |
|
187 | 216 |
|
188 |
let pp_adastring pp_content fmt = |
|
189 |
fprintf fmt "\"%t\"" pp_content |
|
217 |
let pp_adastring pp_content fmt = fprintf fmt "\"%t\"" pp_content |
|
190 | 218 |
|
191 | 219 |
(** Print the ada package introduction sentence it can be used for body and |
192 |
declaration. Boolean parameter body should be true if it is a body delcaration. |
|
193 |
@param fmt the formater to print on |
|
194 |
@param fmt the formater to print on |
|
195 |
@param machine the machine |
|
196 |
**) |
|
220 |
declaration. Boolean parameter body should be true if it is a body |
|
221 |
delcaration. @param fmt the formater to print on @param fmt the formater to |
|
222 |
print on @param machine the machine **) |
|
197 | 223 |
let pp_package pp_name pp_generics body fmt pp_content = |
198 | 224 |
let kind = if body then AdaPackageBody else AdaPackageDecl in |
199 |
pp_def fmt (pp_generics, kind, pp_name, [], None, (AdaPackageContent pp_content), None) |
|
200 |
|
|
201 |
(** Print a new statement instantiating a generic package. |
|
202 |
@param fmt the formater to print on |
|
203 |
@param substitutions the instanciation substitution |
|
204 |
@param machine the machine to instanciate |
|
205 |
**) |
|
206 |
|
|
207 |
(** Print a type declaration |
|
208 |
@param fmt the formater to print on |
|
209 |
@param pp_name a format printer which print the type name |
|
210 |
@param pp_value a format printer which print the type definition |
|
211 |
**) |
|
225 |
pp_def fmt |
|
226 |
(pp_generics, kind, pp_name, [], None, AdaPackageContent pp_content, None) |
|
227 |
|
|
228 |
(** Print a new statement instantiating a generic package. @param fmt the |
|
229 |
formater to print on @param substitutions the instanciation substitution |
|
230 |
@param machine the machine to instanciate **) |
|
231 |
|
|
232 |
(** Print a type declaration @param fmt the formater to print on @param pp_name |
|
233 |
a format printer which print the type name @param pp_value a format printer |
|
234 |
which print the type definition **) |
|
212 | 235 |
let pp_type_decl pp_name visibility fmt = |
213 |
let v = match visibility with |
|
214 |
| AdaNoVisibility -> AdaNoContent |
|
215 |
| _ -> AdaVisibilityDefinition visibility |
|
236 |
let v = |
|
237 |
match visibility with |
|
238 |
| AdaNoVisibility -> |
|
239 |
AdaNoContent |
|
240 |
| _ -> |
|
241 |
AdaVisibilityDefinition visibility |
|
216 | 242 |
in |
217 | 243 |
pp_def fmt ([], AdaType, pp_name, [], None, v, None) |
218 | 244 |
|
... | ... | |
223 | 249 |
pp_def fmt ([], AdaProcedure, pp_name, args, None, content, pp_with_opt) |
224 | 250 |
|
225 | 251 |
let pp_predicate pp_name args imported fmt content_opt = |
226 |
let content, with_st = match content_opt with |
|
227 |
| Some content -> AdaSimpleContent content, None |
|
228 |
| None -> AdaNoContent, Some (true, imported, [], []) |
|
252 |
let content, with_st = |
|
253 |
match content_opt with |
|
254 |
| Some content -> |
|
255 |
AdaSimpleContent content, None |
|
256 |
| None -> |
|
257 |
AdaNoContent, Some (true, imported, [], []) |
|
229 | 258 |
in |
230 |
pp_def fmt ([], AdaFunction, pp_name, args, Some pp_boolean_type, content, with_st) |
|
259 |
pp_def fmt |
|
260 |
([], AdaFunction, pp_name, args, Some pp_boolean_type, content, with_st) |
|
231 | 261 |
|
232 |
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an
|
|
233 |
underscore and must not contain a double underscore
|
|
234 |
@param var name to be cleaned*)
|
|
262 |
(** Print a cleaned an identifier for ada exportation : Ada names must not start |
|
263 |
by an underscore and must not contain a double underscore @param var name to
|
|
264 |
be cleaned*) |
|
235 | 265 |
let pp_clean_ada_identifier fmt name = |
236 |
let reserved_words = ["abort"; "else"; "new"; "return"; "boolean"; "integer"; |
|
237 |
"abs"; "elsif"; "not"; "reverse"; "abstract"; "end"; |
|
238 |
"null"; "accept"; "entry"; "select"; "access"; |
|
239 |
"exception"; "of"; "separate"; "aliased"; "exit"; |
|
240 |
"or"; "some"; "all"; "others"; "subtype"; "and"; |
|
241 |
"for"; "out"; "synchronized"; "array"; "function"; |
|
242 |
"overriding"; "at"; "tagged"; "generic"; "package"; |
|
243 |
"task"; "begin"; "goto"; "pragma"; "terminate"; |
|
244 |
"body"; "private"; "then"; "if"; "procedure"; "type"; |
|
245 |
"case"; "in"; "protected"; "constant"; "interface"; |
|
246 |
"until"; "is"; "raise"; "use"; "declare"; " range"; |
|
247 |
"delay"; "limited"; "record"; "when"; "delta"; "loop"; |
|
248 |
"rem"; "while"; "digits"; "renames"; "with"; "do"; |
|
249 |
"mod"; "requeue"; "xor"; "float"] in |
|
266 |
let reserved_words = |
|
267 |
[ |
|
268 |
"abort"; |
|
269 |
"else"; |
|
270 |
"new"; |
|
271 |
"return"; |
|
272 |
"boolean"; |
|
273 |
"integer"; |
|
274 |
"abs"; |
|
275 |
"elsif"; |
|
276 |
"not"; |
|
277 |
"reverse"; |
|
278 |
"abstract"; |
|
279 |
"end"; |
|
280 |
"null"; |
|
281 |
"accept"; |
|
282 |
"entry"; |
|
283 |
"select"; |
|
284 |
"access"; |
|
285 |
"exception"; |
|
286 |
"of"; |
|
287 |
"separate"; |
|
288 |
"aliased"; |
|
289 |
"exit"; |
|
290 |
"or"; |
|
291 |
"some"; |
|
292 |
"all"; |
|
293 |
"others"; |
|
294 |
"subtype"; |
|
295 |
"and"; |
|
296 |
"for"; |
|
297 |
"out"; |
|
298 |
"synchronized"; |
|
299 |
"array"; |
|
300 |
"function"; |
|
301 |
"overriding"; |
|
302 |
"at"; |
|
303 |
"tagged"; |
|
304 |
"generic"; |
|
305 |
"package"; |
|
306 |
"task"; |
|
307 |
"begin"; |
|
308 |
"goto"; |
|
309 |
"pragma"; |
|
310 |
"terminate"; |
|
311 |
"body"; |
|
312 |
"private"; |
|
313 |
"then"; |
|
314 |
"if"; |
|
315 |
"procedure"; |
|
316 |
"type"; |
|
317 |
"case"; |
|
318 |
"in"; |
|
319 |
"protected"; |
|
320 |
"constant"; |
|
321 |
"interface"; |
|
322 |
"until"; |
|
323 |
"is"; |
|
324 |
"raise"; |
|
325 |
"use"; |
|
326 |
"declare"; |
|
327 |
"\trange"; |
|
328 |
"delay"; |
|
329 |
"limited"; |
|
330 |
"record"; |
|
331 |
"when"; |
|
332 |
"delta"; |
|
333 |
"loop"; |
|
334 |
"rem"; |
|
335 |
"while"; |
|
336 |
"digits"; |
|
337 |
"renames"; |
|
338 |
"with"; |
|
339 |
"do"; |
|
340 |
"mod"; |
|
341 |
"requeue"; |
|
342 |
"xor"; |
|
343 |
"float"; |
|
344 |
] |
|
345 |
in |
|
250 | 346 |
let base_size = String.length name in |
251 |
assert(base_size > 0); |
|
347 |
assert (base_size > 0);
|
|
252 | 348 |
let rec remove_double_underscore s = function |
253 |
| i when i == String.length s - 1 -> s |
|
254 |
| i when String.get s i == '_' && String.get s (i+1) == '_' -> |
|
255 |
remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i |
|
256 |
| i -> remove_double_underscore s (i+1) |
|
349 |
| i when i == String.length s - 1 -> |
|
350 |
s |
|
351 |
| i when String.get s i == '_' && String.get s (i + 1) == '_' -> |
|
352 |
remove_double_underscore |
|
353 |
(sprintf "%s%s" (String.sub s 0 i) |
|
354 |
(String.sub s (i + 1) (String.length s - i - 1))) |
|
355 |
i |
|
356 |
| i -> |
|
357 |
remove_double_underscore s (i + 1) |
|
358 |
in |
|
359 |
let name = |
|
360 |
if String.get name (base_size - 1) == '_' then name ^ "ada" else name |
|
257 | 361 |
in |
258 |
let name = if String.get name (base_size-1) == '_' then name^"ada" else name in |
|
259 | 362 |
let name = remove_double_underscore name 0 in |
260 |
let prefix = if String.length name != base_size |
|
261 |
|| String.get name 0 == '_' |
|
262 |
|| List.exists (String.equal (String.lowercase_ascii name)) reserved_words then |
|
263 |
"ada" |
|
264 |
else |
|
265 |
"" |
|
363 |
let prefix = |
|
364 |
if |
|
365 |
String.length name != base_size |
|
366 |
|| String.get name 0 == '_' |
|
367 |
|| List.exists (String.equal (String.lowercase_ascii name)) reserved_words |
|
368 |
then "ada" |
|
369 |
else "" |
|
266 | 370 |
in |
267 | 371 |
fprintf fmt "%s%s" prefix name |
268 | 372 |
|
269 |
(** Print the access of an item from an other package. |
|
270 |
@param fmt the formater to print on |
|
271 |
@param package the package to use |
|
272 |
@param item the item which is accessed |
|
273 |
**) |
|
373 |
(** Print the access of an item from an other package. @param fmt the formater |
|
374 |
to print on @param package the package to use @param item the item which is |
|
375 |
accessed **) |
|
274 | 376 |
let pp_package_access (pp_package, pp_item) fmt = |
275 | 377 |
fprintf fmt "%t.%t" pp_package pp_item |
276 | 378 |
|
... | ... | |
278 | 380 |
fprintf fmt "%a with %t" pp_visibility visibility pp_pakage_name |
279 | 381 |
|
280 | 382 |
(** Print a one line comment with the final new line character to avoid |
281 |
commenting anything else. |
|
282 |
@param fmt the formater to print on |
|
283 |
@param s the comment without newline character |
|
284 |
**) |
|
383 |
commenting anything else. @param fmt the formater to print on @param s the |
|
384 |
comment without newline character **) |
|
285 | 385 |
let pp_oneline_comment fmt s = |
286 | 386 |
assert (not (String.contains s '\n')); |
287 | 387 |
fprintf fmt "-- %s@," s |
288 | 388 |
|
289 | 389 |
let pp_call fmt (pp_name, args) = |
290 |
fprintf fmt "%t%a" |
|
291 |
pp_name |
|
292 |
(pp_args ~sep:",@ ") (List.map (pp_group ~sep:",@,") args) |
|
390 |
fprintf fmt "%t%a" pp_name (pp_args ~sep:",@ ") |
|
391 |
(List.map (pp_group ~sep:",@,") args) |
|
293 | 392 |
|
294 |
|
|
295 |
(** Print the complete name of variable. |
|
296 |
@param m the machine to check if it is memory |
|
297 |
@param fmt the formater to print on |
|
298 |
@param var the variable |
|
299 |
**) |
|
300 |
let pp_access pp_state pp_var fmt = |
|
301 |
fprintf fmt "%t.%t" pp_state pp_var |
|
393 |
(** Print the complete name of variable. @param m the machine to check if it is |
|
394 |
memory @param fmt the formater to print on @param var the variable **) |
|
395 |
let pp_access pp_state pp_var fmt = fprintf fmt "%t.%t" pp_state pp_var |
|
302 | 396 |
|
303 | 397 |
let pp_old pp fmt = fprintf fmt "%t'Old" pp |
304 |
|
Also available in: Unified diff
reformatting