Project

General

Profile

Download (6.75 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
(** All the pretty print functions common to the ada backend **)
9

    
10
(* Package pretty print functions *)
11

    
12
(** Print the name of a package associated to a machine.
13
   @param fmt the formater to print on
14
   @param machine the machine
15
*)
16
let pp_package_name fmt machine =
17
  fprintf fmt "%s" machine.mname.node_id
18

    
19
(** Print the ada package introduction sentence it can be used for body and
20
declaration. Boolean parameter body should be true if it is a body delcaration.
21
   @param fmt the formater to print on
22
   @param fmt the formater to print on
23
   @param machine the machine
24
*)
25
let pp_begin_package body fmt machine =
26
  fprintf fmt "package %s %a is"
27
    (if body then "body" else "")
28
    pp_package_name machine
29

    
30
(** Print the ada package conclusion sentence.
31
   @param fmt the formater to print on
32
   @param machine the machine
33
*)
34
let pp_end_package fmt machine =
35
  fprintf fmt "end %a" pp_package_name machine
36

    
37

    
38
(* Type pretty print functions *)
39

    
40
(** Print a type declaration
41
   @param fmt the formater to print on
42
   @param pp_name a format printer which print the type name
43
   @param pp_value a format printer which print the type definition
44
*)
45
let pp_type_decl fmt (pp_name, pp_definition) =
46
  fprintf fmt "type %t is %t" pp_name pp_definition
47

    
48
(** Print a private type declaration
49
   @param fmt the formater to print on
50
   @param pp_name a format printer which print the type name
51
*)
52
let pp_private_type_decl fmt pp_name =
53
  let pp_definition fmt = fprintf fmt "private" in
54
  pp_type_decl fmt (pp_name, pp_definition)
55

    
56
(** Print the type of the state variable.
57
   @param fmt the formater to print on
58
*)
59
let pp_state_type fmt =
60
  fprintf fmt "TState"
61

    
62
(** Print the type of a variable.
63
   @param fmt the formater to print on
64
   @param id the variable
65
*)
66
let pp_var_type fmt id = fprintf fmt
67
  (match (Types.repr id.var_type).Types.tdesc with
68
    | Types.Tbasic Types.Basic.Tint -> "Integer"
69
    | Types.Tbasic Types.Basic.Treal -> "Float"
70
    | Types.Tbasic Types.Basic.Tbool -> "Boolean"
71
    | _ -> eprintf "Type error : %a@." Types.print_ty id.var_type; assert false (*TODO*)
72
  )
73
  
74

    
75
(* Variable pretty print functions *)
76

    
77
(** Represent the possible mode for a type of a procedure parameter **)
78
type parameter_mode = NoMode | In | Out | InOut
79

    
80
(** Print a parameter_mode.
81
   @param fmt the formater to print on
82
   @param mode the modifier
83
*)
84
let pp_parameter_mode fmt mode =
85
  fprintf fmt "%s" (match mode with
86
                     | NoMode -> ""
87
                     | In     -> "in"
88
                     | Out    -> "out"
89
                     | InOut  -> "in out")
90

    
91
(** Print the name of the state variable.
92
   @param fmt the formater to print on
93
*)
94
let pp_state_name fmt =
95
  fprintf fmt "state"
96

    
97
(** Print the name of a variable.
98
   @param fmt the formater to print on
99
   @param id the variable
100
*)
101
let pp_var_name fmt id =
102
  let base_size = String.length id.var_id in
103
  assert(base_size > 0);
104
  let rec remove_double_underscore s = function
105
    | i when i == String.length s - 1 -> s
106
    | i when String.get s i == '_' && String.get s (i+1) == '_' ->
107
        remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i
108
    | i -> remove_double_underscore s (i+1)
109
  in
110
  let name = remove_double_underscore id.var_id 0 in
111
  let prefix = if String.length name == base_size
112
                  || String.get id.var_id 0 == '_' then
113
                  "ada"
114
               else
115
                  ""
116
  in
117
  fprintf fmt "%s%s" prefix name
118

    
119
(** Print a variable declaration
120
   @param mode input/output mode of the parameter
121
   @param pp_name a format printer wich print the variable name
122
   @param pp_type a format printer wich print the variable type
123
   @param fmt the formater to print on
124
   @param id the variable
125
*)
126
let pp_var_decl fmt (mode, pp_name, pp_type) =
127
  fprintf fmt "%t: %a %t"
128
    pp_name
129
    pp_parameter_mode mode
130
    pp_type
131

    
132
(** Print variable declaration for machine variable
133
   @param mode input/output mode of the parameter
134
   @param fmt the formater to print on
135
   @param id the variable
136
*)
137
let pp_machine_var_decl mode fmt id =
138
  let pp_name = function fmt -> pp_var_name fmt id in
139
  let pp_type = function fmt -> pp_var_type fmt id in
140
  pp_var_decl fmt (mode, pp_name, pp_type)
141

    
142
(** Print variable declaration for state variable
143
   @param fmt the formater to print on
144
   @param mode input/output mode of the parameter
145
*)
146
let pp_state_var_decl fmt mode =
147
  let pp_name = pp_state_name in
148
  let pp_type = pp_state_type in
149
  pp_var_decl fmt (mode, pp_name, pp_type)
150

    
151

    
152
(* Prototype pretty print functions *)
153

    
154
(** Print the name of the init procedure **)
155
let pp_init_procedure_name fmt = fprintf fmt "init"
156

    
157
(** Print the step of the init procedure **)
158
let pp_step_procedure_name fmt = fprintf fmt "step"
159

    
160
(** Print the reset of the init procedure **)
161
let pp_reset_procedure_name fmt = fprintf fmt "reset"
162

    
163
(** Print the clear of the init procedure **)
164
let pp_clear_procedure_name fmt = fprintf fmt "clear"
165

    
166
(** Print the prototype of a machine procedure. The first parameter is always
167
the state, state_modifier specify the modifier applying to it. The next
168
parameters are inputs and the last parameters are the outputs.
169
   @param fmt the formater to print on
170
   @param name the name of the procedure
171
   @param state_mode the input/output mode for the state parameter
172
   @param input list of the input parameter of the procedure
173
   @param output list of the output parameter of the procedure
174
*)
175
let pp_simple_prototype fmt (pp_name, state_mode, input, output) =
176
  fprintf fmt "procedure %t(@[<v>%a%t@[%a@]%t@[%a@])@]"
177
    pp_name
178
    pp_state_var_decl state_mode
179
    (Utils.pp_final_char_if_non_empty ";@," input)
180
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl In)) input
181
    (Utils.pp_final_char_if_non_empty ";@," output)
