Project

General

Profile

Download (19 KB) Statistics
| Branch: | Tag: | Revision:
1
open Format
2

    
3
open Machine_code_types
4
open Lustre_types
5
open Corelang
6
open Machine_code_common
7

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

    
11
(** All the pretty print functions common to the ada backend **)
12

    
13
(* Misc pretty print functions *)
14

    
15
(** Print a cleaned an identifier for ada exportation : Ada names must not start by an
16
    underscore and must not contain a double underscore
17
   @param var name to be cleaned*)
18
let pp_clean_ada_identifier fmt name =
19
  let base_size = String.length name in
20
  assert(base_size > 0);
21
  let rec remove_double_underscore s = function
22
    | i when i == String.length s - 1 -> s
23
    | i when String.get s i == '_' && String.get s (i+1) == '_' ->
24
        remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i
25
    | i -> remove_double_underscore s (i+1)
26
  in
27
  let name = remove_double_underscore name 0 in
28
  let prefix = if String.length name != base_size
29
                  || String.get name 0 == '_' then
30
                  "ada"
31
               else
32
                  ""
33
  in
34
  fprintf fmt "%s%s" prefix name
35

    
36
(** Encapsulate a pretty print function to lower case its result when applied
37
   @param pp the pretty print function
38
   @param fmt the formatter
39
   @param arg the argument of the pp function
40
**)
41
let pp_lowercase pp fmt =
42
  let str = asprintf "%t" pp in
43
  fprintf fmt "%s" (String. lowercase_ascii str)
44

    
45
(** Print a filename by lowercasing the base and appending an extension.
46
   @param extension the extension to append to the package name
47
   @param fmt the formatter
48
   @param pp_name the file base name printer
49
**)
50
let pp_filename extension fmt pp_name =
51
  fprintf fmt "%t.%s"
52
    (pp_lowercase pp_name)
53
    extension
54

    
55

    
56
(* Package pretty print functions *)
57

    
58
(** Print the name of the arrow package.
59
   @param fmt the formater to print on
60
**)
61
let pp_arrow_package_name fmt = fprintf fmt "Arrow"
62

    
63
(** Print the name of a package associated to a node.
64
   @param fmt the formater to print on
65
   @param machine the machine
66
**)
67
let pp_package_name_from_node fmt node =
68
  if String.equal Arrow.arrow_id node.node_id then
69
      fprintf fmt "%t" pp_arrow_package_name
70
  else
71
      fprintf fmt "%a" pp_clean_ada_identifier node.node_id
72

    
73
(** Print the name of a package associated to a machine.
74
   @param fmt the formater to print on
75
   @param machine the machine
76
**)
77
let pp_package_name fmt machine =
78
  pp_package_name_from_node fmt machine.mname
79

    
80
(** Print the ada package introduction sentence it can be used for body and
81
declaration. Boolean parameter body should be true if it is a body delcaration.
82
   @param fmt the formater to print on
83
   @param fmt the formater to print on
84
   @param machine the machine
85
**)
86
let pp_begin_package body fmt machine =
87
  fprintf fmt "package %s%a is"
88
    (if body then "body " else "")
89
    pp_package_name machine
90

    
91
(** Print the ada package conclusion sentence.
92
   @param fmt the formater to print on
93
   @param machine the machine
94
**)
95
let pp_end_package fmt machine =
96
  fprintf fmt "end %a" pp_package_name machine
97

    
98
(** Print the access of an item from an other package.
99
   @param fmt the formater to print on
100
   @param package the package to use
101
   @param item the item which is accessed
102
**)
103
let pp_package_access fmt (package, item) =
104
  fprintf fmt "%t.%t" package item
105

    
106
(** Print the name of the main procedure.
107
   @param fmt the formater to print on
108
**)
109
let pp_main_procedure_name fmt =
110
  fprintf fmt "main"
111

    
112
(** Extract a node from an instance.
113
   @param instance the instance
114
**)
115
let extract_node instance =
116
  let (_, (node, _)) = instance in
117
  match node.top_decl_desc with
118
    | Node nd         -> nd
119
    | _ -> assert false (*TODO*)
120

    
121
(** Print a with statement to include a package.
122
   @param fmt the formater to print on
123
   @param pp_pakage_name the package name printer
124
**)
125
let pp_with fmt pp_pakage_name =
126
  fprintf fmt "with %t" pp_pakage_name
127

    
128
(** Print a with statement to include a machine.
129
   @param fmt the formater to print on
130
   @param machine the machine
131
**)
132
let pp_with_machine fmt machine =
133
  fprintf fmt "private with %a" pp_package_name machine
