Project

General

Profile

Revision fd834769 src/backends/Ada/ada_backend_common.ml

View differences:

src/backends/Ada/ada_backend_common.ml
7 7

  
8 8
(** All the pretty print functions common to the ada backend **)
9 9

  
10
(* Misc pretty print functions *)
10 11

  
11 12
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an
12 13
    underscore and must not contain a double underscore 
13 14
   @param var name to be cleaned*)
14
let print_clean_ada_identifier fmt name =
15
let pp_clean_ada_identifier fmt name =
15 16
  let base_size = String.length name in
16 17
  assert(base_size > 0);
17 18
  let rec remove_double_underscore s = function
......
29 30
  in
30 31
  fprintf fmt "%s%s" prefix name
31 32

  
32

  
33 33
(* Package pretty print functions *)
34 34

  
35 35
(** Print the name of a package associated to a machine.
......
37 37
   @param machine the machine
38 38
**)
39 39
let pp_package_name fmt node =
40
    fprintf fmt "%a" print_clean_ada_identifier node.node_id
40
    fprintf fmt "%a" pp_clean_ada_identifier node.node_id
41 41

  
42 42
(** Print the ada package introduction sentence it can be used for body and
43 43
declaration. Boolean parameter body should be true if it is a body delcaration.
......
65 65
let pp_package_access fmt (package, item) =
66 66
  fprintf fmt "%t.%t" package item
67 67

  
68
(** Print the name of the main procedure.
69
   @param fmt the formater to print on
70
   @param main_machine the machine associated to the main node
71
**)
72
let pp_main_procedure_name main_machine fmt =
73
  fprintf fmt "main"
74

  
75
(** Print the name of the main ada file.
76
   @param fmt the formater to print on
77
   @param main_machine the machine associated to the main node
78
**)
79
let pp_main_filename fmt main_machine =
80
  fprintf fmt "%t.adb" (pp_main_procedure_name main_machine)
81

  
82
(** Extract a node from an instance.
83
   @param instance the instance
84
**)
85
let extract_node instance =
86
  let (_, (node, _)) = instance in
87
  match node.top_decl_desc with 
88
    | Node nd         -> nd
89
    | _ -> assert false (*TODO*)
90

  
91
(** Print a with statement to include a node.
92
   @param fmt the formater to print on
93
   @param node the node
94
**)
95
let pp_with_node fmt node =
96
  fprintf fmt "private with %a" pp_package_name node
97

  
98

  
68 99
(* Type pretty print functions *)
69 100

  
70 101
(** Print a type declaration
......
148 179
   @param id the variable
149 180
**)
150 181
let pp_var_name fmt id =
151
  fprintf fmt "%a" print_clean_ada_identifier id.var_id
182
  fprintf fmt "%a" pp_clean_ada_identifier id.var_id
152 183

  
153 184
(** Print a variable declaration
154 185
   @param mode input/output mode of the parameter
......
183 214
  let pp_type = pp_state_type in
184 215
  pp_var_decl fmt (mode, pp_name, pp_type)
185 216

  
217
(** Print the declaration of a state element of node.
218
   @param instance name of the variable
219
   @param fmt the formater to print on
220
   @param instance node
221
**)
222
let pp_node_state_decl name fmt node =
223
  let pp_package fmt = pp_package_name fmt node in
224
  let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in
225
  let pp_name fmt = pp_clean_ada_identifier fmt name in
226
  pp_var_decl fmt (NoMode, pp_name, pp_type)
186 227

  
187 228
(* Prototype pretty print functions *)
188 229

  
......
198 239
(** Print the clear of the init procedure **)
199 240
let pp_clear_procedure_name fmt = fprintf fmt "clear"
200 241

  
242
(** Print the prototype of a procedure with non input/outputs
243
   @param fmt the formater to print on
244
   @param name the name of the procedure
245
**)
246
let pp_simple_prototype fmt pp_name =
247
  fprintf fmt "procedure %t" pp_name
248

  
201 249
(** Print the prototype of a machine procedure. The first parameter is always
202 250
the state, state_modifier specify the modifier applying to it. The next
203 251
parameters are inputs and the last parameters are the outputs.
204
   @param fmt the formater to print on
205
   @param name the name of the procedure
206 252
   @param state_mode the input/output mode for the state parameter
207 253
   @param input list of the input parameter of the procedure
208 254
   @param output list of the output parameter of the procedure
255
   @param fmt the formater to print on
256
   @param name the name of the procedure
209 257
**)
210
let pp_simple_prototype fmt (pp_name, state_mode, input, output) =
258
let pp_base_prototype state_mode input output fmt pp_name =
211 259
  fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]"
212 260
    pp_name
213 261
    pp_state_var_decl state_mode
......
217 265
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output
218 266

  
219 267
(** Print the prototype of the init procedure of a machine.
220
   @param fmt the formater to print on
221 268
   @param m the machine
269
   @param fmt the formater to print on
270
   @param pp_name name function printer
222 271
**)
223
let pp_init_prototype fmt m =
224
  pp_simple_prototype fmt (pp_init_procedure_name, Out, m.mstatic, [])
272
let pp_init_prototype m fmt pp_name =
273
  pp_base_prototype Out m.mstatic [] fmt pp_name
225 274

  
226 275
(** Print the prototype of the step procedure of a machine.
227
   @param fmt the formater to print on
228 276
   @param m the machine
277
   @param fmt the formater to print on
278
   @param pp_name name function printer
229 279
**)
230
let pp_step_prototype fmt m =
231
  pp_simple_prototype fmt (pp_step_procedure_name, InOut, m.mstep.step_inputs, m.mstep.step_outputs)
280
let pp_step_prototype m fmt pp_name =
281
  pp_base_prototype InOut m.mstep.step_inputs m.mstep.step_outputs fmt pp_name
232 282

  
233 283
(** Print the prototype of the reset procedure of a machine.
234
   @param fmt the formater to print on
235 284
   @param m the machine
285
   @param fmt the formater to print on
286
   @param pp_name name function printer
236 287
**)
237
let pp_reset_prototype fmt m =
238
  pp_simple_prototype fmt (pp_reset_procedure_name, InOut, m.mstatic, [])
288
let pp_reset_prototype m fmt pp_name =
289
  pp_base_prototype InOut m.mstatic [] fmt pp_name
239 290

  
240 291
(** Print the prototype of the clear procedure of a machine.
241
   @param fmt the formater to print on
242 292
   @param m the machine
293
   @param fmt the formater to print on
294
   @param pp_name name function printer
243 295
**)
244
let pp_clear_prototype fmt m =
245
  pp_simple_prototype fmt (pp_clear_procedure_name, InOut, m.mstatic, [])
296
let pp_clear_prototype m fmt pp_name =
297
  pp_base_prototype InOut m.mstatic [] fmt pp_name
298

  
299

  
300
(* Procedure pretty print functions *)
301

  
302
(** Print the definition of a procedure
303
   @param pp_name the procedure name printer
304
   @param pp_prototype the prototype printer
305
   @param pp_instr local var printer
306
   @param pp_instr instruction printer
307
   @param fmt the formater to print on
308
   @param locals locals var list
309
   @param instrs instructions list
310
**)
311
let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) =
312
  fprintf fmt "@[<v>%a is%t@[<v>%a%t@]@,begin@,  @[<v>%a%t@]@,end %t@]"
313
    pp_prototype pp_name
314
    (Utils.pp_final_char_if_non_empty "@,  " locals)
315
    (Utils.fprintf_list ~sep:";@," pp_local) locals
316
    (Utils.pp_final_char_if_non_empty ";" locals)
317
    (Utils.fprintf_list ~sep:";@," pp_instr) instrs
318
    (Utils.pp_final_char_if_non_empty ";" instrs)
319
    pp_name
320

  

Also available in: Unified diff