Project

General

Profile

Revision 59020713 src/backends/EMF/EMF_common.ml

View differences:

src/backends/EMF/EMF_common.ml
76 76
*)
77 77
  
78 78
  
79
let pp_tag_type fmt typ =
80
  let rec aux tydec_desc =
81
  match tydec_desc with  
82
  | Tydec_int -> fprintf fmt "int"
83
  | Tydec_real -> fprintf fmt "real"
84
  | Tydec_bool -> fprintf fmt "bool"
85
  | Tydec_clock ty -> aux ty
86
  | Tydec_enum const_list -> (
87
    let size = List.length const_list in
88
    if size < 255 then
89
      fprintf fmt "uint8"
90
    else if size < 65535 then
91
      fprintf fmt "uint16"
92
    else
93
      assert false (* Too much states. This not reasonable *)
94
  )
95
  | Tydec_const _ | Tydec_struct _ | Tydec_array _ | Tydec_any -> eprintf "unhandled cst tag in EMF: %a@." Printers.pp_var_type_dec_desc tydec_desc; assert false
96
  in
97
  aux typ.tydef_desc
98 79

  
99
     
100
let pp_cst_type fmt c (*infered_typ*) =
101
  match c with
102
  | Const_tag t ->
103
     let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
104
     if typ.tydef_id = "bool" then
105
       fprintf fmt "bool"
106
     else
107
       pp_tag_type fmt typ
108
  | Const_int _ -> fprintf fmt "int" (*!Options.int_type*)
109
  | Const_real _ -> fprintf fmt "real" (*!Options.real_type*)
110
  | Const_string _ -> fprintf fmt "string" 
111
  | _ -> eprintf "cst: %a@." Printers.pp_const c; assert false
80
let rec pp_emf_dim fmt dim_expr =
81
  fprintf fmt "{";
82
  (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
  );
95
  fprintf fmt "}"
112 96

  
113
let rec pp_infered_type fmt t =
114
  let open Types in
115
  if is_bool_type t  then fprintf fmt "bool" else
116
  if is_int_type t then fprintf fmt "int" else (* !Options.int_type *)
117
  if is_real_type t then fprintf fmt "real" else (* !Options.real_type *)
118
  match t.tdesc with
119
  | Tclock t ->
120
     pp_infered_type fmt t
121
  | Tstatic (_, t) ->
122
     fprintf fmt "%a" pp_infered_type t
123
  | Tconst id ->
124
    (* This is a type id for a enumerated type, eg. introduced by automata *)
125
     let typ =
126
       (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table (Tydec_const id)))
127
     in
128
     pp_tag_type fmt typ
129
   | Tlink ty -> 
130
       pp_infered_type fmt ty 
131
   | _ -> eprintf "unhandled type: %a@." Types.print_node_ty t; assert false
132 97
     
98

  
99

  
100
(* First try to print the declared one *)
133 101
let rec pp_concrete_type dec_t infered_t fmt =
134 102
  match dec_t with
135
  | Tydec_int -> fprintf fmt "int" (* !Options.int_type *)
136
  | Tydec_real -> fprintf fmt "real" (* !Options.real_type *)
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 *)
137 108
  (* TODO we could add more concrete types here if they were available in
138 109
     dec_t *)
139
  | Tydec_bool -> fprintf fmt "bool"
110
  | Tydec_bool -> fprintf fmt "{ \"kind\": \"bool\" }"
140 111
  | Tydec_clock t -> pp_concrete_type t infered_t fmt
141 112
  | Tydec_const id -> (
142
    (* This is a type id for a enumerated type, eg. introduced by automata *)
113
    (* This is an alias type *)
114

  
115
    (* id for a enumerated type, eg. introduced by automata *)
143 116
    let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t)) in
144
    pp_tag_type fmt typ
117
    (* Print the type name associated to this enumerated type. This is
118
       basically an integer *)
119
    pp_tag_type id typ infered_t fmt
120
  )
121
                    
122
  | 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 ()