182
    (Utils.fprintf_list ~sep:";@ " (pp_machine_var_decl Out)) output
183

    
184
(** Print the prototype of the init procedure of a machine.
185
   @param fmt the formater to print on
186
   @param m the machine
187
*)
188
let pp_init_prototype fmt m =
189
  pp_simple_prototype fmt (pp_init_procedure_name, Out, m.mstatic, [])
190

    
191
(** Print the prototype of the step procedure of a machine.
192
   @param fmt the formater to print on
193
   @param m the machine
194
*)
195
let pp_step_prototype fmt m =
196
  pp_simple_prototype fmt (pp_step_procedure_name, InOut, m.mstep.step_inputs, m.mstep.step_outputs)
197

    
198
(** Print the prototype of the reset procedure of a machine.
199
   @param fmt the formater to print on
200
   @param m the machine
201
*)
202
let pp_reset_prototype fmt m =
203
  pp_simple_prototype fmt (pp_reset_procedure_name, InOut, m.mstatic, [])
204

    
205
(** Print the prototype of the clear procedure of a machine.
206
   @param fmt the formater to print on
207
   @param m the machine
208
*)
209
let pp_clear_prototype fmt m =
210
  pp_simple_prototype fmt (pp_clear_procedure_name, InOut, m.mstatic, [])
(5-5/6)