Project

General

Profile

« Previous | Next » 

Revision 230b168e

Added by Guillaume DAVY almost 3 years ago

Ada: Refactor Ada Backend to reduce redundancy, make it more modular and
more simple.

View differences:

src/backends/Ada/ada_backend_common.ml
5 5
open Corelang
6 6
open Machine_code_common
7 7

  
8
open Ada_printer
9
open Misc_printer
10
open Misc_lustre_function
11

  
8 12
(** Exception for unsupported features in Ada backend **)
9 13
exception Ada_not_supported of string
10 14

  
11
(** All the pretty print and aux functions common to the ada backend **)
15
(** Print the name of the state variable.
16
   @param fmt the formater to print on
17
**)
18
let pp_state_name fmt = fprintf fmt "state"
19
(** Print the type of the state variable.
20
   @param fmt the formater to print on
21
**)
22
let pp_state_type fmt = fprintf fmt "TState"
23
(** Print the name of the reset procedure
24
   @param fmt the formater to print on
25
**)
26
let pp_reset_procedure_name fmt = fprintf fmt "reset"
27
(** Print the name of the step procedure
28
   @param fmt the formater to print on
29
**)
30
let pp_step_procedure_name fmt = fprintf fmt "step"
31
(** Print the name of the main procedure.
32
   @param fmt the formater to print on
33
**)
34
let pp_main_procedure_name fmt = fprintf fmt "ada_main"
35
(** Print the name of the arrow package.
36
   @param fmt the formater to print on
37
**)
38
let pp_arrow_package_name fmt = fprintf fmt "Arrow"
39
(** Print the type of a polymorphic type.
40
   @param fmt the formater to print on
41
   @param id the id of the polymorphic type
42
**)
43
let pp_polymorphic_type id fmt = fprintf fmt "T_%i" id
44

  
45

  
46

  
47

  
48

  
49

  
12 50

  
13
(* Misc pretty print functions *)
14 51

  
15
let is_machine_statefull m = not m.mname.node_dec_stateless
16 52

  
17 53
(*TODO Check all this function with unit test, improve this system and
18 54
   add support for : "cbrt", "erf", "log10", "pow", "atan2".
......
47 83
  List.mem ident Basic_library.internal_funs ||
48 84
    List.mem_assoc ident ada_supported_funs
49 85

  
50
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an
51
    underscore and must not contain a double underscore
52
   @param var name to be cleaned*)
53
let pp_clean_ada_identifier fmt name =
54
  let reserved_words = ["abort"; "else"; "new"; "return"; "boolean"; "integer";
55
                        "abs"; "elsif"; "not"; "reverse"; "abstract"; "end";
56
                        "null"; "accept"; "entry"; "select"; "access";
57
                        "exception"; "of"; "separate"; "aliased"; "exit";
58
                        "or"; "some"; "all"; "others"; "subtype"; "and";
59
                        "for"; "out"; "synchronized"; "array"; "function";
60
                        "overriding"; "at"; "tagged"; "generic"; "package";
61
                        "task"; "begin"; "goto"; "pragma"; "terminate";
62
                        "body"; "private"; "then"; "if"; "procedure"; "type";
63
                        "case"; "in"; "protected"; "constant"; "interface";
64
                        "until"; "is"; "raise"; "use"; "declare"; "	range";
65
                        "delay"; "limited"; "record"; "when"; "delta"; "loop";
66
                        "rem"; "while"; "digits"; "renames"; "with"; "do";
67
                        "mod"; "requeue"; "xor"; "float"] in
68
  let base_size = String.length name in
69
  assert(base_size > 0);
70
  let rec remove_double_underscore s = function
71
    | i when i == String.length s - 1 -> s
72
    | i when String.get s i == '_' && String.get s (i+1) == '_' ->
73
        remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i
74
    | i -> remove_double_underscore s (i+1)
75
  in
76
  let name = if String.get name (base_size-1) == '_' then name^"ada" else name in
77
  let name = remove_double_underscore name 0 in
78
  let prefix = if String.length name != base_size
79
                  || String.get name 0 == '_' 
80
                  || List.exists (String.equal (String.lowercase_ascii name)) reserved_words then
81
                  "ada"
82
               else
83
                  ""
84
  in
85
  fprintf fmt "%s%s" prefix name
86

  
87
(** Encapsulate a pretty print function to lower case its result when applied
88
   @param pp the pretty print function
89
   @param fmt the formatter
90
   @param arg the argument of the pp function
91
**)
92
let pp_lowercase pp fmt =
93
  let str = asprintf "%t" pp in
94
  fprintf fmt "%s" (String. lowercase_ascii str)
95

  
96
(** Print a filename by lowercasing the base and appending an extension.
97
   @param extension the extension to append to the package name
98
   @param fmt the formatter
99
   @param pp_name the file base name printer
100
**)
101
let pp_filename extension fmt pp_name =
102
  fprintf fmt "%t.%s"
103
    (pp_lowercase pp_name)
104
    extension
105

  
106

  
107
(* Package pretty print functions *)
108

  
109
(** Return true if its the arrow machine
110
   @param machine the machine to test
111
*)
112
let is_arrow machine = String.equal Arrow.arrow_id machine.mname.node_id
113

  
114
(** Print the name of the arrow package.
115
   @param fmt the formater to print on
116
**)
117
let pp_arrow_package_name fmt = fprintf fmt "Arrow"
118

  
119 86
(** Print the name of a package associated to a machine.
120 87
   @param fmt the formater to print on
121 88
   @param machine the machine
122 89
**)
123
let pp_package_name fmt machine =
90
let pp_package_name machine fmt =
124 91
  if is_arrow machine then