134
    in
135
    fprintf fmt "{ \"kind\": \"array\", \"base_type\": %t, \"dim\": %a }"
136
      (pp_concrete_type e inf_base)
137
      pp_emf_dim dim
145 138
  )
146
  | Tydec_any -> pp_infered_type fmt infered_t 
147
  | _ -> eprintf
148
     "unhandled construct in type printing for EMF backend: %a@."
149
     Printers.pp_var_type_dec_desc dec_t; raise (Failure "var")
139
                          
140
(* | _ -> eprintf
141
 *          "unhandled construct in type printing for EMF backend: %a@."
142
 *          Printers.pp_var_type_dec_desc dec_t; raise (Failure "var") *)
143
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 *)
145
  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
151
    | 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
150 157
       
158
    | Tydec_clock ty -> aux ty
159
    | Tydec_enum const_list -> ( (* enum can be mapped to int *)
160
      let size = List.length const_list in
161
      fprintf fmt "{ \"name\": \"%s\", \"kind\": \"enum\", \"size\": \"%i\" }" id size
162
    )
163
    | 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
168
  in
169
  aux typ.tydef_desc
170
and pp_infered_type fmt t =
171
  (* Shall only be used for variable types that were not properly declared. Ie generated at compile time. *)
172
  let open Types in
173
  if is_bool_type t  then fprintf fmt "bool" else
174
    if is_int_type t then fprintf fmt "int" else (* !Options.int_type *)
175
      if is_real_type t then fprintf fmt "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
        | _ -> eprintf "unhandled type: %a@." Types.print_node_ty t; assert false
151 191

  
152 192
(*let pp_cst_type fmt v =
153 193
  match v.value_desc with
154 194
  | Cst c-> pp_cst_type c v.value_type fmt (* constants do not have declared type (yet) *)
155 195
  | _ -> assert false
156 196
*)
157
       
197

  
198
(* Provide both the declared type and the infered one. *)
158 199
let pp_var_type fmt v =
159 200
  try
160 201
    if Machine_types.is_specified v then
161 202
      Machine_types.pp_var_type fmt v
162 203
    else
163 204
      pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
164
  with Failure _ -> eprintf "failed var: %a@." Printers.pp_var v; assert false
205
  with Failure msg -> eprintf "failed var: %a@.%s@." Printers.pp_var v msg; assert false
165 206
    
166 207
(******** Other print functions *)
167
    
