Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / EMF / EMF_common.ml @ ef8a361a

History | View | Annotate | Download (5.94 KB)

1
open LustreSpec
2
open Format
3
open Machine_code 
4

    
5
(* Matlab starting counting from 1.
6
   simple function to extract the element id in the list. Starts from 1. *)
7
let rec get_idx x l =
8
  match l with
9
  | hd::tl -> if hd = x then 1 else 1+(get_idx x tl)
10
  | [] -> assert false
11

    
12
let rec get_expr_vars v =
13
  match v.value_desc with
14
  | Cst c -> VSet.empty
15
  | LocalVar v | StateVar v -> VSet.singleton v
16
  | Fun (_, args) -> List.fold_left (fun accu v -> VSet.union accu (get_expr_vars v)) VSet.empty args
17
  | _ -> assert false (* Invalid argument *)
18

    
19
let is_imported_node f m =
20
  let (decl, _) = List.assoc f m.mcalls in
21
  Corelang.is_imported_node decl
22

    
23
(* Handling of enumerated types: for the moment each of such type is transformed
24
   into an int: the idx number of the constant in the typedef. This is not so
25
   nice but is compatible with basic Simulink types: int, real, bools) *)
26
(*
27
let recorded_enums = ref []
28
let record_types prog =
29
  let typedefs = Corelang.get_typedefs prog in
30
  List.iter (fun top ->
31
    let consts = consts_of_enum_type top in
32
  ) prog
33
*)
34
    
35
(* Basic printing functions *)
36
    
37
let pp_var_string fmt v = fprintf fmt "\"%s\"" v
38
(*let pp_var_name fmt v = fprintf fmt "\"%a\"" Printers.pp_var_name v*)
39
(*let pp_node_args = fprintf_list ~sep:", " pp_var_name*)
40

    
41
(********* Printing types ***********)
42
(* Two cases:
43
   - printing a variable definition:
44
     -  we look at the declared type if available
45
     - if not, we print the inferred type
46

    
47
   - printing a constant definion
48
*)
49
  
50
  
51
let pp_tag_type fmt typ =
52
  let const_list = match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false in
53
  let size = List.length const_list in
54
  if size < 255 then
55
    fprintf fmt "uint8"
56
  else if size < 65535 then
57
fprintf fmt "uint16"
58
  else
59
    assert false (* Too much states. This not reasonable *)
60
      
61
   
62
     
63
let pp_cst_type c infered_typ fmt =
64
  match c with
65
  | Const_tag t ->
66
     let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
67
     if typ.tydef_id = "bool" then
68
       fprintf fmt "bool"
69
     else
70
       pp_tag_type fmt typ
71
  | Const_int _ -> fprintf fmt "%s" !Options.int_type
72
  | Const_real _ -> fprintf fmt "%s" !Options.real_type
73
  | _ -> Format.eprintf "cst: %a@." Printers.pp_const c; assert false
74

    
75
let rec pp_infered_type fmt t =
76
  let open Types in
77
  match t.tdesc with
78
  | Tint ->
79
     fprintf fmt "%s" !Options.int_type
80
  | Treal ->
81
     fprintf fmt "%s" !Options.real_type
82
  | Tbool ->
83
     fprintf fmt "bool"
84
  | Tclock t ->
85
     pp_infered_type fmt t
86
  | Tstatic (_, t) ->
87
     fprintf fmt "%a" pp_infered_type t
88
  | Tconst id ->
89
    (* This is a type id for a enumerated type, eg. introduced by automata *)
90
     let typ =
91
       (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table (Tydec_const id)))
92
     in
93
     pp_tag_type fmt typ
94
   | Tlink ty -> 
95
       pp_infered_type fmt ty 
96
  | _ -> Format.eprintf "unhandled type: %a@." Types.print_node_ty t; assert false
97
let rec pp_concrete_type dec_t infered_t fmt =
98
  match dec_t with
99
  | Tydec_int -> fprintf fmt "%s" !Options.int_type
100
  | Tydec_real -> fprintf fmt "%s" !Options.real_type