125 92
      fprintf fmt "%t" pp_arrow_package_name
126 93
  else
127 94
      fprintf fmt "%a" pp_clean_ada_identifier machine.mname.node_id
128 95

  
129
(** Print the ada package introduction sentence it can be used for body and
130
declaration. Boolean parameter body should be true if it is a body delcaration.
131
   @param fmt the formater to print on
132
   @param fmt the formater to print on
133
   @param machine the machine
134
**)
135
let pp_begin_package body fmt machine =
136
  fprintf fmt "package %s%a is"
137
    (if body then "body " else "")
138
    pp_package_name machine
139

  
140
(** Print the ada package conclusion sentence.
141
   @param fmt the formater to print on
142
   @param machine the machine
143
**)
144
let pp_end_package fmt machine =
145
  fprintf fmt "end %a" pp_package_name machine
146

  
147
(** Print the access of an item from an other package.
148
   @param fmt the formater to print on
149
   @param package the package to use
150
   @param item the item which is accessed
151
**)
152
let pp_package_access fmt (package, item) =
153
  fprintf fmt "%t.%t" package item
154

  
155
(** Print the name of the main procedure.
156
   @param fmt the formater to print on
157
**)
158
let pp_main_procedure_name fmt =
159
  fprintf fmt "ada_main"
160

  
161
(** Print a with statement to include a package.
162
   @param fmt the formater to print on
163
   @param pp_pakage_name the package name printer
164
**)
165
let pp_private_with fmt pp_pakage_name =
166
  fprintf fmt "private with %t" pp_pakage_name
167

  
168
(** Print a with statement to include a package.
169
   @param fmt the formater to print on
170
   @param name the package name
171
**)
172
let pp_with fmt name =
173
  fprintf fmt "with %s" name
174

  
175
(** Print a with statement to include a machine.
176
   @param fmt the formater to print on
177
   @param machine the machine
178
**)
179
let pp_with_machine fmt machine =
180
  fprintf fmt "private with %a" pp_package_name machine
181

  
182
(** Extract a node from an instance.
183
   @param instance the instance
184
**)
185
let extract_node instance =
186
  let (_, (node, _)) = instance in
187
  match node.top_decl_desc with
188
    | Node nd         -> nd
189
    | _ -> assert false (*TODO*)
190

  
191
(** Extract from a machine list the one corresponding to the given instance.
192
      assume that the machine is in the list.
193
   @param machines list of all machines
194
   @param instance instance of a machine
195
   @return the machine corresponding to hte given instance
196
**)
197
let get_machine machines instance =
198
    let id = (extract_node instance).node_id in
199
    try
200
      List.find (function m -> m.mname.node_id=id) machines
201
    with
202
      Not_found -> assert false (*TODO*)
203

  
204

  
205
(* Type pretty print functions *)
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
**)
212
let pp_type_decl fmt (pp_name, pp_definition) =
213
  fprintf fmt "type %t is %t" pp_name pp_definition
214

  
215
(** Print a private type declaration
216
   @param fmt the formater to print on
217
   @param pp_name a format printer which print the type name
218
**)
219
let pp_private_type_decl fmt pp_name =
220
  let pp_definition fmt = fprintf fmt "private" in
221
  pp_type_decl fmt (pp_name, pp_definition)
222

  
223
(** Print a limited private type declaration
224
   @param fmt the formater to print on
225
   @param pp_name a format printer which print the type name
226
**)
227
let pp_private_limited_type_decl fmt pp_name =
228
  let pp_definition fmt = fprintf fmt "limited private" in
229
  pp_type_decl fmt (pp_name, pp_definition)
230

  
231
(** Print the type of the state variable.
232
   @param fmt the formater to print on
233
**)
234
let pp_state_type fmt =
235
  (* Type and variable names live in the same environement in Ada so name of
236
     this type and of the associated parameter : pp_state_name must be
237
     different *)
238
  fprintf fmt "TState"
239 96

  
240 97
(** Print the integer type name.
241 98
   @param fmt the formater to print on
......
252 109
**)
253 110
let pp_boolean_type fmt = fprintf fmt "Boolean"
254 111

  
255
(** Print the type of a polymorphic type.
256
   @param fmt the formater to print on
257
   @param id the id of the polymorphic type
258
**)
259
let pp_polymorphic_type fmt id =
260
  fprintf fmt "T_%i" id
