Revision ca7ff3f7
Added by Lélio Brun over 1 year ago
src/backends/EMF/EMF_common.ml | ||
---|---|---|
4 | 4 |
open Format |
5 | 5 |
open Machine_code_common |
6 | 6 |
|
7 |
(* Matlab starting counting from 1. |
|
8 |
simple function to extract the element id in the list. Starts from 1. *)
|
|
7 |
(* Matlab starting counting from 1. simple function to extract the element id in
|
|
8 |
the list. Starts from 1. *) |
|
9 | 9 |
let rec get_idx x l = |
10 | 10 |
match l with |
11 |
| hd::tl -> if hd = x then 1 else 1+(get_idx x tl) |
|
12 |
| [] -> assert false |
|
11 |
| hd :: tl -> |
|
12 |
if hd = x then 1 else 1 + get_idx x tl |
|
13 |
| [] -> |
|
14 |
assert false |
|
13 | 15 |
|
14 | 16 |
let rec get_expr_vars v = |
15 | 17 |
match v.value_desc with |
16 |
| Cst _ -> VSet.empty |
|
17 |
| Var v -> VSet.singleton v |
|
18 |
| Fun (_, args) -> List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args |
|
19 |
| _ -> assert false (* Invalid argument *) |
|
18 |
| Cst _ -> |
|
19 |
VSet.empty |
|
20 |
| Var v -> |
|
21 |
VSet.singleton v |
|
22 |
| Fun (_, args) -> |
|
23 |
List.fold_left |
|
24 |
(fun accu v -> VSet.union accu (get_expr_vars v)) |
|
25 |
VSet.empty args |
|
26 |
| _ -> |
|
27 |
assert false |
|
28 |
(* Invalid argument *) |
|
20 | 29 |
|
21 | 30 |
let is_imported_node f m = |
22 |
let (decl, _) = List.assoc f m.mcalls in
|
|
31 |
let decl, _ = List.assoc f m.mcalls in
|
|
23 | 32 |
Corelang.is_imported_node decl |
24 | 33 |
|
25 | 34 |
(* Handling of enumerated types: for the moment each of such type is transformed |
26 | 35 |
into an int: the idx number of the constant in the typedef. This is not so |
27 | 36 |
nice but is compatible with basic Simulink types: int, real, bools) *) |
28 |
(* |
|
29 |
let recorded_enums = ref [] |
|
30 |
let record_types prog = |
|
31 |
let typedefs = Corelang.get_typedefs prog in |
|
32 |
List.iter (fun top -> |
|
33 |
let consts = consts_of_enum_type top in |
|
34 |
) prog |
|
35 |
*) |
|
36 |
|
|
37 |
(* let recorded_enums = ref [] let record_types prog = let typedefs = |
|
38 |
Corelang.get_typedefs prog in List.iter (fun top -> let consts = |
|
39 |
consts_of_enum_type top in ) prog *) |
|
40 |
|
|
37 | 41 |
(* Basic printing functions *) |
38 | 42 |
|
39 | 43 |
let hash_map = Hashtbl.create 13 |
40 |
|
|
44 |
|
|
41 | 45 |
(* If string length of f is longer than 50 chars, we select the 10 first and |
42 | 46 |
last and put a hash in the middle *) |
43 | 47 |
let print_protect fmt f = |
44 | 48 |
fprintf str_formatter "%t" f; |
45 | 49 |
let s = flush_str_formatter () in |
46 | 50 |
let l = String.length s in |
47 |
if l > 30 then |
|
48 |
(* let _ = Format.eprintf "Looking for variable %s in hash @[<v 0>%t@]@." *) |
|
49 |
(* s *) |
|
50 |
(* (fun fmt -> Hashtbl.iter (fun s new_s -> fprintf fmt "%s -> %s@ " s new_s) hash_map) *) |
|
51 |
(* in *) |
|
52 |
if Hashtbl.mem hash_map s then |
|
53 |
fprintf fmt "%s" (Hashtbl.find hash_map s) |
|
51 |
if l > 30 then ( |
|
52 |
if |
|
53 |
(* let _ = Format.eprintf "Looking for variable %s in hash @[<v 0>%t@]@." *) |
|
54 |
(* s *) |
|
55 |
(* (fun fmt -> Hashtbl.iter (fun s new_s -> fprintf fmt "%s -> %s@ " s |
|
56 |
new_s) hash_map) *) |
|
57 |
(* in *) |
|
58 |
Hashtbl.mem hash_map s |
|
59 |
then fprintf fmt "%s" (Hashtbl.find hash_map s) |
|
54 | 60 |
else |
55 |
let prefix = String.sub s 0 10 and |
|
56 |
suffix = String.sub s (l-10) 10 in |
|
61 |
let prefix = String.sub s 0 10 and suffix = String.sub s (l - 10) 10 in |
|
57 | 62 |
let hash = Hashtbl.hash s in |
58 | 63 |
fprintf str_formatter "%s_%i_%s" prefix hash suffix; |
59 | 64 |
let new_s = flush_str_formatter () in |
60 | 65 |
Hashtbl.add hash_map s new_s; |
61 |
fprintf fmt "%s" new_s |
|
62 |
else |
|
63 |
fprintf fmt "%s" s |
|
64 |
|
|
65 |
let pp_var_string fmt v =fprintf fmt "\"%t\"" (fun fmt -> print_protect fmt (fun fmt -> fprintf fmt "%s" v)) |
|
66 |
let pp_var_name fmt v = print_protect fmt (fun fmt -> Printers.pp_var_name fmt v) |
|
66 |
fprintf fmt "%s" new_s) |
|
67 |
else fprintf fmt "%s" s |
|
68 |
|
|
69 |
let pp_var_string fmt v = |
|
70 |
fprintf fmt "\"%t\"" (fun fmt -> |
|
71 |
print_protect fmt (fun fmt -> fprintf fmt "%s" v)) |
|
72 |
|
|
73 |
let pp_var_name fmt v = |
|
74 |
print_protect fmt (fun fmt -> Printers.pp_var_name fmt v) |
|
67 | 75 |
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*) |
68 | 76 |
|
69 | 77 |
(********* Printing types ***********) |
70 |
(* Two cases: |
|
71 |
- printing a variable definition: |
|
72 |
- we look at the declared type if available |
|
73 |
- if not, we print the inferred type |
|
78 |
(* Two cases: - printing a variable definition: - we look at the declared type |
|
79 |
if available - if not, we print the inferred type |
|
74 | 80 |
|
75 |
- printing a constant definion |
|
76 |
*) |
|
77 |
|
|
78 |
|
|
81 |
- printing a constant definion *) |
|
79 | 82 |
|
80 | 83 |
let rec pp_emf_dim fmt dim_expr = |
81 | 84 |
fprintf fmt "{"; |
82 | 85 |
(let open Dimension in |
83 |
match dim_expr.dim_desc with |
|
84 |
| Dbool b -> fprintf fmt "\"kind\": \"bool\",@ \"value\": \"%b\"" b |
|
85 |
| Dint i -> fprintf fmt "\"kind\": \"int\",@ \"value\": \"%i\"" i |
|
86 |
| Dident s -> fprintf fmt "\"kind\": \"ident\",@ \"value\": \"%s\"" s |
|
87 |
| Dappl(f, args) -> fprintf fmt "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]" |
|
88 |
f (Utils.fprintf_list ~sep:",@ " pp_emf_dim) args |
|
89 |
| Dite(i,t,e) -> fprintf fmt "\"kind\": \"ite\",@ \"guard\": \"%a\",@ \"then\": %a,@ \"else\": %a" |
|
90 |
pp_emf_dim i pp_emf_dim t pp_emf_dim e |
|
91 |
| Dlink e -> pp_emf_dim fmt e |
|
92 |
| Dvar |
|
93 |
| Dunivar -> assert false (* unresolved *) |
|
94 |
); |
|
86 |
match dim_expr.dim_desc with |
|
87 |
| Dbool b -> |
|
88 |
fprintf fmt "\"kind\": \"bool\",@ \"value\": \"%b\"" b |
|
89 |
| Dint i -> |
|
90 |
fprintf fmt "\"kind\": \"int\",@ \"value\": \"%i\"" i |
|
91 |
| Dident s -> |
|
92 |
fprintf fmt "\"kind\": \"ident\",@ \"value\": \"%s\"" s |
|
93 |
| Dappl (f, args) -> |
|
94 |
fprintf fmt "\"kind\": \"fun\",@ \"id\": \"%s\",@ \"args\": [@[%a@]]" f |
|
95 |
(Utils.fprintf_list ~sep:",@ " pp_emf_dim) |
|
96 |
args |
|
97 |
| Dite (i, t, e) -> |
|
98 |
fprintf fmt |
|
99 |
"\"kind\": \"ite\",@ \"guard\": \"%a\",@ \"then\": %a,@ \"else\": %a" |
|
100 |
pp_emf_dim i pp_emf_dim t pp_emf_dim e |
|
101 |
| Dlink e -> |
|
102 |
pp_emf_dim fmt e |
|
103 |
| Dvar | Dunivar -> |
|
104 |
assert false |
|
105 |
(* unresolved *)); |
|
95 | 106 |
fprintf fmt "}" |
96 | 107 |
|
97 |
|
|
98 |
|
|
99 |
|
|
100 | 108 |
(* First try to print the declared one *) |
101 | 109 |
let rec pp_concrete_type dec_t infered_t fmt = |
102 | 110 |
match dec_t with |
103 |
| Tydec_any -> (* Dynamical built variable. No declared type. Shall |
|
104 |
use the infered one. *) |
|
105 |
pp_infered_type fmt infered_t |
|
106 |
| Tydec_int -> fprintf fmt "{ \"kind\": \"int\" }" (* !Options.int_type *) |
|
107 |
| Tydec_real -> fprintf fmt "{ \"kind\": \"real\" }" (* !Options.real_type *) |
|
108 |
(* TODO we could add more concrete types here if they were available in |
|
109 |
dec_t *) |
|
110 |
| Tydec_bool -> fprintf fmt "{ \"kind\": \"bool\" }" |
|
111 |
| Tydec_clock t -> pp_concrete_type t infered_t fmt |
|
112 |
| Tydec_const id -> ( |
|
111 |
| Tydec_any -> |
|
112 |
(* Dynamical built variable. No declared type. Shall use the infered one. *) |
|
113 |
pp_infered_type fmt infered_t |
|
114 |
| Tydec_int -> |
|
115 |
fprintf fmt "{ \"kind\": \"int\" }" (* !Options.int_type *) |
|
116 |
| Tydec_real -> |
|
117 |
fprintf fmt "{ \"kind\": \"real\" }" |
|
118 |
(* !Options.real_type *) |
|
119 |
(* TODO we could add more concrete types here if they were available in dec_t *) |
|
120 |
| Tydec_bool -> |
|
121 |
fprintf fmt "{ \"kind\": \"bool\" }" |
|
122 |
| Tydec_clock t -> |
|
123 |
pp_concrete_type t infered_t fmt |
|
124 |
| Tydec_const id -> |
|
113 | 125 |
(* This is an alias type *) |
114 | 126 |
|
115 | 127 |
(* id for a enumerated type, eg. introduced by automata *) |
116 |
let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t)) in |
|
117 |
(* Print the type name associated to this enumerated type. This is |
|
118 |
basically an integer *) |
|
128 |
let typ = |
|
129 |
Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t) |
|
130 |
in |
|
131 |
(* Print the type name associated to this enumerated type. This is basically |
|
132 |
an integer *) |
|
119 | 133 |
pp_tag_type id typ infered_t fmt |
120 |
) |
|
121 |
|
|
122 | 134 |
| Tydec_struct _ | Tydec_enum _ -> |
123 |
assert false (* should not happen. These type are only built when |
|
124 |
declaring a type in the prefix of the lustre |
|
125 |
file. They shall not be associated to variables |
|
126 |
*) |
|
127 |
|
|
128 |
| Tydec_array (dim, e) -> ( |
|
129 |
let inf_base = match infered_t.Typing.tdesc with |
|
130 |
| Typing.Tarray(_,t) -> t |
|
131 |
| _ -> (* returing something useless, hoping that the concrete |
|
132 |
datatype will return something usefull *) |
|
133 |
Typing.new_var () |
|
135 |
assert false |
|
136 |
(* should not happen. These type are only built when declaring a type in the |
|
137 |
prefix of the lustre file. They shall not be associated to variables *) |
|
138 |
| Tydec_array (dim, e) -> |
|
139 |
let inf_base = |
|
140 |
match infered_t.Typing.tdesc with |
|
141 |
| Typing.Tarray (_, t) -> |
|
142 |
t |
|
143 |
| _ -> |
|
144 |
(* returing something useless, hoping that the concrete datatype will |
|
145 |
return something usefull *) |
|
146 |
Typing.new_var () |
|
134 | 147 |
in |
135 | 148 |
fprintf fmt "{ \"kind\": \"array\", \"base_type\": %t, \"dim\": %a }" |
136 | 149 |
(pp_concrete_type e inf_base) |
137 | 150 |
pp_emf_dim dim |
138 |
) |
|
139 |
|
|
151 |
|
|
140 | 152 |
(* | _ -> eprintf |
141 | 153 |
* "unhandled construct in type printing for EMF backend: %a@." |
142 | 154 |
* Printers.pp_var_type_dec_desc dec_t; raise (Failure "var") *) |
143 | 155 |
and pp_tag_type id typ inf fmt = |
144 |
(* We ought to represent these types as values: enum will become int, we keep the name for structs *) |
|
156 |
(* We ought to represent these types as values: enum will become int, we keep |
|
157 |
the name for structs *) |
|
145 | 158 |
let rec aux tydec_desc = |
146 |
match tydec_desc with |
|
147 |
| Tydec_int |
|
148 |
| Tydec_real |
|
149 |
| Tydec_bool |
|
150 |
| Tydec_array _ -> pp_concrete_type tydec_desc inf fmt |
|
159 |
match tydec_desc with |
|
160 |
| Tydec_int | Tydec_real | Tydec_bool | Tydec_array _ -> |
|
161 |
pp_concrete_type tydec_desc inf fmt |
|
151 | 162 |
| Tydec_const id -> |
152 |
(* Alias of an alias: unrolling definitions *) |
|
153 |
let typ = (Corelang.typedef_of_top |
|
154 |
(Hashtbl.find Corelang.type_table tydec_desc)) |
|
155 |
in |
|
156 |
pp_tag_type id typ inf fmt |
|
157 |
|
|
158 |
| Tydec_clock ty -> aux ty |
|
159 |
| Tydec_enum const_list -> ( (* enum can be mapped to int *) |
|
163 |
(* Alias of an alias: unrolling definitions *) |
|
164 |
let typ = |
|
165 |
Corelang.typedef_of_top (Hashtbl.find Corelang.type_table tydec_desc) |
|
166 |
in |
|
167 |
pp_tag_type id typ inf fmt |
|
168 |
| Tydec_clock ty -> |
|
169 |
aux ty |
|
170 |
| Tydec_enum const_list -> |
|
171 |
(* enum can be mapped to int *) |
|
160 | 172 |
let size = List.length const_list in |
161 |
fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }" id size
|
|
162 |
)
|
|
173 |
fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }" |
|
174 |
id size
|
|
163 | 175 |
| Tydec_struct _ -> |
164 |
fprintf fmt "{ \"name\": \"%s\", \"kind\": \"struct\" }" id
|
|
165 |
| Tydec_any -> (* shall not happen: a declared type cannot be
|
|
166 |
bound to type any *)
|
|
167 |
assert false
|
|
176 |
fprintf fmt "{ \"name\": \"%s\", \"kind\": \"struct\" }" id |
|
177 |
| Tydec_any -> |
|
178 |
(* shall not happen: a declared type cannot be bound to type any *)
|
|
179 |
assert false |
|
168 | 180 |
in |
169 | 181 |
aux typ.tydef_desc |
182 |
|
|
170 | 183 |
and pp_infered_type fmt t = |
171 |
(* Shall only be used for variable types that were not properly declared. Ie generated at compile time. *) |
|
184 |
(* Shall only be used for variable types that were not properly declared. Ie |
|
185 |
generated at compile time. *) |
|
172 | 186 |
let open Types in |
173 |
if is_bool_type t then fprintf fmt "{ \"kind\": \"bool\" }" else |
|
174 |
if is_int_type t then fprintf fmt "{ \"kind\": \"int\" }" else (* !Options.int_type *) |
|
175 |
if is_real_type t then fprintf fmt "{ \"kind\": \"real\" }" else (* !Options.real_type *) |
|
176 |
match t.tdesc with |
|
177 |
| Tclock t -> |
|
178 |
pp_infered_type fmt t |
|
179 |
| Tstatic (_, t) -> |
|
180 |
fprintf fmt "%a" pp_infered_type t |
|
181 |
| Tconst id -> |
|
182 |
(* This is a type id for a enumerated type, eg. introduced by automata *) |
|
183 |
let typ = |
|
184 |
(Corelang.typedef_of_top |
|
185 |
(Hashtbl.find Corelang.type_table (Tydec_const id))) |
|
186 |
in |
|
187 |
pp_tag_type id typ t fmt |
|
188 |
| Tlink ty -> |
|
189 |
pp_infered_type fmt ty |
|
190 |
| Tarray (dim, base_t) -> |
|
191 |
fprintf fmt "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }" |
|
192 |
pp_infered_type base_t |
|
193 |
pp_emf_dim dim |
|
194 |
| _ -> eprintf "unhandled type: %a@." Types.print_node_ty t; assert false |
|
195 |
|
|
196 |
(*let pp_cst_type fmt v = |
|
197 |
match v.value_desc with |
|
198 |
| Cst c-> pp_cst_type c v.value_type fmt (* constants do not have declared type (yet) *) |
|
199 |
| _ -> assert false |
|
200 |
*) |
|
187 |
if is_bool_type t then fprintf fmt "{ \"kind\": \"bool\" }" |
|
188 |
else if is_int_type t then fprintf fmt "{ \"kind\": \"int\" }" |
|
189 |
else if (* !Options.int_type *) |
|
190 |
is_real_type t then fprintf fmt "{ \"kind\": \"real\" }" |
|
191 |
else |
|
192 |
(* !Options.real_type *) |
|
193 |
match t.tdesc with |
|
194 |
| Tclock t -> |
|
195 |
pp_infered_type fmt t |
|
196 |
| Tstatic (_, t) -> |
|
197 |
fprintf fmt "%a" pp_infered_type t |
|
198 |
| Tconst id -> |
|
199 |
(* This is a type id for a enumerated type, eg. introduced by automata *) |
|
200 |
let typ = |
|
201 |
Corelang.typedef_of_top |
|
202 |
(Hashtbl.find Corelang.type_table (Tydec_const id)) |
|
203 |
in |
|
204 |
pp_tag_type id typ t fmt |
|
205 |
| Tlink ty -> |
|
206 |
pp_infered_type fmt ty |
|
207 |
| Tarray (dim, base_t) -> |
|
208 |
fprintf fmt "{ \"kind\": \"array\", \"base_type\": %a, \"dim\": %a }" |
|
209 |
pp_infered_type base_t pp_emf_dim dim |
|
210 |
| _ -> |
|
211 |
eprintf "unhandled type: %a@." Types.print_node_ty t; |
|
212 |
assert false |
|
213 |
|
|
214 |
(*let pp_cst_type fmt v = match v.value_desc with | Cst c-> pp_cst_type c |
|
215 |
v.value_type fmt (* constants do not have declared type (yet) *) | _ -> assert |
|
216 |
false *) |
|
201 | 217 |
|
202 | 218 |
(* Provide both the declared type and the infered one. *) |
203 | 219 |
let pp_var_type fmt v = |
204 | 220 |
try |
205 |
if Machine_types.is_specified v then |
|
206 |
Machine_types.pp_var_type fmt v
|
|
207 |
else
|
|
208 |
pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
|
|
209 |
with Failure msg -> eprintf "failed var: %a@.%s@." Printers.pp_var v msg; assert false
|
|
210 |
|
|
221 |
if Machine_types.is_specified v then Machine_types.pp_var_type fmt v
|
|
222 |
else pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
|
|
223 |
with Failure msg ->
|
|
224 |
eprintf "failed var: %a@.%s@." Printers.pp_var v msg;
|
|
225 |
assert false
|
|
226 |
|
|
211 | 227 |
(******** Other print functions *) |
212 | 228 |
|
213 |
let pp_emf_list ?(eol:('a, formatter, unit) Stdlib.format="") pp fmt l =
|
|
229 |
let pp_emf_list ?(eol : ('a, formatter, unit) Stdlib.format = "") pp fmt l =
|
|
214 | 230 |
match l with |
215 |
[] -> () |
|
216 |
| _ -> fprintf fmt "@["; |
|
217 |
Utils.fprintf_list ~sep:",@ " pp fmt l; |
|
218 |
fprintf fmt "@]%(%)" eol |
|
219 |
|
|
231 |
| [] -> |
|
232 |
() |
|
233 |
| _ -> |
|
234 |
fprintf fmt "@["; |
|
235 |
Utils.fprintf_list ~sep:",@ " pp fmt l; |
|
236 |
fprintf fmt "@]%(%)" eol |
|
237 |
|
|
220 | 238 |
(* Print the variable declaration *) |
221 | 239 |
let pp_emf_var_decl fmt v = |
222 |
fprintf fmt "@[{\"name\": \"%a\", \"datatype\": %a, \"original_name\": \"%a\"}@]" |
|
223 |
pp_var_name v |
|
224 |
pp_var_type v |
|
225 |
Printers.pp_var_name v |
|
240 |
fprintf fmt |
|
241 |
"@[{\"name\": \"%a\", \"datatype\": %a, \"original_name\": \"%a\"}@]" |
|
242 |
pp_var_name v pp_var_type v Printers.pp_var_name v |
|
226 | 243 |
|
227 | 244 |
let pp_emf_vars_decl = pp_emf_list pp_emf_var_decl |
228 | 245 |
|
229 |
|
|
230 |
|
|
231 |
let reset_name id = |
|
232 |
"reset_" ^ id |
|
233 |
|
|
246 |
let reset_name id = "reset_" ^ id |
|
247 |
|
|
234 | 248 |
let pp_tag_id fmt t = |
235 |
let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in |
|
236 |
if typ.tydef_id = "bool" then |
|
237 |
pp_print_string fmt t |
|
249 |
let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in |
|
250 |
if typ.tydef_id = "bool" then pp_print_string fmt t |
|
238 | 251 |
else |
239 |
let const_list = match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false in |
|
252 |
let const_list = |
|
253 |
match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false |
|
254 |
in |
|
240 | 255 |
fprintf fmt "%i" (get_idx t const_list) |
241 | 256 |
|
242 | 257 |
let pp_cst_type c inf fmt (*infered_typ*) = |
243 | 258 |
let pp_basic fmt s = fprintf fmt "{ \"kind\": \"%s\" }" s in |
244 | 259 |
match c with |
245 | 260 |
| Const_tag t -> |
246 |
let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in |
|
247 |
if typ.tydef_id = "bool" then |
|
248 |
pp_basic fmt "bool" |
|
249 |
else |
|
250 |
pp_tag_type t typ inf fmt |
|
251 |
| Const_int _ -> pp_basic fmt "int" (*!Options.int_type*) |
|
252 |
| Const_real _ -> pp_basic fmt "real" (*!Options.real_type*) |
|
253 |
| Const_string _ -> pp_basic fmt "string" |
|
254 |
| _ -> eprintf "cst: %a@." Printers.pp_const c; assert false |
|
255 |
|
|
256 |
|
|
261 |
let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in |
|
262 |
if typ.tydef_id = "bool" then pp_basic fmt "bool" |
|
263 |
else pp_tag_type t typ inf fmt |
|
264 |
| Const_int _ -> |
|
265 |
pp_basic fmt "int" (*!Options.int_type*) |
|
266 |
| Const_real _ -> |
|
267 |
pp_basic fmt "real" (*!Options.real_type*) |
|
268 |
| Const_string _ -> |
|
269 |
pp_basic fmt "string" |
|
270 |
| _ -> |
|
271 |
eprintf "cst: %a@." Printers.pp_const c; |
|
272 |
assert false |
|
273 |
|
|
257 | 274 |
let pp_emf_cst c inf fmt = |
258 |
let pp_typ fmt = |
|
259 |
fprintf fmt "\"datatype\": %t@ " |
|
260 |
(pp_cst_type c inf) |
|
261 |
in |
|
275 |
let pp_typ fmt = fprintf fmt "\"datatype\": %t@ " (pp_cst_type c inf) in |
|
262 | 276 |
match c with |
263 |
| Const_tag t-> |
|
264 |
let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in |
|
265 |
if typ.tydef_id = "bool" then ( |
|
266 |
fprintf fmt "{@[\"type\": \"constant\",@ "; |
|
267 |
fprintf fmt"\"value\": \"%a\",@ " |
|
268 |
Printers.pp_const c; |
|
269 |
pp_typ fmt; |
|
270 |
fprintf fmt "@]}" |
|
271 |
) |
|
272 |
else ( |
|
273 |
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " |
|
274 |
pp_tag_id t; |
|
275 |
fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ " |
|
276 |
typ.tydef_id t; |
|
277 |
pp_typ fmt; |
|
278 |
fprintf fmt "@]}" |
|
279 |
) |
|
277 |
| Const_tag t -> |
|
278 |
let typ = Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t) in |
|
279 |
if typ.tydef_id = "bool" then ( |
|
280 |
fprintf fmt "{@[\"type\": \"constant\",@ "; |
|
281 |
fprintf fmt "\"value\": \"%a\",@ " Printers.pp_const c; |
|
282 |
pp_typ fmt; |
|
283 |
fprintf fmt "@]}") |
|
284 |
else ( |
|
285 |
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " pp_tag_id t; |
|
286 |
fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ " |
|
287 |
typ.tydef_id t; |
|
288 |
pp_typ fmt; |
|
289 |
fprintf fmt "@]}") |
|
280 | 290 |
| Const_string s -> |
281 |
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s; |
|
282 |
pp_typ fmt; |
|
283 |
fprintf fmt "@]}" |
|
284 |
|
|
285 |
| _ -> ( |
|
291 |
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s; |
|
292 |
pp_typ fmt; |
|
293 |
fprintf fmt "@]}" |
|
294 |
| _ -> |
|
286 | 295 |
fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " |
287 | 296 |
Printers.pp_const c; |
288 | 297 |
pp_typ fmt; |
289 | 298 |
fprintf fmt "@]}" |
290 |
) |
|
291 |
|
|
299 |
|
|
292 | 300 |
(* Print a value: either a constant or a variable value *) |
293 | 301 |
let rec pp_emf_cst_or_var m fmt v = |
294 | 302 |
match v.value_desc with |
295 |
| Cst c -> pp_emf_cst c v.value_type fmt
|
|
296 |
| Var v -> (
|
|
297 |
fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
|
|
298 |
pp_var_name v;
|
|
299 |
(* fprintf fmt "\"original_name\": \"%a\",@ " Printers.pp_var_name v; *)
|
|
303 |
| Cst c -> |
|
304 |
pp_emf_cst c v.value_type fmt
|
|
305 |
| Var v ->
|
|
306 |
fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ " pp_var_name v;
|
|
307 |
(* fprintf fmt "\"original_name\": \"%a\",@ " Printers.pp_var_name v; *) |
|
300 | 308 |
fprintf fmt "\"datatype\": %a@ " pp_var_type v; |
301 | 309 |
fprintf fmt "@]}" |
302 |
) |
|
303 |
| Array vl -> ( |
|
304 |
fprintf fmt "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ " |
|
310 |
| Array vl -> |
|
311 |
fprintf fmt "{@[\"type\": \"array\",@ \"value\": @[[%a@]]@ " |
|
305 | 312 |
(pp_emf_cst_or_var_list m) vl; |
306 |
fprintf fmt "@]}" |
|
307 |
) |
|
308 |
| Access (arr, idx) -> ( |
|
309 |
fprintf fmt "{@[\"type\": \"array access\",@ \"array\": @[[%a@]],@ \"idx\": @[[%a@]]@ " |
|
313 |
fprintf fmt "@]}" |
|
314 |
| Access (arr, idx) -> |
|
315 |
fprintf fmt |
|
316 |
"{@[\"type\": \"array access\",@ \"array\": @[[%a@]],@ \"idx\": \ |
|
317 |
@[[%a@]]@ " |
|
310 | 318 |
(pp_emf_cst_or_var m) arr (pp_emf_cst_or_var m) idx; |
311 |
fprintf fmt "@]}"
|
|
312 |
)
|
|
313 |
| Power (v,nb) ->(
|
|
314 |
fprintf fmt "{@[\"type\": \"power\",@ \"expr\": @[[%a@]],@ \"nb\": @[[%a@]]@ "
|
|
319 |
fprintf fmt "@]}" |
|
320 |
| Power (v, nb) ->
|
|
321 |
fprintf fmt
|
|
322 |
"{@[\"type\": \"power\",@ \"expr\": @[[%a@]],@ \"nb\": @[[%a@]]@ " |
|
315 | 323 |
(pp_emf_cst_or_var m) v (pp_emf_cst_or_var m) nb; |
316 |
fprintf fmt "@]}" |
|
317 |
) |
|
318 |
| Fun _ -> eprintf "Fun expression should have been normalized: %a@." (pp_val m) v ; assert false (* Invalid argument *) |
|
324 |
fprintf fmt "@]}" |
|
325 |
| Fun _ -> |
|
326 |
eprintf "Fun expression should have been normalized: %a@." (pp_val m) v; |
|
327 |
assert false (* Invalid argument *) |
|
319 | 328 |
| ResetFlag -> |
320 | 329 |
(* TODO: handle reset flag *) |
321 | 330 |
assert false |
... | ... | |
324 | 333 |
Utils.fprintf_list ~sep:",@ " (pp_emf_cst_or_var m) |
325 | 334 |
|
326 | 335 |
(* Printer lustre expr and eexpr *) |
327 |
|
|
336 |
|
|
328 | 337 |
let rec pp_emf_expr fmt e = |
329 | 338 |
match e.expr_desc with |
330 |
| Expr_const c -> pp_emf_cst c e.expr_type fmt |
|
339 |
| Expr_const c -> |
|
340 |
pp_emf_cst c e.expr_type fmt |
|
331 | 341 |
| Expr_ident id -> |
332 |
fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
|
|
333 |
print_protect (fun fmt -> pp_print_string fmt id);
|
|
342 |
fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ " print_protect
|
|
343 |
(fun fmt -> pp_print_string fmt id); |
|
334 | 344 |
fprintf fmt "\"datatype\": %t@ " |
335 |
(pp_concrete_type |
|
336 |
Tydec_any (* don't know much about that time since it was not |
|
337 |
declared. That may not work with clock constants *) |
|
338 |
e.expr_type |
|
339 |
); |
|
345 |
(pp_concrete_type Tydec_any |
|
346 |
(* don't know much about that time since it was not declared. That may |
|
347 |
not work with clock constants *) |
|
348 |
e.expr_type); |
|
340 | 349 |
fprintf fmt "@]}" |
341 |
|
|
342 | 350 |
| Expr_tuple el -> |
343 |
fprintf fmt "[@[<hov 0>%a@ @]]" |
|
344 |
(Utils.fprintf_list ~sep:",@ " pp_emf_expr) el |
|
345 |
(* Missing these |
|
346 |
| Expr_ite of expr * expr * expr |
|
347 |
| Expr_arrow of expr * expr |
|
348 |
| Expr_fby of expr * expr |
|
349 |
| Expr_array of expr list |
|
350 |
| Expr_access of expr * Dimension.dim_expr |
|
351 |
| Expr_power of expr * Dimension.dim_expr |
|
352 |
| Expr_pre of expr |
|
353 |
| Expr_when of expr * ident * label |
|
354 |
| Expr_merge of ident * (label * expr) list |
|
355 |
| Expr_appl of call_t |
|
356 |
*) |
|
357 |
| _ -> ( |
|
358 |
Log.report ~level:2 |
|
359 |
(fun fmt -> |
|
360 |
fprintf fmt "Warning: unhandled expression %a in annotation.@ " |
|
361 |
Printers.pp_expr e; |
|
362 |
fprintf fmt "Will not be produced in the experted JSON EMF@." |
|
363 |
); |
|
351 |
fprintf fmt "[@[<hov 0>%a@ @]]" |
|
352 |
(Utils.fprintf_list ~sep:",@ " pp_emf_expr) |
|
353 |
el |
|
354 |
(* Missing these | Expr_ite of expr * expr * expr | Expr_arrow of expr * expr |
|
355 |
| Expr_fby of expr * expr | Expr_array of expr list | Expr_access of expr * |
|
356 |
Dimension.dim_expr | Expr_power of expr * Dimension.dim_expr | Expr_pre of |
|
357 |
expr | Expr_when of expr * ident * label | Expr_merge of ident * (label * |
|
358 |
expr) list | Expr_appl of call_t *) |
|
359 |
| _ -> |
|
360 |
Log.report ~level:2 (fun fmt -> |
|
361 |
fprintf fmt "Warning: unhandled expression %a in annotation.@ " |
|
362 |
Printers.pp_expr e; |
|
363 |
fprintf fmt "Will not be produced in the experted JSON EMF@."); |
|
364 | 364 |
fprintf fmt "\"unhandled construct, complain to Ploc\"" |
365 |
) |
|
366 |
(* Remaining constructs *)
|
|
365 |
|
|
366 |
(* Remaining constructs *) |
|
367 | 367 |
(* | Expr_ite of expr * expr * expr *) |
368 | 368 |
(* | Expr_arrow of expr * expr *) |
369 | 369 |
(* | Expr_fby of expr * expr *) |
... | ... | |
376 | 376 |
(* | Expr_appl of call_t *) |
377 | 377 |
|
378 | 378 |
let pp_emf_exprs = pp_emf_list pp_emf_expr |
379 |
|
|
379 |
|
|
380 | 380 |
let pp_emf_const fmt v = |
381 |
fprintf fmt "@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \"%a\",@ \"value\": %a}@]"
|
|
382 |
pp_var_name v
|
|
383 |
pp_var_type v
|
|
384 |
Printers.pp_var_name v
|
|
385 |
pp_emf_expr (match v.var_dec_value with None -> assert false | Some e -> e)
|
|
381 |
fprintf fmt |
|
382 |
"@[<hov 0>{\"name\": \"%a\",@ \"datatype\":%a,@ \"original_name\": \
|
|
383 |
\"%a\",@ \"value\": %a}@]"
|
|
384 |
pp_var_name v pp_var_type v Printers.pp_var_name v pp_emf_expr
|
|
385 |
(match v.var_dec_value with None -> assert false | Some e -> e) |
|
386 | 386 |
|
387 | 387 |
let pp_emf_consts = pp_emf_list pp_emf_const |
388 |
|
|
388 |
|
|
389 | 389 |
let pp_emf_eexpr fmt ee = |
390 | 390 |
fprintf fmt "{@[<hov 0>%t\"quantifiers\": \"%a\",@ \"qfexpr\": @[%a@]@] }" |
391 |
(fun fmt -> match ee.eexpr_name with |
|
392 |
| None -> () |
|
393 |
| Some name -> Format.fprintf fmt "\"name\": \"%s\",@ " name |
|
394 |
) |
|
391 |
(fun fmt -> |
|
392 |
match ee.eexpr_name with |
|
393 |
| None -> |
|
394 |
() |
|
395 |
| Some name -> |
|
396 |
Format.fprintf fmt "\"name\": \"%s\",@ " name) |
|
395 | 397 |
(Utils.fprintf_list ~sep:"; " Printers.pp_quantifiers) |
396 |
ee.eexpr_quantifiers |
|
397 |
pp_emf_expr ee.eexpr_qfexpr |
|
398 |
ee.eexpr_quantifiers pp_emf_expr ee.eexpr_qfexpr |
|
398 | 399 |
|
399 | 400 |
let pp_emf_eexprs = pp_emf_list pp_emf_eexpr |
400 | 401 |
|
401 |
(* |
|
402 |
TODO Thanksgiving |
|
402 |
(* TODO Thanksgiving |
|
403 |
|
|
404 |
trouver un moyen de transformer en machine code les instructions de chaque |
|
405 |
spec peut etre associer a chaque imported node une minimachine et rajouter un |
|
406 |
champ a spec dans machine code pour stoquer memoire et instr *) |
|
403 | 407 |
|
404 |
trouver un moyen de transformer en machine code les instructions de chaque spec |
|
405 |
peut etre associer a chaque imported node une minimachine |
|
406 |
et rajouter un champ a spec dans machine code pour stoquer memoire et instr |
|
407 |
*) |
|
408 |
|
|
409 | 408 |
let pp_emf_stmt fmt stmt = |
410 | 409 |
match stmt with |
411 |
| Aut _ -> assert false |
|
412 |
| Eq eq -> ( |
|
413 |
fprintf fmt "@[ @[<v 2>\"%a\": {@ " (Utils.fprintf_list ~sep:"_" pp_print_string) eq.eq_lhs; |
|
414 |
fprintf fmt "\"lhs\": [%a],@ " (Utils.fprintf_list ~sep:", " (fun fmt vid -> fprintf fmt "\"%s\"" vid)) eq.eq_lhs; |
|
410 |
| Aut _ -> |
|
411 |
assert false |
|
412 |
| Eq eq -> |
|
413 |
fprintf fmt "@[ @[<v 2>\"%a\": {@ " |
|
414 |
(Utils.fprintf_list ~sep:"_" pp_print_string) |
|
415 |
eq.eq_lhs; |
|
416 |
fprintf fmt "\"lhs\": [%a],@ " |
|
417 |
(Utils.fprintf_list ~sep:", " (fun fmt vid -> fprintf fmt "\"%s\"" vid)) |
|
418 |
eq.eq_lhs; |
|
415 | 419 |
fprintf fmt "\"rhs\": %a,@ " pp_emf_expr eq.eq_rhs; |
416 | 420 |
fprintf fmt "@]@]@ }" |
417 |
) |
|
418 | 421 |
|
419 |
let pp_emf_stmts = pp_emf_list pp_emf_stmt
|
|
420 |
|
|
422 |
let pp_emf_stmts = pp_emf_list pp_emf_stmt |
|
423 |
|
|
421 | 424 |
(* Printing the type declaration, not its use *) |
422 | 425 |
let rec pp_emf_typ_dec fmt tydef_dec = |
423 | 426 |
fprintf fmt "{"; |
424 | 427 |
(match tydef_dec with |
425 |
| Tydec_any -> fprintf fmt "\"kind\": \"any\"" |
|
426 |
| Tydec_int -> fprintf fmt "\"kind\": \"int\"" |
|
427 |
| Tydec_real -> fprintf fmt "\"kind\": \"real\"" |
|
428 |
| Tydec_bool-> fprintf fmt "\"kind\": \"bool\"" |
|
429 |
| Tydec_clock ck -> pp_emf_typ_dec fmt ck |
|
430 |
| Tydec_const c -> fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c |
|
431 |
| Tydec_enum el -> fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]" |
|
432 |
(Utils.fprintf_list ~sep:", " (fun fmt e -> fprintf fmt "\"%s\"" e)) el |
|
433 |
| Tydec_struct s -> fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]" |
|
434 |
(Utils.fprintf_list ~sep:", " (fun fmt (id,typ) -> |
|
435 |
fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ)) s |
|
436 |
| Tydec_array (dim, typ) -> fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a" |
|
437 |
pp_emf_dim dim |
|
438 |
pp_emf_typ_dec typ |
|
439 |
); |
|
428 |
| Tydec_any -> |
|
429 |
fprintf fmt "\"kind\": \"any\"" |
|
430 |
| Tydec_int -> |
|
431 |
fprintf fmt "\"kind\": \"int\"" |
|
432 |
| Tydec_real -> |
|
433 |
fprintf fmt "\"kind\": \"real\"" |
|
434 |
| Tydec_bool -> |
|
435 |
fprintf fmt "\"kind\": \"bool\"" |
|
436 |
| Tydec_clock ck -> |
|
437 |
pp_emf_typ_dec fmt ck |
|
438 |
| Tydec_const c -> |
|
439 |
fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c |
|
440 |
| Tydec_enum el -> |
|
441 |
fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]" |
|
442 |
(Utils.fprintf_list ~sep:", " (fun fmt e -> fprintf fmt "\"%s\"" e)) |
|
443 |
el |
|
444 |
| Tydec_struct s -> |
|
445 |
fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]" |
|
446 |
(Utils.fprintf_list ~sep:", " (fun fmt (id, typ) -> |
|
447 |
fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ)) |
|
448 |
s |
|
449 |
| Tydec_array (dim, typ) -> |
|
450 |
fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a" |
|
451 |
pp_emf_dim dim pp_emf_typ_dec typ); |
|
440 | 452 |
fprintf fmt "}" |
441 |
|
|
453 |
|
|
442 | 454 |
let pp_emf_typedef fmt typdef_top = |
443 | 455 |
let typedef = Corelang.typedef_of_top typdef_top in |
444 |
fprintf fmt "{ \"%s\": @[%a@] }" typedef.tydef_id pp_emf_typ_dec typedef.tydef_desc |
|
445 |
|
|
446 |
let pp_emf_top_const fmt const_top = |
|
456 |
fprintf fmt "{ \"%s\": @[%a@] }" typedef.tydef_id pp_emf_typ_dec |
|
457 |
typedef.tydef_desc |
|
458 |
|
|
459 |
let pp_emf_top_const fmt const_top = |
|
447 | 460 |
let const = Corelang.const_of_top const_top in |
448 |
fprintf fmt "{ \"%s\": %t }" |
|
449 |
const.const_id |
|
461 |
fprintf fmt "{ \"%s\": %t }" const.const_id |
|
450 | 462 |
(pp_emf_cst const.const_value const.const_type) |
451 | 463 |
|
452 | 464 |
(* Local Variables: *) |
Also available in: Unified diff
reformatting