134

    
135

    
136
(* Type pretty print functions *)
137

    
138
(** Print a type declaration
139
   @param fmt the formater to print on
140
   @param pp_name a format printer which print the type name
141
   @param pp_value a format printer which print the type definition
142
**)
143
let pp_type_decl fmt (pp_name, pp_definition) =
144
  fprintf fmt "type %t is %t" pp_name pp_definition
145

    
146
(** Print a limited private type declaration
147
   @param fmt the formater to print on
148
   @param pp_name a format printer which print the type name
149
**)
150
let pp_private_limited_type_decl fmt pp_name =
151
  let pp_definition fmt = fprintf fmt "limited private" in
152
  pp_type_decl fmt (pp_name, pp_definition)
153

    
154
(** Print the type of the state variable.
155
   @param fmt the formater to print on
156
**)
157
let pp_state_type fmt =
158
  (* Type and variable names live in the same environement in Ada so name of
159
     this type and of the associated parameter : pp_state_name must be
160
     different *)
161
  fprintf fmt "TState"
162

    
163
(** Print the integer type name.
164
   @param fmt the formater to print on
165
**)
166
let pp_integer_type fmt = fprintf fmt "Integer"
167

    
168
(** Print the float type name.
169
   @param fmt the formater to print on
170
**)
171
let pp_float_type fmt = fprintf fmt "Float"
172

    
173
(** Print the boolean type name.
174
   @param fmt the formater to print on
175
**)
176
let pp_boolean_type fmt = fprintf fmt "Boolean"
177

    
178
(** Print the type of a polymorphic type.
179
   @param fmt the formater to print on
180
   @param id the id of the polymorphic type
181
**)
182
let pp_polymorphic_type fmt id =
183
  fprintf fmt "T_%i" id
184

    
185
(** Print a type.
186
   @param fmt the formater to print on
187
   @param type the type
188
**)
189
let pp_type fmt typ = 
190
  (match (Types.repr typ).Types.tdesc with
191
    | Types.Tbasic Types.Basic.Tint  -> pp_integer_type fmt
192
    | Types.Tbasic Types.Basic.Treal -> pp_float_type fmt
193
    | Types.Tbasic Types.Basic.Tbool -> pp_boolean_type fmt
194
    | Types.Tunivar _                -> pp_polymorphic_type fmt typ.tid
195
    | Types.Tconst _                 -> eprintf "Tconst@."; assert false (*TODO*)
196
    | Types.Tclock _                 -> eprintf "Tclock@."; assert false (*TODO*)
197
    | Types.Tarrow _                 -> eprintf "Tarrow@."; assert false (*TODO*)
198
    | Types.Ttuple l                 -> eprintf "Ttuple %a @." (Utils.fprintf_list ~sep:" " Types.print_ty) l; assert false (*TODO*)
199
    | Types.Tenum _                  -> eprintf "Tenum@.";  assert false (*TODO*)
200
    | Types.Tstruct _                -> eprintf "Tstruct@.";assert false (*TODO*)
201
    | Types.Tarray _                 -> eprintf "Tarray@."; assert false (*TODO*)
202
    | Types.Tstatic _                -> eprintf "Tstatic@.";assert false (*TODO*)
203
    | Types.Tlink _                  -> eprintf "Tlink@.";  assert false (*TODO*)
204
    | Types.Tvar _                   -> eprintf "Tvar@.";   assert false (*TODO*)
205
    | _ -> eprintf "Type error : %a@." Types.print_ty typ; assert false (*TODO*)
206
  )
207

    
208
(** Print the type of a variable.
209
   @param fmt the formater to print on
210
   @param id the variable
211
**)
212
let pp_var_type fmt id = 
213
  pp_type fmt id.var_type
214

    
215
(** Extract all the inputs and outputs.
216
   @param machine the machine
217
   @return a list of all the var_decl of a macine
218
**)
219
let get_all_vars_machine m =
220
  m.mmemory@m.mstep.step_inputs@m.mstep.step_outputs@m.mstatic
221

    
222
(** Check if a type is polymorphic.
223
   @param typ the type
224
   @return true if its polymorphic
225
**)
226
let is_Tunivar typ = (Types.repr typ).tdesc == Types.Tunivar
227

    
228
(** Find all polymorphic type : Types.Tunivar in a machine.
229
   @param machine the machine
230
   @return a list of id corresponding to polymorphic type
231
**)
232
let find_all_polymorphic_type m =
233
  let vars = get_all_vars_machine m in