261 112

  
262 113
(** Print a type.
263 114
   @param fmt the formater to print on
......
268 119
    | Types.Tbasic Types.Basic.Tint  -> pp_integer_type fmt
269 120
    | Types.Tbasic Types.Basic.Treal -> pp_float_type fmt
270 121
    | Types.Tbasic Types.Basic.Tbool -> pp_boolean_type fmt
271
    | Types.Tunivar                  -> pp_polymorphic_type fmt typ.Types.tid
122
    | Types.Tunivar                  -> pp_polymorphic_type typ.Types.tid fmt
272 123
    | Types.Tbasic _                 -> eprintf "Tbasic@."; assert false (*TODO*)
273 124
    | Types.Tconst _                 -> eprintf "Tconst@."; assert false (*TODO*)
274 125
    | Types.Tclock _                 -> eprintf "Tclock@."; assert false (*TODO*)
......
300 151
    | Types.Tbasic t  -> mk_val (Cst (default_ada_cst t)) typ
301 152
    | _                              -> assert false (*TODO*)
302 153

  
303
(** Test if two types are the same.
304
   @param typ1 the first type
305
   @param typ2 the second type
306
**)
307
let pp_eq_type typ1 typ2 = 
308
  let get_basic typ = match (Types.repr typ).Types.tdesc with
309
    | Types.Tbasic Types.Basic.Tint -> Types.Basic.Tint
310
    | Types.Tbasic Types.Basic.Treal -> Types.Basic.Treal
311
    | Types.Tbasic Types.Basic.Tbool -> Types.Basic.Tbool
312
    | _ -> assert false (*TODO*)
313
  in
314
  get_basic typ1 = get_basic typ2
315

  
316

  
317 154
(** Print the type of a variable.
318 155
   @param fmt the formater to print on
319 156
   @param id the variable
......
321 158
let pp_var_type fmt id = 
322 159
  pp_type fmt id.var_type
323 160

  
324
(** Extract all the inputs and outputs.
325
   @param machine the machine
326
   @return a list of all the var_decl of a macine
327
**)
328
let get_all_vars_machine m =
329
  m.mmemory@m.mstep.step_inputs@m.mstep.step_outputs@m.mstatic
330

  
331
(** Check if a type is polymorphic.
332
   @param typ the type
333
   @return true if its polymorphic
334
**)
335
let is_Tunivar typ = (Types.repr typ).tdesc == Types.Tunivar
336

  
337
(** Find all polymorphic type : Types.Tunivar in a machine.
338
   @param machine the machine
339
   @return a list of id corresponding to polymorphic type
340
**)
341
let find_all_polymorphic_type m =
342
  let vars = get_all_vars_machine m in
343
  let extract id = id.var_type.tid in
344
  let polymorphic_type_vars =
345
    List.filter (function x-> is_Tunivar x.var_type) vars in
346
  List.sort_uniq (-) (List.map extract polymorphic_type_vars)
347

  
348 161
(** Print a package name with polymorphic types specified.
349 162
   @param substitution correspondance between polymorphic type id and their instantiation
350 163
   @param fmt the formater to print on
351 164
   @param machine the machine
352 165
**)
353
let pp_package_name_with_polymorphic substitution fmt machine =
166
let pp_package_name_with_polymorphic substitution machine fmt =
354 167
  let polymorphic_types = find_all_polymorphic_type machine in
355 168
  assert(List.length polymorphic_types = List.length substitution);
356 169
  let substituion = List.sort_uniq (fun x y -> fst x - fst y) substitution in
357 170
  assert(List.for_all2 (fun poly1 (poly2, _) -> poly1 = poly2)
358 171
            polymorphic_types substituion);
359 172
  let instantiated_types = snd (List.split substitution) in
360
  fprintf fmt "%a%t%a"
361
    pp_package_name machine
173
  fprintf fmt "%t%t%a"
174
    (pp_package_name machine)
362 175
    (Utils.pp_final_char_if_non_empty "_" instantiated_types)
363 176
    (Utils.fprintf_list ~sep:"_" pp_type) instantiated_types
364 177

  
365

  
366
(* Variable pretty print functions *)
367

  
368
(** Represent the possible mode for a type of a procedure parameter **)
369
type parameter_mode = NoMode | In | Out | InOut
370

  
371
(** Print a parameter_mode.
372
   @param fmt the formater to print on
373
   @param mode the modifier
374
**)
375
let pp_parameter_mode fmt mode =
376
  fprintf fmt "%s" (match mode with
377
                     | NoMode -> ""
378
                     | In     -> "in"
379
                     | Out    -> "out"
380
                     | InOut  -> "in out")
381

  
382
(** Print the name of the state variable.
383
   @param fmt the formater to print on
384
**)
385
let pp_state_name fmt =
386
  fprintf fmt "state"
387

  
388

  
389 178
(** Print the name of a variable.
390 179
   @param fmt the formater to print on
391 180
   @param id the variable
......
404 193
  else
405 194
    pp_var_name fmt var
406 195

  
407
(** Print a variable declaration
408
   @param mode input/output mode of the parameter
409
   @param pp_name a format printer wich print the variable name
410
   @param pp_type a format printer wich print the variable type
411
   @param fmt the formater to print on
412
   @param id the variable
413
**)
414
let pp_var_decl fmt (mode, pp_name, pp_type) =
415
  fprintf fmt "%t: %a%s%t"
416
    pp_name
417
    pp_parameter_mode mode
418
    (if mode = NoMode then "" else " ")
419
    pp_type
420

  
421
(** Print variable declaration for machine variable
422
   @param mode input/output mode of the parameter
423
   @param fmt the formater to print on
424
   @param id the variable
425
**)
426
let pp_machine_var_decl mode fmt id =
427
  let pp_name = function fmt -> pp_var_name fmt id in
428
  let pp_type = function fmt -> pp_var_type fmt id in
429
  pp_var_decl fmt (mode, pp_name, pp_type)
430

  
431
(** Print variable declaration for a local state variable
432
   @param fmt the formater to print on
433
   @param mode input/output mode of the parameter
434
**)
435
let pp_state_var_decl fmt mode =
436
  let pp_name = pp_state_name in
437
  let pp_type = pp_state_type in
438
  pp_var_decl fmt (mode, pp_name, pp_type)
439

  
440
(** Print the declaration of a state element of a machine.
441
   @param substitution correspondance between polymorphic type id and their instantiation
442
   @param name name of the variable
443
   @param fmt the formater to print on
444
   @param machine the machine
445
**)
446
let pp_node_state_decl substitution name fmt machine =
447
  let pp_package fmt = pp_package_name_with_polymorphic substitution fmt machine in
448
  let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in
449
  let pp_name fmt = pp_clean_ada_identifier fmt name in
450
  pp_var_decl fmt (NoMode, pp_name, pp_type)
451 196

  
197
(* Expression print functions *)
452 198

  
453
(* Prototype pretty print functions *)
454

  
455
(** Print the name of the reset procedure **)
456
let pp_reset_procedure_name fmt = fprintf fmt "reset"
199
(* Printing functions for basic operations and expressions *)
200
(* TODO: refactor code -> use let rec and for basic pretty printing
201
   function *)
202
(** Printing function for Ada tags, mainly booleans.
457 203

  
458
(** Print the name of the step procedure **)
459
let pp_step_procedure_name fmt = fprintf fmt "step"
204
    @param fmt the formater to use
205
    @param t the tag to print
206
 **)
207
let pp_ada_tag fmt t =
208
  pp_print_string fmt
209
    (if t = tag_true then "True" else if t = tag_false then "False" else t)
460 210

  
461
(** Print the name of the init procedure **)
462
let pp_init_procedure_name fmt = fprintf fmt "init"
211
(** Printing function for machine type constants. For the moment,
212
    arrays are not supported.
463 213

  
464
(** Print the name of the clear procedure **)
465
let pp_clear_procedure_name fmt = fprintf fmt "clear"
214
    @param fmt the formater to use
215
    @param c the constant to print
216
 **)
217
let pp_ada_const fmt c =
218
  match c with
219
  | Const_int i                     -> pp_print_int fmt i
220
  | Const_real (c, e, s)            ->
221
      fprintf fmt "%s.0*1.0e-%i" (Num.string_of_num c) e
222
  | Const_tag t                     -> pp_ada_tag fmt t
223
  | Const_string _ | Const_modeid _ ->
224
    (Format.eprintf
225
       "internal error: Ada_backend_adb.pp_ada_const cannot print string or modeid.";
226
     assert false)
227
  | _                               ->
228
    raise (Ada_not_supported "unsupported: Ada_backend_adb.pp_ada_const does not
229
    support this constant")
230

  
231
(** Printing function for expressions [v1 modulo v2]. Depends
232
    on option [integer_div_euclidean] to choose between mathematical
233
    modulo or remainder ([rem] in Ada).
234

  
235
    @param pp_value pretty printer for values
236
    @param v1 the first value in the expression
237
    @param v2 the second value in the expression
238
    @param fmt the formater to print on
239
 **)
240
let pp_mod pp_value v1 v2 fmt =
241
  if !Options.integer_div_euclidean then
242
    (* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
243
    Format.fprintf fmt
244
      "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
245
      pp_value v1 pp_value v2
246
      pp_value v1 pp_value v2
247
      pp_value v2
248
  else (* Ada behavior for rem *)
249
    Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
250

  
251
(** Printing function for expressions [v1 div v2]. Depends on
252
    option [integer_div_euclidean] to choose between mathematic
253
    division or Ada division.
254

  
255
    @param pp_value pretty printer for values
256
    @param v1 the first value in the expression
257
    @param v2 the second value in the expression
258
    @param fmt the formater to print in
259
 **)
260
let pp_div pp_value v1 v2 fmt =
261
  if !Options.integer_div_euclidean then
262
    (* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
263
    Format.fprintf fmt "(%a - %t) / %a"
264
      pp_value v1
265
      (pp_mod pp_value v1 v2)
266
      pp_value v2
267
  else (* Ada behavior for / *)
268
    Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
269

  
270
(** Printing function for basic lib functions.
271

  
272
    @param pp_value pretty printer for values
273
    @param i a string representing the function
274
    @param fmt the formater to print on
275
    @param vl the list of operands
276
 **)
277
let pp_basic_lib_fun pp_value ident fmt vl =
278
  match ident, vl with
279
  | "uminus", [v]    ->
280
    Format.fprintf fmt "(- %a)" pp_value v
281
  | "not", [v]       ->
282
    Format.fprintf fmt "(not %a)" pp_value v
283
  | "impl", [v1; v2] ->
284
    Format.fprintf fmt "(not %a or else %a)" pp_value v1 pp_value v2
285
  | "=", [v1; v2]    ->
286
    Format.fprintf fmt "(%a = %a)" pp_value v1 pp_value v2
287
  | "mod", [v1; v2]  -> pp_mod pp_value v1 v2 fmt
288
  | "equi", [v1; v2] ->
289
    Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
290
  | "xor", [v1; v2]  ->
291
    Format.fprintf fmt "((not %a) /= (not %a))" pp_value v1 pp_value v2
292
  | "/", [v1; v2]    -> pp_div pp_value v1 v2 fmt
293
  | "&&", [v1; v2]    ->
294
    Format.fprintf fmt "(%a %s %a)" pp_value v1 "and then" pp_value v2
295
  | "||", [v1; v2]    ->
296
    Format.fprintf fmt "(%a %s %a)" pp_value v1 "or else" pp_value v2
297
  | "!=", [v1; v2]    ->
298
    Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2
299
  | op, [v1; v2]     ->
300
    Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
301
  | op, [v1] when  List.mem_assoc ident ada_supported_funs ->
302
    let pkg, name = try List.assoc ident ada_supported_funs
303
      with Not_found -> assert false in
304
    let pkg = pkg^(if String.equal pkg "" then "" else ".") in
305
      Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1
306
  | fun_name, _      ->
307
    (Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false)
308

  
309
(** Printing function for values.
310

  
311
    @param m the machine to know the state variable
312
    @param fmt the formater to use
313
    @param value the value to print. Should be a
314
           {!type:Machine_code_types.value_t} value
315
 **)
316
let rec pp_value m fmt value =
317
  match value.value_desc with
318
  | Cst c             -> pp_ada_const fmt c
319
  | Var var      -> pp_access_var m fmt var
320
  | Fun (f_ident, vl) -> pp_basic_lib_fun (pp_value m) f_ident fmt vl
321
  | _                 ->
322
    raise (Ada_not_supported
323
             "unsupported: Ada_backend.adb.pp_value does not support this value type")
466 324

  
467
(** Print the prototype of a procedure with non input/outputs
468
   @param fmt the formater to print on
469
   @param name the name of the procedure
470
**)
471
let pp_simple_prototype pp_name fmt =
472
  fprintf fmt "procedure %t" pp_name
473

  
474
(** Print the prototype of a machine procedure. The first parameter is always
475
the state, state_modifier specify the modifier applying to it. The next
476
parameters are inputs and the last parameters are the outputs.
477
   @param state_mode_opt None if no state parameter required and some input/output mode for it else
478
   @param input list of the input parameter of the procedure
479
   @param output list of the output parameter of the procedure
480
   @param fmt the formater to print on
481
   @param name the name of the procedure
482
**)
483
let pp_base_prototype state_mode_opt input output fmt pp_name =
484
  let pp_var_decl_state fmt = match state_mode_opt with
485
    | None -> fprintf fmt ""
486
    | Some state_mode -> fprintf fmt "%a" pp_state_var_decl state_mode
487
  in
488
  fprintf fmt "procedure %t(@[<v>%t%t@[%a@]%t@[%a@])@]"
489
    pp_name
490
    pp_var_decl_state
491
    (fun fmt -> if state_mode_opt != None && input!=[] then
492
      fprintf fmt ";@," else fprintf fmt "")
493
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl In)) input
494
    (fun fmt -> if (state_mode_opt != None || input!=[]) && output != [] then
495
      fprintf fmt ";@," else fprintf fmt "")
496
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output
497

  
498
(** Print the prototype of the step procedure of a machine.
499
   @param m the machine
500
   @param fmt the formater to print on
501
   @param pp_name name function printer
502
**)
503
let pp_step_prototype m fmt =
504
  let state_mode = if is_machine_statefull m then Some InOut else None in
505
  pp_base_prototype state_mode m.mstep.step_inputs m.mstep.step_outputs fmt pp_step_procedure_name
506 325

  
507
(** Print the prototype of the reset procedure of a machine.
508
   @param m the machine
509
   @param fmt the formater to print on
510
   @param pp_name name function printer
326
(** Print the filename of a machine package.
327
   @param extension the extension to append to the package name
328
   @param fmt the formatter
329
   @param machine the machine corresponding to the package
511 330
**)
512
let pp_reset_prototype m fmt =
513
  let state_mode = if is_machine_statefull m then Some Out else None in
514
  pp_base_prototype state_mode m.mstatic [] fmt pp_reset_procedure_name
331
let pp_machine_filename extension fmt machine =
332
  pp_filename extension fmt (pp_package_name machine)
515 333

  
516
(** Print the prototype of the init procedure of a machine.
517
   @param m the machine
518
   @param fmt the formater to print on
519
   @param pp_name name function printer
520
**)
521
let pp_init_prototype m fmt =
522
  let state_mode = if is_machine_statefull m then Some Out else None in
523
  pp_base_prototype state_mode m.mstatic [] fmt pp_init_procedure_name
334
let pp_main_filename fmt _ = pp_filename "adb" fmt pp_main_procedure_name
524 335

  
525
(** Print the prototype of the clear procedure of a machine.
526
   @param m the machine
527
   @param fmt the formater to print on
528
   @param pp_name name function printer
529
**)
530
let pp_clear_prototype m fmt =
531
  let state_mode = if is_machine_statefull m then Some InOut else None in
532
  pp_base_prototype state_mode m.mstatic [] fmt pp_clear_procedure_name
533 336

  
534
(** Print a one line comment with the final new line character to avoid
535
      commenting anything else.
337
(** Print the declaration of a state element of a subinstance of a machine.
338
   @param machine the machine
536 339
   @param fmt the formater to print on
537
   @param s the comment without newline character
538
**)
539
let pp_oneline_comment fmt s =
540
  assert (not (String.contains s '\n'));
541
  fprintf fmt "-- %s@," s
542

  
543

  
544
(* Functions which computes the substitution for polymorphic type *)
545

  
546
(** Check if a submachine is statefull.
547
    @param submachine a submachine
548
    @return true if the submachine is statefull
340
   @param substitution correspondance between polymorphic type id and their instantiation
341
   @param ident the identifier of the subinstance
342
   @param submachine the submachine of the subinstance
549 343
**)
550
let is_submachine_statefull submachine =
551
    not (snd (snd submachine)).mname.node_dec_stateless
344
let build_pp_state_decl_from_subinstance (name, (substitution, machine)) =
345
  let pp_package = pp_package_name_with_polymorphic substitution machine in
346
  let pp_type = pp_package_access (pp_package, pp_state_type) in
347
  let pp_name fmt = pp_clean_ada_identifier fmt name in
348
  (AdaNoMode, pp_name, pp_type)
552 349

  
553
(** Find a submachine step call in a list of instructions.
554
    @param ident submachine instance ident
555
    @param instr_list List of instruction sto search
556
    @return a list of pair containing input types and output types for each step call found
557
**)
558
let rec find_submachine_step_call ident instr_list =
559
  let search_instr instruction = 
560
    match instruction.instr_desc with
561
      | MStep (il, i, vl) when String.equal i ident -> [
562
        (List.map (function x-> x.value_type) vl,
563
            List.map (function x-> x.var_type) il)]
564
      | MBranch (_, l) -> List.flatten
565
          (List.map (function x, y -> find_submachine_step_call ident y) l)
566
      | _ -> []
567
  in
568
  List.flatten (List.map search_instr instr_list)
569

  
570
(** Check that two types are the same.
571
   @param t1 a type
572
   @param t2 an other type
573
   @param return true if the two types are Tbasic or Tunivar and equal
574
**)
575
let rec check_type_equal (t1:Types.type_expr) (t2:Types.type_expr) =
576
  match (Types.repr t1).Types.tdesc, (Types.repr t2).Types.tdesc with
577
    | Types.Tbasic x, Types.Tbasic y -> x = y
578
    | Types.Tunivar,  Types.Tunivar  -> t1.tid = t2.tid
579
    | Types.Ttuple l, _ -> assert (List.length l = 1); check_type_equal (List.hd l) t2
580
    | _, Types.Ttuple l -> assert (List.length l = 1); check_type_equal t1 (List.hd l)
581
    | Types.Tstatic (_, t), _ -> check_type_equal t t2
582
    | _, Types.Tstatic (_, t) -> check_type_equal t1 t
583
    | _ -> eprintf "ERROR: %a | %a" pp_type t1 pp_type t2; assert false (* TODO *)
584

  
585
(** Extend a substitution to unify the two given types. Only the
586
  first type can be polymorphic.
587
    @param subsitution the base substitution
588
    @param type_poly the type which can be polymorphic
589
    @param typ the type to match type_poly with
590
**)
591
let unification (substituion:(int*Types.type_expr) list) ((type_poly:Types.type_expr), (typ:Types.type_expr)) =
592
  assert(not (is_Tunivar typ));
593
  (* If type_poly is polymorphic *)
594
  if is_Tunivar type_poly then
595
    (* If a subsitution exists for it *)
596
    if List.mem_assoc type_poly.tid substituion then
597
    begin
598
      (* We check that the type corresponding to type_poly in the subsitution
599
         match typ *)
600
      (try
601
        assert(check_type_equal (List.assoc type_poly.tid substituion) typ)
602
      with
603
        Not_found -> assert false);
604
      (* We return the original substituion, it is already correct *)
605
      substituion
606
    end
607
    (* If type_poly is not in the subsitution *)
608
    else
609
      (* We add it to the substituion *)
610
      (type_poly.tid, typ)::substituion
611
  (* iftype_poly is not polymorphic *)
612
  else
613
  begin
614
    (* We check that type_poly and typ are the same *)
615
    assert(check_type_equal type_poly typ);
616
    (* We return the original substituion, it is already correct *)
617
    substituion
618
  end
619

  
620
(** Check that two calls are equal. A call is
621
  a pair of list of types, the inputs and the outputs.
622
   @param calls a list of pair of list of types
623
   @param return true if the two pairs are equal
624
**)
625
let check_call_equal (i1, o1) (i2, o2) =
626
  (List.for_all2 check_type_equal i1 i2)
627
    && (List.for_all2 check_type_equal i1 i2)
628

  
629
(** Check that all the elements of list of calls are equal to one.
630
  A call is a pair of list of types, the inputs and the outputs.
631
   @param call a pair of list of types
632
   @param calls a list of pair of list of types
633
   @param return true if all the elements are equal
634
**)
635
let check_calls call calls =
636
  List.for_all (check_call_equal call) calls
637

  
638
(** Extract from a subinstance that can have polymorphic type the instantiation
639
    of all its polymorphic type instanciation for a given machine. It searches
640
    the step calls and extract a substitution for all polymorphic type from
641
    it.
642
   @param machine the machine which instantiate the subinstance
643
   @param ident the identifier of the instance which permits to find the step call
644
   @param submachine the machine corresponding to the subinstance
645
   @return the correspondance between polymorphic type id and their instantiation
646
**)
647
let get_substitution machine ident submachine =
648
  (* extract the calls to submachines from the machine *)
649
  let calls = find_submachine_step_call ident machine.mstep.step_instrs in
650
  (* extract the first call  *)
651
  let call = match calls with
652
              (* assume that there is always one call to a subinstance *)
653
              | []    -> assert(false)
654
              | h::t  -> h in
655
  (* assume that all the calls to a subinstance are using the same type *)
656
  assert(check_calls call calls);
657
  (* make a list of all types from input and output vars *)
658
  let call_types = (fst call)@(snd call) in
659
  (* extract all the input and output vars from the submachine *)
660
  let machine_vars = submachine.mstep.step_inputs@submachine.mstep.step_outputs in
661
  (* keep only the type of vars *)
662
  let machine_types = List.map (function x-> x.var_type) machine_vars in
663
  (* assume that there is the same numer of input and output in the submachine
664
      and the call *)
665
  assert (List.length machine_types = List.length call_types);
666
  (* Unify the two lists of types *)
667
  let substitution = List.fold_left unification [] (List.combine machine_types call_types) in
668
  (* Assume that our substitution match all the possible
669
       polymorphic type of the node *)
670
  let polymorphic_types = find_all_polymorphic_type submachine in
671
  assert (List.length polymorphic_types = List.length substitution);
672
  (try
673
    assert (List.for_all (fun x -> List.mem_assoc x substitution) polymorphic_types)
674
  with
675
    Not_found -> assert false);
676
  substitution
677

  
678

  
679
(* Procedure pretty print functions *)
680

  
681
let pp_block pp_item fmt items =
682
  fprintf fmt "  @[<v>%a%t@]@,"
683
    (Utils.fprintf_list ~sep:";@," pp_item) items
684
    (Utils.pp_final_char_if_non_empty ";" items)
685

  
686
(** Print the definition of a procedure
687
   @param pp_name the procedure name printer
688
   @param pp_prototype the prototype printer
689
   @param pp_instr local var printer
690
   @param pp_instr instruction printer
350
(** Print variable declaration for a local state variable
691 351
   @param fmt the formater to print on
692
   @param locals locals var list
693
   @param instrs instructions list
352
   @param mode input/output mode of the parameter
694 353
**)
695
let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) =
696
  fprintf fmt "@[<v>%t is@,%abegin@,%aend %t@]"
697
    pp_prototype
698
    (pp_block pp_local) locals
699
    (pp_block pp_instr) instrs
700
    pp_name
701

  
702

  
703
(* Expression print functions *)
354
let build_pp_state_decl mode =
355
  (mode, pp_state_name, pp_state_type)
704 356

  
705
  (* Printing functions for basic operations and expressions *)
706
  (* TODO: refactor code -> use let rec and for basic pretty printing
707
     function *)
708
  (** Printing function for Ada tags, mainly booleans.
709

  
710
      @param fmt the formater to use
711
      @param t the tag to print
712
   **)
713
  let pp_ada_tag fmt t =
714
    pp_print_string fmt
715
      (if t = tag_true then "True" else if t = tag_false then "False" else t)
716

  
717
  (** Printing function for machine type constants. For the moment,
718
      arrays are not supported.
719

  
720
      @param fmt the formater to use
721
      @param c the constant to print
722
   **)
723
  let pp_ada_const fmt c =
724
    match c with
725
    | Const_int i                     -> pp_print_int fmt i
726
    | Const_real (c, e, s)            ->
727
        fprintf fmt "%s.0*1.0e-%i" (Num.string_of_num c) e
728
    | Const_tag t                     -> pp_ada_tag fmt t
729
    | Const_string _ | Const_modeid _ ->
730
      (Format.eprintf
731
         "internal error: Ada_backend_adb.pp_ada_const cannot print string or modeid.";
732
       assert false)
733
    | _                               ->
734
      raise (Ada_not_supported "unsupported: Ada_backend_adb.pp_ada_const does not
735
      support this constant")
736

  
737
  (** Printing function for expressions [v1 modulo v2]. Depends
738
      on option [integer_div_euclidean] to choose between mathematical
739
      modulo or remainder ([rem] in Ada).
740

  
741
      @param pp_value pretty printer for values
742
      @param v1 the first value in the expression
743
      @param v2 the second value in the expression
744
      @param fmt the formater to print on
745
   **)
746
  let pp_mod pp_value v1 v2 fmt =
747
    if !Options.integer_div_euclidean then
748
      (* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
749
      Format.fprintf fmt
750
        "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
751
        pp_value v1 pp_value v2
752
        pp_value v1 pp_value v2
753
        pp_value v2
754
    else (* Ada behavior for rem *)
755
      Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
756

  
757
  (** Printing function for expressions [v1 div v2]. Depends on
758
      option [integer_div_euclidean] to choose between mathematic
759
      division or Ada division.
760

  
761
      @param pp_value pretty printer for values
762
      @param v1 the first value in the expression
763
      @param v2 the second value in the expression
764
      @param fmt the formater to print in
765
   **)
766
  let pp_div pp_value v1 v2 fmt =
767
    if !Options.integer_div_euclidean then
768
      (* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
769
      Format.fprintf fmt "(%a - %t) / %a"
770
        pp_value v1
771
        (pp_mod pp_value v1 v2)
772
        pp_value v2
773
    else (* Ada behavior for / *)
774
      Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
775

  
776
  (** Printing function for basic lib functions.
777

  
778
      @param pp_value pretty printer for values
779
      @param i a string representing the function
780
      @param fmt the formater to print on
781
      @param vl the list of operands
782
   **)
783
  let pp_basic_lib_fun pp_value ident fmt vl =
784
    match ident, vl with
785
    | "uminus", [v]    ->
786
      Format.fprintf fmt "(- %a)" pp_value v
787
    | "not", [v]       ->
788
      Format.fprintf fmt "(not %a)" pp_value v
789
    | "impl", [v1; v2] ->
790
      Format.fprintf fmt "(not %a or else %a)" pp_value v1 pp_value v2
791
    | "=", [v1; v2]    ->
792
      Format.fprintf fmt "(%a = %a)" pp_value v1 pp_value v2
793
    | "mod", [v1; v2]  -> pp_mod pp_value v1 v2 fmt
794
    | "equi", [v1; v2] ->
795
      Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
796
    | "xor", [v1; v2]  ->
797
      Format.fprintf fmt "((not %a) /= (not %a))" pp_value v1 pp_value v2
798
    | "/", [v1; v2]    -> pp_div pp_value v1 v2 fmt
799
    | "&&", [v1; v2]    ->
800
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "and then" pp_value v2
801
    | "||", [v1; v2]    ->
802
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "or else" pp_value v2
803
    | "!=", [v1; v2]    ->
804
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2
805
    | op, [v1; v2]     ->
806
      Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
807
    | op, [v1] when  List.mem_assoc ident ada_supported_funs ->
808
      let pkg, name = try List.assoc ident ada_supported_funs
809
        with Not_found -> assert false in
810
      let pkg = pkg^(if String.equal pkg "" then "" else ".") in
811
        Format.fprintf fmt "%s%s(%a)" pkg name pp_value v1
812
    | fun_name, _      ->
813
      (Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false)
814

  
815
  (** Printing function for values.
816

  
817
      @param m the machine to know the state variable
818
      @param fmt the formater to use
819
      @param value the value to print. Should be a
820
             {!type:Machine_code_types.value_t} value
821
   **)
822
  let rec pp_value m fmt value =
823
    match value.value_desc with
824
    | Cst c             -> pp_ada_const fmt c
825
    | Var var      -> pp_access_var m fmt var
826
    | Fun (f_ident, vl) -> pp_basic_lib_fun (pp_value m) f_ident fmt vl
827
    | _                 ->
828
      raise (Ada_not_supported
829
               "unsupported: Ada_backend.adb.pp_value does not support this value type")
357
let build_pp_var_decl mode var =
358
  let pp_name = function fmt -> pp_var_name fmt var in
359
  let pp_type = function fmt -> pp_var_type fmt var in
360
  (mode, pp_name, pp_type)
830 361

  
362
let build_pp_var_decl_local var =
363
  AdaLocalVar (build_pp_var_decl AdaNoMode var)
831 364

  
832
(** Print the filename of a machine package.
833
   @param extension the extension to append to the package name
834
   @param fmt the formatter
835
   @param machine the machine corresponding to the package
836
**)
837
let pp_machine_filename extension fmt machine =
838
  pp_filename extension fmt (function fmt -> pp_package_name fmt machine)
365
let build_pp_var_decl_step_input mode m =
366
  if m.mstep.step_inputs=[] then [] else
367
    [List.map (build_pp_var_decl mode) m.mstep.step_inputs]
839 368

  
840
let pp_main_filename fmt _ = pp_filename "adb" fmt pp_main_procedure_name
841

  
842
(** Extract from a machine the instance corresponding to the identifier,
843
      assume that the identifier exists in the instances of the machine.
844

  
845
   @param identifier the instance identifier
846
   @param machine a machine
847
   @return the instance of machine.minstances corresponding to identifier
848
**)
849
let get_instance identifier typed_submachines =
850
  try
851
    List.assoc identifier typed_submachines
852
  with Not_found -> assert false
369
let build_pp_var_decl_step_output mode m =
370
  if m.mstep.step_outputs=[] then [] else
371
    [List.map (build_pp_var_decl mode) m.mstep.step_outputs]
853 372

  
854
(** Printing a call to a package function
373
let build_pp_var_decl_static mode m =
374
  if m.mstatic=[] then [] else
375
    [List.map (build_pp_var_decl mode) m.mstatic]
855 376

  
856
    @param typed_submachines list of all typed machine instances of this machine
857
    @param pp_name printer for the function name
858
    @param fmt the formater to use
859
    @param identifier the instance identifier
860
    @param pp_args_opt optional printer for other arguments
861
 **)
862
let pp_package_call pp_name fmt (substitution, submachine, pp_state, pp_args_opt) =
863
  let statefull = is_machine_statefull submachine in
864
  let pp_opt fmt = function
865
      | Some pp_args when statefull -> fprintf fmt ",@,%t" pp_args
866
      | Some pp_args -> pp_args fmt
867
      | None -> fprintf fmt ""
868
  in
869
  let pp_state fmt =
870
    if statefull then
871
      pp_state fmt
872
    else
873
      fprintf fmt ""
874
  in
875
  fprintf fmt "%a.%t(@[<v>%t%a@])"
876
    (pp_package_name_with_polymorphic substitution) submachine
877
    pp_name
878
    pp_state
879
    pp_opt pp_args_opt
377
let build_pp_arg_step m =
378
  (if is_machine_statefull m then [[build_pp_state_decl AdaInOut]] else [])
379
    @ (build_pp_var_decl_step_input AdaIn m)
380
    @ (build_pp_var_decl_step_output AdaOut m)
880 381

  
382
let build_pp_arg_reset m =
383
  (if is_machine_statefull m then [[build_pp_state_decl AdaOut]] else [])
384
    @ (build_pp_var_decl_static AdaIn m)

Also available in: Unified diff