101
  (* TODO we could add more concrete types here if they were available in
102
     dec_t *)
103
  | Tydec_bool -> fprintf fmt "bool"
104
  | Tydec_clock t -> pp_concrete_type t infered_t fmt
105
  | Tydec_const id -> (
106
    (* This is a type id for a enumerated type, eg. introduced by automata *)
107
    let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.type_table dec_t)) in
108
    pp_tag_type fmt typ
109
  )
110
  | Tydec_any -> pp_infered_type fmt infered_t 
111
  | _ -> Format.eprintf
112
     "unhandled construct in type printing for EMF backend: %a@."
113
     Printers.pp_var_type_dec_desc dec_t; raise (Failure "var")
114
       
115

    
116
let pp_cst_type fmt v =
117
  match v.value_desc with
118
  | Cst c-> pp_cst_type c v.value_type fmt (* constants do not have declared type (yet) *)
119
  | _ -> assert false
120
     
121
let pp_var_type fmt v =
122
  try
123
  pp_concrete_type v.var_dec_type.ty_dec_desc v.var_type fmt
124
  with Failure _ -> Format.eprintf "failed var: %a@." Printers.pp_var v; assert false
125
(******** Other print functions *)
126
    
127
let pp_emf_var_decl fmt v =
128
  fprintf fmt "@[{\"name\": \"%a\", \"datatype\":\"%a\"}@]"
129
    Printers.pp_var_name v
130
    pp_var_type v
131
    
132
let pp_emf_vars_decl fmt vl =
133
  fprintf fmt "@[";
134
  Utils.fprintf_list ~sep:",@ " pp_emf_var_decl fmt vl;
135
  fprintf fmt "@]"
136
  
137
let reset_name id =
138
  "reset_" ^ id
139
  
140
let pp_tag_id fmt t =
141
  let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
142
  if typ.tydef_id = "bool" then
143
    pp_print_string fmt t
144
  else
145
    let const_list = match typ.tydef_desc with Tydec_enum tl -> tl | _ -> assert false in
146
    fprintf fmt "%i" (get_idx t const_list)
147
     
148
let pp_emf_cst_or_var fmt v =
149
  match v.value_desc with
150
  | Cst ((Const_tag t) as c)->
151
     let typ = (Corelang.typedef_of_top (Hashtbl.find Corelang.tag_table t)) in
152
     if typ.tydef_id = "bool" then (
153
       fprintf fmt "{@[\"type\": \"constant\",@ ";
154
       fprintf fmt"\"value\": \"%a\",@ "
155
	 Printers.pp_const c;
156
       fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type v;
157
       fprintf fmt "@]}"
158
     )
159
     else (
160
       fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ " 
161
	 pp_tag_id t;
162
       fprintf fmt "\"origin_type\": \"%s\",@ \"origin_value\": \"%s\",@ "
163
	 typ.tydef_id t;
164
       fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type v;
165
       fprintf fmt "@]}"
166
     )
167
  | Cst c -> (
168
    fprintf fmt "{@[\"type\": \"constant\",@ \"value\": \"%a\",@ "
169
      Printers.pp_const c;
170
    fprintf fmt "\"datatype\": \"%a\"@ " pp_cst_type v;
171
    fprintf fmt "@]}"
172
  )
173
  | LocalVar v
174
  | StateVar v -> (
175
    fprintf fmt "{@[\"type\": \"variable\",@ \"value\": \"%a\",@ "
176
      Printers.pp_var_name v;
177
    fprintf fmt "\"datatype\": \"%a\"@ " pp_var_type v;
178
    fprintf fmt "@]}"
179
  )
180
  | _ -> Format.eprintf "Not of cst or var: %a@." Machine_code.pp_val v ; assert false (* Invalid argument *)
181

    
182

    
183
let pp_emf_cst_or_var_list =
184
  Utils.fprintf_list ~sep:",@ " pp_emf_cst_or_var
185

    
186

    
187
(* Local Variables: *)
188
(* compile-command: "make -C ../.." *)
189
(* End: *)