234
  let extract id = id.var_type.tid in
235
  let polymorphic_type_vars =
236
    List.filter (function x-> is_Tunivar x.var_type) vars in
237
  List.sort_uniq (-) (List.map extract polymorphic_type_vars)
238

    
239
(** Print a package name with polymorphic types specified.
240
   @param substitution correspondance between polymorphic type id and their instantiation
241
   @param fmt the formater to print on
242
   @param machine the machine
243
**)
244
let pp_package_name_with_polymorphic substitution fmt machine =
245
  let polymorphic_types = find_all_polymorphic_type machine in
246
  assert(List.length polymorphic_types = List.length substitution);
247
  let substituion = List.sort_uniq (fun x y -> fst x - fst y) substitution in
248
  assert(List.for_all2 (fun poly1 (poly2, _) -> poly1 = poly2)
249
            polymorphic_types substituion);
250
  let instantiated_types = snd (List.split substitution) in
251
  fprintf fmt "%a%t%a"
252
    pp_package_name machine
253
    (Utils.pp_final_char_if_non_empty "_" instantiated_types)
254
    (Utils.fprintf_list ~sep:"_" pp_type) instantiated_types
255

    
256

    
257
(* Variable pretty print functions *)
258

    
259
(** Represent the possible mode for a type of a procedure parameter **)
260
type parameter_mode = NoMode | In | Out | InOut
261

    
262
(** Print a parameter_mode.
263
   @param fmt the formater to print on
264
   @param mode the modifier
265
**)
266
let pp_parameter_mode fmt mode =
267
  fprintf fmt "%s" (match mode with
268
                     | NoMode -> ""
269
                     | In     -> "in"
270
                     | Out    -> "out"
271
                     | InOut  -> "in out")
272

    
273
(** Print the name of the state variable.
274
   @param fmt the formater to print on
275
**)
276
let pp_state_name fmt =
277
  fprintf fmt "state"
278

    
279

    
280
(** Print the name of a variable.
281
   @param fmt the formater to print on
282
   @param id the variable
283
**)
284
let pp_var_name fmt id =
285
  fprintf fmt "%a" pp_clean_ada_identifier id.var_id
286

    
287
(** Print the complete name of variable.
288
   @param m the machine to check if it is memory
289
   @param fmt the formater to print on
290
   @param var the variable
291
**)
292
let pp_access_var m fmt var =
293
  if is_memory m var then
294
    fprintf fmt "%t.%a" pp_state_name pp_var_name var
295
  else
296
    pp_var_name fmt var
297

    
298
(** Print a variable declaration
299
   @param mode input/output mode of the parameter
300
   @param pp_name a format printer wich print the variable name
301
   @param pp_type a format printer wich print the variable type
302
   @param fmt the formater to print on
303
   @param id the variable
304
**)
305
let pp_var_decl fmt (mode, pp_name, pp_type) =
306
  fprintf fmt "%t: %a%s%t"
307
    pp_name
308
    pp_parameter_mode mode
309
    (if mode = NoMode then "" else " ")
310
    pp_type
311

    
312
(** Print variable declaration for machine variable
313
   @param mode input/output mode of the parameter
314
   @param fmt the formater to print on
315
   @param id the variable
316
**)
317
let pp_machine_var_decl mode fmt id =
318
  let pp_name = function fmt -> pp_var_name fmt id in
319
  let pp_type = function fmt -> pp_var_type fmt id in
320
  pp_var_decl fmt (mode, pp_name, pp_type)
321

    
322
(** Print variable declaration for a local state variable
323
   @param fmt the formater to print on
324
   @param mode input/output mode of the parameter
325
**)
326
let pp_state_var_decl fmt mode =
327
  let pp_name = pp_state_name in
328
  let pp_type = pp_state_type in
329
  pp_var_decl fmt (mode, pp_name, pp_type)
330

    
331
(** Print the declaration of a state element of a machine.
332
   @param substitution correspondance between polymorphic type id and their instantiation
333
   @param name name of the variable
334
   @param fmt the formater to print on
335
   @param machine the machine
336
**)
337
let pp_node_state_decl substitution name fmt machine =
338
  let pp_package fmt = pp_package_name_with_polymorphic substitution fmt machine in
339
  let pp_type fmt = pp_package_access fmt (pp_package, pp_state_type) in
340
  let pp_name fmt = pp_clean_ada_identifier fmt name in
341
  pp_var_decl fmt (NoMode, pp_name, pp_type)