208

  
209
let pp_emf_list ?(eol:('a, formatter, unit) Pervasives.format="") pp fmt l =
210
  match l with
211
    [] -> ()
212
  | _ -> fprintf fmt "@[";
213
         Utils.fprintf_list ~sep:",@ " pp fmt l;
214
         fprintf fmt "@]%(%)" eol
215
  
216
(* Print the variable declaration *)
168 217
let pp_emf_var_decl fmt v =
169 218
  fprintf fmt "@[{\"name\": \"%a\", \"datatype\":\"%a\", \"original_name\": \"%a\"}@]"
170 219
    pp_var_name v
171 220
    pp_var_type v
172 221
    Printers.pp_var_name v
173
    
174
let pp_emf_vars_decl fmt vl =
175
  fprintf fmt "@[";
176
  Utils.fprintf_list ~sep:",@ " pp_emf_var_decl fmt vl;
177
  fprintf fmt "@]"
222

  
223
let pp_emf_vars_decl = pp_emf_list pp_emf_var_decl
224

  
225
 
178 226
  
179 227
let reset_name id =
180 228
  "reset_" ^ id
......
187 235
    let const_list = match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false in
188 236
    fprintf fmt "%i" (get_idx t const_list)
189 237

  
190
let pp_emf_cst fmt c =
238
let pp_cst_type c inf fmt (*infered_typ*) =
239
  match c with
240
  | Const_tag t ->
241
     let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
242
     if typ.tydef_id = "bool" then
243
       fprintf fmt "bool"
244
     else
245
       pp_tag_type t typ inf fmt
246
  | Const_int _ -> fprintf fmt "int" (*!Options.int_type*)
247
  | Const_real _ -> fprintf fmt "real" (*!Options.real_type*)
248
  | Const_string _ -> fprintf fmt "string" 
249
  | _ -> eprintf "cst: %a@." Printers.pp_const c; assert false
250

  
251
    
252
let pp_emf_cst c inf fmt =
253
  let pp_typ fmt =
254
    fprintf fmt "\"datatype\": \"";
255
    pp_cst_type c inf fmt;
256
    fprintf fmt "\"@ "
257
  in
191 258
  match c with
192 259
  | Const_tag t->
193 260
     let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
......
195 262
       fprintf fmt "{@[\"type\": \"constant\",@ ";
196 263
       fprintf fmt"\"value\": \"%a\",@ "
197 264
	 Printers.pp_const c;
198
       fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type c;
265
       pp_typ fmt;
199 266
       fprintf fmt "@]}"
200 267
     )
201 268
     else (
......
203 270
	 pp_tag_id t;
204 271
       fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
205 272
	 typ.tydef_id t;
206
       fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type c;
273
       pp_typ fmt;
207 274
       fprintf fmt "@]}"
208 275
     )
209 276
  | Const_string s ->
210
    fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s;
211
    fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type c;
212
    fprintf fmt "@]}"
277
     fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%s\",@ " s;
278
     pp_typ fmt;
279
     fprintf fmt "@]}"
213 280
     
214 281
  | _ -> (
215 282
    fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
216 283
      Printers.pp_const c;
217
    fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type c;
284
    pp_typ fmt;
218 285
    fprintf fmt "@]}"
219 286
  )
220 287
  
221
  
288
(* Print a value: either a constant or a variable value *)
222 289
let pp_emf_cst_or_var m fmt v =
223 290
  match v.value_desc with
224
  | Cst c -> pp_emf_cst fmt c
291
  | Cst c -> pp_emf_cst c v.value_type fmt 
225 292
  | Var v -> (
226 293
    fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
227 294
      pp_var_name v;
......
239 306
    
240 307
let rec pp_emf_expr fmt e =
241 308
  match e.expr_desc with
242
  | Expr_const c -> pp_emf_cst fmt c
309
  | Expr_const c -> pp_emf_cst c e.expr_type fmt 
243 310
  | Expr_ident id ->
244 311
     fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
245 312
       print_protect (fun fmt -> pp_print_string fmt id);
......
254 321
  | Expr_tuple el ->
255 322
     fprintf fmt "[@[<hov 0>%a@ @]]"
256 323
       (Utils.fprintf_list ~sep:",@ " pp_emf_expr) el
324
 (* Missing these 
325
  | Expr_ite   of expr * expr * expr
326
  | Expr_arrow of expr * expr
327
  | Expr_fby of expr * expr
328
  | Expr_array of expr list
329
  | Expr_access of expr * Dimension.dim_expr
330
  | Expr_power of expr * Dimension.dim_expr
331
  | Expr_pre of expr
332
  | Expr_when of expr * ident * label
333
  | Expr_merge of ident * (label * expr) list
334
  | Expr_appl of call_t
335
  *)
257 336
  | _ -> (
258 337
    Log.report ~level:2
259 338
      (fun fmt ->
......
274 353
(* | Expr_when of expr * ident * label *)
275 354
(* | Expr_merge of ident * (label * expr) list *)
276 355
(* | Expr_appl of call_t *)
277
     
278 356

  
357
let pp_emf_exprs = pp_emf_list pp_emf_expr
358
       
359
let pp_emf_const fmt v =
360
  fprintf fmt "@[{\"name\": \"%a\", \"datatype\":\"%a\", \"original_name\": \"%a\", \"value\": \"%a\"}@]"
361
    pp_var_name v
362
    pp_var_type v
363
    Printers.pp_var_name v
364
    pp_emf_expr (match v.var_dec_value with None -> assert false | Some e -> e)
365

  
366
let pp_emf_consts = pp_emf_list pp_emf_const
367
                  
279 368
let pp_emf_eexpr fmt ee =
280 369
  fprintf fmt "{@[<hov 0>\"quantifiers\": \"%a\",@ \"qfexpr\": @[%a@]@] }"
281 370
    (Utils.fprintf_list ~sep:"; " Printers.pp_quantifiers) ee.eexpr_quantifiers
282 371
    pp_emf_expr ee.eexpr_qfexpr
283
    
284
    
372

  
373
let pp_emf_eexprs = pp_emf_list pp_emf_eexpr
374

  
375
(*
376
                      TODO Thanksgiving
377

  
378
                      trouver un moyen de transformer en machine code les instructions de chaque spec
379
                      peut etre associer a chaque imported node une minimachine
380
                      et rajouter un champ a spec dans machine code pour stoquer memoire et instr
381
 *)                
382
                 
383
let pp_emf_stmt fmt stmt =
384
  match stmt with
385
  | Aut _ -> assert false
386
  | Eq eq -> (
387
    fprintf fmt "@[ @[<v 2>\"%a\": {@ " (Utils.fprintf_list ~sep:"_" pp_print_string) eq.eq_lhs;
388
    fprintf fmt "\"lhs\": [%a],@ " (Utils.fprintf_list ~sep:", " (fun fmt vid -> fprintf fmt "\"%s\"" vid)) eq.eq_lhs;
389
    fprintf fmt "\"rhs\": \"%a\",@ " pp_emf_expr eq.eq_rhs;
390
    fprintf fmt "@]@]@ }"
391
  )
392

  
393
let pp_emf_stmts = pp_emf_list pp_emf_stmt 
394
  
395
(* Printing the type declaration, not its use *)
396
let rec pp_emf_typ_dec fmt tydef_dec =
397
  fprintf fmt "{";
398
  (match tydef_dec with
399
   | Tydec_any -> fprintf fmt "\"kind\": \"any\""
400
   | Tydec_int -> fprintf fmt "\"kind\": \"int\""
401
   | Tydec_real -> fprintf fmt "\"kind\": \"real\""
402
   | Tydec_bool-> fprintf fmt "\"kind\": \"bool\""
403
   | Tydec_clock ck -> pp_emf_typ_dec fmt ck
404
   | Tydec_const c -> fprintf fmt "\"kind\": \"alias\",@ \"value\": \"%s\"" c
405
   | Tydec_enum el -> fprintf fmt "\"kind\": \"enum\",@ \"elements\": [%a]"
406
                        (Utils.fprintf_list ~sep:", " (fun fmt e -> fprintf fmt "\"%s\"" e)) el
407
   | Tydec_struct s -> fprintf fmt "\"kind\": \"struct\",@ \"fields\": [%a]"
408
                         (Utils.fprintf_list ~sep:", " (fun fmt (id,typ) ->
409
                              fprintf fmt "\"%s\": %a" id pp_emf_typ_dec typ)) s
410
   | Tydec_array (dim, typ) -> fprintf fmt "\"kind\": \"array\",@ \"dim\": @[%a@],@ \"base\": %a"
411
                               pp_emf_dim dim
412
                               pp_emf_typ_dec typ
413
  );
414
  fprintf fmt "}"
415
 
416
let pp_emf_typedef fmt typdef_top =
417
  let typedef = Corelang.typedef_of_top typdef_top in
418
  fprintf fmt "\"%s\": @[%a@]" typedef.tydef_id pp_emf_typ_dec typedef.tydef_desc 
419
  
420
let pp_emf_top_const fmt const_top = 
421
  let const = Corelang.const_of_top const_top in
422
  fprintf fmt "\"%s\": " const.const_id;
423
  pp_emf_cst const.const_value const.const_type fmt
424

  
285 425
(* Local Variables: *)
286 426
(* compile-command: "make -C ../.." *)
287 427
(* End: *)

Also available in: Unified diff