Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / Ada / ada_backend_common.ml @ fd834769

History | View | Annotate | Download (10.3 KB)

1
open Format
2

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

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

    
10
(* Misc pretty print functions *)
11

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

    
33
(* Package pretty print functions *)
34

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

    
42
(** Print the ada package introduction sentence it can be used for body and
43
declaration. Boolean parameter body should be true if it is a body delcaration.
44
   @param fmt the formater to print on
45
   @param fmt the formater to print on
46
   @param machine the machine
47
**)
48
let pp_begin_package body fmt machine =
49
  fprintf fmt "package %s%a is"
50
    (if body then "body " else "")
51
    pp_package_name machine.mname
52

    
53
(** Print the ada package conclusion sentence.
54
   @param fmt the formater to print on
55
   @param machine the machine
56
**)
57
let pp_end_package fmt machine =
58
  fprintf fmt "end %a" pp_package_name machine.mname
59

    
60
(** Print the access of an item from an other package.
61
   @param fmt the formater to print on
62
   @param package the package to use
63
   @param item the item which is accessed
64
**)
65
let pp_package_access fmt (package, item) =
66
  fprintf fmt "%t.%t" package item
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

    
99
(* Type pretty print functions *)
100

    
101
(** Print a type declaration
102
   @param fmt the formater to print on
103
   @param pp_name a format printer which print the type name
104
   @param pp_value a format printer which print the type definition
105
**)
106
let pp_type_decl fmt (pp_name, pp_definition) =
107
  fprintf fmt "type %t is %t" pp_name pp_definition
108

    
109
(** Print a private type declaration
110
   @param fmt the formater to print on
111
   @param pp_name a format printer which print the type name
112
**)
113
let pp_private_type_decl fmt pp_name =
114
  let pp_definition fmt = fprintf fmt "private" in
115
  pp_type_decl fmt (pp_name, pp_definition)
116

    
117
(** Print the type of the state variable.
118
   @param fmt the formater to print on
119
**)
120
let pp_state_type fmt =
121
  (* Type and variable names live in the same environement in Ada so name of
122
     this type and of the associated parameter : pp_state_name must be
123
     different *)
124
  fprintf fmt "TState"
125

    
126
(** Print the integer type name.
127
   @param fmt the formater to print on
128
**)
129
let pp_integer_type fmt = fprintf fmt "Integer"
130

    
131
(** Print the float type name.
132
   @param fmt the formater to print on
133
**)
134
let pp_float_type fmt = fprintf fmt "Float"
135

    
136
(** Print the boolean type name.
137
   @param fmt the formater to print on
138
**)
139
let pp_boolean_type fmt = fprintf fmt "Boolean"
140

    
141
(** Print the type of a variable.
142
   @param fmt the formater to print on
143
   @param id the variable
144
**)
145
let pp_var_type fmt id = 
146
  (match (Types.repr id.var_type).Types.tdesc with
147
    | Types.Tbasic Types.Basic.Tint -> pp_integer_type fmt
148
    | Types.Tbasic Types.Basic.Treal -> pp_float_type fmt
149
    | Types.Tbasic Types.Basic.Tbool -> pp_boolean_type fmt
150
    | _ -> eprintf "Type error : %a@." Types.print_ty id.var_type; assert false (*TODO*)
151
  )
152
  
153

    
154
(* Variable pretty print functions *)
155

    
156
(** Represent the possible mode for a type of a procedure parameter **)
157
type parameter_mode = NoMode | In | Out | InOut
158

    
159
(** Print a parameter_mode.
160
   @param fmt the formater to print on
161
   @param mode the modifier
162
**)
163
let pp_parameter_mode fmt mode =
164
  fprintf fmt "%s" (match mode with
165
                     | NoMode -> ""
166
                     | In     -> "in"
167
                     | Out    -> "out"
168
                     | InOut  -> "in out")
169

    
170
(** Print the name of the state variable.
171
   @param fmt the formater to print on
172
**)
173
let pp_state_name fmt =
174
  fprintf fmt "state"
175

    
176

    
177
(** Print the name of a variable.
178
   @param fmt the formater to print on
179
   @param id the variable
180
**)
181
let pp_var_name fmt id =
182
  fprintf fmt "%a" pp_clean_ada_identifier id.var_id
183

    
184
(** Print a variable declaration
185
   @param mode input/output mode of the parameter
186
   @param pp_name a format printer wich print the variable name
187
   @param pp_type a format printer wich print the variable type
188
   @param fmt the formater to print on
189
   @param id the variable
190
**)
191
let pp_var_decl fmt (mode, pp_name, pp_type) =
192
  fprintf fmt "%t: %a%s%t"
193
    pp_name
194
    pp_parameter_mode mode
195
    (if mode = NoMode then "" else " ")
196
    pp_type
197

    
198
(** Print variable declaration for machine variable
199
   @param mode input/output mode of the parameter
200
   @param fmt the formater to print on
201
   @param id the variable
202
**)
203
let pp_machine_var_decl mode fmt id =
204
  let pp_name = function fmt -> pp_var_name fmt id in
205
  let pp_type = function fmt -> pp_var_type fmt id in
206
  pp_var_decl fmt (mode, pp_name, pp_type)
207

    
208
(** Print variable declaration for state variable
209
   @param fmt the formater to print on
210
   @param mode input/output mode of the parameter
211
**)
212
let pp_state_var_decl fmt mode =
213
  let pp_name = pp_state_name in
214
  let pp_type = pp_state_type in
215
  pp_var_decl fmt (mode, pp_name, pp_type)
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)
227

    
228
(* Prototype pretty print functions *)
229

    
230
(** Print the name of the init procedure **)
231
let pp_init_procedure_name fmt = fprintf fmt "init"
232

    
233
(** Print the step of the init procedure **)
234
let pp_step_procedure_name fmt = fprintf fmt "step"
235

    
236
(** Print the reset of the init procedure **)
237
let pp_reset_procedure_name fmt = fprintf fmt "reset"
238

    
239
(** Print the clear of the init procedure **)
240
let pp_clear_procedure_name fmt = fprintf fmt "clear"
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

    
249
(** Print the prototype of a machine procedure. The first parameter is always
250
the state, state_modifier specify the modifier applying to it. The next
251
parameters are inputs and the last parameters are the outputs.
252
   @param state_mode the input/output mode for the state parameter
253
   @param input list of the input parameter of the procedure
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
257
**)
258
let pp_base_prototype state_mode input output fmt pp_name =
259
  fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]"
260
    pp_name
261
    pp_state_var_decl state_mode
262
    (Utils.pp_final_char_if_non_empty ";@," input)
263
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl In)) input
264
    (Utils.pp_final_char_if_non_empty ";@," output)
265
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output
266

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

    
275
(** Print the prototype of the step procedure of a machine.
276
   @param m the machine
277
   @param fmt the formater to print on
278
   @param pp_name name function printer
279
**)
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
282

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

    
291
(** Print the prototype of the clear procedure of a machine.
292
   @param m the machine
293
   @param fmt the formater to print on
294
   @param pp_name name function printer
295
**)
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