342

    
343

    
344
(* Prototype pretty print functions *)
345

    
346
(** Print the name of the reset procedure **)
347
let pp_reset_procedure_name fmt = fprintf fmt "reset"
348

    
349
(** Print the name of the step procedure **)
350
let pp_step_procedure_name fmt = fprintf fmt "step"
351

    
352
(** Print the name of the init procedure **)
353
let pp_init_procedure_name fmt = fprintf fmt "init"
354

    
355
(** Print the name of the clear procedure **)
356
let pp_clear_procedure_name fmt = fprintf fmt "clear"
357

    
358
(** Print the prototype of a procedure with non input/outputs
359
   @param fmt the formater to print on
360
   @param name the name of the procedure
361
**)
362
let pp_simple_prototype pp_name fmt =
363
  fprintf fmt "procedure %t" pp_name
364

    
365
(** Print the prototype of a machine procedure. The first parameter is always
366
the state, state_modifier specify the modifier applying to it. The next
367
parameters are inputs and the last parameters are the outputs.
368
   @param state_mode the input/output mode for the state parameter
369
   @param input list of the input parameter of the procedure
370
   @param output list of the output parameter of the procedure
371
   @param fmt the formater to print on
372
   @param name the name of the procedure
373
**)
374
let pp_base_prototype state_mode input output fmt pp_name =
375
  fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]"
376
    pp_name
377
    pp_state_var_decl state_mode
378
    (Utils.pp_final_char_if_non_empty ";@," input)
379
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl In)) input
380
    (Utils.pp_final_char_if_non_empty ";@," output)
381
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output
382

    
383
(** Print the prototype of the step procedure of a machine.
384
   @param m the machine
385
   @param fmt the formater to print on
386
   @param pp_name name function printer
387
**)
388
let pp_step_prototype m fmt =
389
  pp_base_prototype InOut m.mstep.step_inputs m.mstep.step_outputs fmt pp_step_procedure_name
390

    
391
(** Print the prototype of the reset procedure of a machine.
392
   @param m the machine
393
   @param fmt the formater to print on
394
   @param pp_name name function printer
395
**)
396
let pp_reset_prototype m fmt =
397
  pp_base_prototype InOut m.mstatic [] fmt pp_reset_procedure_name
398

    
399
(** Print the prototype of the init procedure of a machine.
400
   @param m the machine
401
   @param fmt the formater to print on
402
   @param pp_name name function printer
403
**)
404
let pp_init_prototype m fmt =
405
  pp_base_prototype Out m.mstatic [] fmt pp_init_procedure_name
406

    
407
(** Print the prototype of the clear procedure of a machine.
408
   @param m the machine
409
   @param fmt the formater to print on
410
   @param pp_name name function printer
411
**)
412
let pp_clear_prototype m fmt =
413
  pp_base_prototype InOut m.mstatic [] fmt pp_clear_procedure_name
414

    
415

    
416
(* Procedure pretty print functions *)
417

    
418
(** Print the definition of a procedure
419
   @param pp_name the procedure name printer
420
   @param pp_prototype the prototype printer
421
   @param pp_instr local var printer
422
   @param pp_instr instruction printer
423
   @param fmt the formater to print on
424
   @param locals locals var list
425
   @param instrs instructions list
426
**)
427
let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) =
428
  fprintf fmt "@[<v>%t is%t@[<v>%a%t@]@,begin@,  @[<v>%a%t@]@,end %t@]"
429
    pp_prototype
430
    (Utils.pp_final_char_if_non_empty "@,  " locals)
431
    (Utils.fprintf_list ~sep:";@," pp_local) locals
432
    (Utils.pp_final_char_if_non_empty ";" locals)
433
    (Utils.fprintf_list ~sep:";@," pp_instr) instrs
434
    (Utils.pp_final_char_if_non_empty ";" instrs)
435
    pp_name
436

    
437

    
438
(* Expression print functions *)
439

    
440
  (* Printing functions for basic operations and expressions *)
441
  (* TODO: refactor code -> use let rec and for basic pretty printing
442
     function *)
443
  (** Printing function for Ada tags, mainly booleans.
444

    
445
      @param fmt the formater to use
446
      @param t the tag to print
447
   **)
448
  let pp_ada_tag fmt t =
449
    pp_print_string fmt
450
      (if t = tag_true then "True" else if t = tag_false then "Flase" else t)
451

    
452
  (** Printing function for machine type constants. For the moment,
453
      arrays are not supported.
454

    
455
      @param fmt the formater to use
456
      @param c the constant to print
457
   **)
