Project

General

Profile

« Previous | Next » 

Revision ca7ff3f7

Added by LĂ©lio Brun 8 months ago

reformatting

View differences:

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