458
  let pp_ada_const fmt c =
459
    match c with
460
    | Const_int i                     -> pp_print_int fmt i
461
    | Const_real (c, e, s)            -> pp_print_string fmt s
462
    | Const_tag t                     -> pp_ada_tag fmt t
463
    | Const_string _ | Const_modeid _ ->
464
      (Format.eprintf
465
         "internal error: Ada_backend_adb.pp_ada_const cannot print string or modeid.";
466
       assert false)
467
    | _                               ->
468
      raise (Ada_not_supported "unsupported: Ada_backend_adb.pp_ada_const does not
469
      support this constant")
470

    
471
  (** Printing function for expressions [v1 modulo v2]. Depends
472
      on option [integer_div_euclidean] to choose between mathematical
473
      modulo or remainder ([rem] in Ada).
474

    
475
      @param pp_value pretty printer for values
476
      @param v1 the first value in the expression
477
      @param v2 the second value in the expression
478
      @param fmt the formater to print on
479
   **)
480
  let pp_mod pp_value v1 v2 fmt =
481
    if !Options.integer_div_euclidean then
482
      (* (a rem b) + (a rem b < 0 ? abs(b) : 0) *)
483
      Format.fprintf fmt
484
        "((%a rem %a) + (if (%a rem %a) < 0 then abs(%a) else 0))"
485
        pp_value v1 pp_value v2
486
        pp_value v1 pp_value v2
487
        pp_value v2
488
    else (* Ada behavior for rem *)
489
      Format.fprintf fmt "(%a rem %a)" pp_value v1 pp_value v2
490

    
491
  (** Printing function for expressions [v1 div v2]. Depends on
492
      option [integer_div_euclidean] to choose between mathematic
493
      division or Ada division.
494

    
495
      @param pp_value pretty printer for values
496
      @param v1 the first value in the expression
497
      @param v2 the second value in the expression
498
      @param fmt the formater to print in
499
   **)
500
  let pp_div pp_value v1 v2 fmt =
501
    if !Options.integer_div_euclidean then
502
      (* (a - ((a rem b) + (if a rem b < 0 then abs (b) else 0))) / b) *)
503
      Format.fprintf fmt "(%a - %t) / %a"
504
        pp_value v1
505
        (pp_mod pp_value v1 v2)
506
        pp_value v2
507
    else (* Ada behavior for / *)
508
      Format.fprintf fmt "(%a / %a)" pp_value v1 pp_value v2
509

    
510
  (** Printing function for basic lib functions.
511

    
512
      @param pp_value pretty printer for values
513
      @param i a string representing the function
514
      @param fmt the formater to print on
515
      @param vl the list of operands
516
   **)
517
  let pp_basic_lib_fun pp_value ident fmt vl =
518
    match ident, vl with
519
    | "uminus", [v]    ->
520
      Format.fprintf fmt "(- %a)" pp_value v
521
    | "not", [v]       ->
522
      Format.fprintf fmt "(not %a)" pp_value v
523
    | "impl", [v1; v2] ->
524
      Format.fprintf fmt "(not %a or else %a)" pp_value v1 pp_value v2
525
    | "=", [v1; v2]    ->
526
      Format.fprintf fmt "(%a = %a)" pp_value v1 pp_value v2
527
    | "mod", [v1; v2]  -> pp_mod pp_value v1 v2 fmt
528
    | "equi", [v1; v2] ->
529
      Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
530
    | "xor", [v1; v2]  ->
531
      Format.fprintf fmt "((not %a) \\= (not %a))" pp_value v1 pp_value v2
532
    | "/", [v1; v2]    -> pp_div pp_value v1 v2 fmt
533
    | op, [v1; v2]     ->
534
      Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
535
    | fun_name, _      ->
536
      (Format.eprintf "internal compilation error: basic function %s@." fun_name; assert false)
537

    
538
  (** Printing function for values.
539

    
540
      @param m the machine to know the state variable
541
      @param fmt the formater to use
542
      @param value the value to print. Should be a
543
             {!type:Machine_code_types.value_t} value
544
   **)
545
  let rec pp_value m fmt value =
546
    match value.value_desc with
547
    | Cst c             -> pp_ada_const fmt c
548
    | Var var      -> pp_access_var m fmt var
549
    | Fun (f_ident, vl) -> pp_basic_lib_fun (pp_value m) f_ident fmt vl
550
    | _                 ->
551
      raise (Ada_not_supported
552
               "unsupported: Ada_backend.adb.pp_value does not support this value type")
(5-5/6)