Revision 70e1006b src/corelang.ml
src/corelang.ml | ||
---|---|---|
28 | 28 |
|
29 | 29 |
let dummy_type_dec = {ty_dec_desc=Tydec_any; ty_dec_loc=Location.dummy_loc} |
30 | 30 |
|
31 |
|
|
32 |
|
|
33 | 31 |
let dummy_clock_dec = {ck_dec_desc=Ckdec_any; ck_dec_loc=Location.dummy_loc} |
34 | 32 |
|
35 | 33 |
|
... | ... | |
87 | 85 |
assert_expr = expr |
88 | 86 |
} |
89 | 87 |
|
90 |
let mktop_decl loc d = |
|
91 |
{ top_decl_desc = d; top_decl_loc = loc } |
|
88 |
let mktop_decl loc own itf d =
|
|
89 |
{ top_decl_desc = d; top_decl_loc = loc; top_decl_owner = own; top_decl_itf = itf }
|
|
92 | 90 |
|
93 | 91 |
let mkpredef_call loc funname args = |
94 | 92 |
mkexpr loc (Expr_appl (funname, mkexpr loc (Expr_tuple args), None)) |
95 | 93 |
|
94 |
|
|
95 |
let const_of_top top_decl = |
|
96 |
match top_decl.top_decl_desc with |
|
97 |
| Const c -> c |
|
98 |
| _ -> assert false |
|
99 |
|
|
100 |
let node_of_top top_decl = |
|
101 |
match top_decl.top_decl_desc with |
|
102 |
| Node nd -> nd |
|
103 |
| _ -> assert false |
|
104 |
|
|
105 |
let imported_node_of_top top_decl = |
|
106 |
match top_decl.top_decl_desc with |
|
107 |
| ImportedNode ind -> ind |
|
108 |
| _ -> assert false |
|
109 |
|
|
110 |
let typedef_of_top top_decl = |
|
111 |
match top_decl.top_decl_desc with |
|
112 |
| TypeDef tdef -> tdef |
|
113 |
| _ -> assert false |
|
114 |
|
|
115 |
let dependency_of_top top_decl = |
|
116 |
match top_decl.top_decl_desc with |
|
117 |
| Open (local, dep) -> (local, dep) |
|
118 |
| _ -> assert false |
|
119 |
|
|
120 |
let consts_of_enum_type top_decl = |
|
121 |
match top_decl.top_decl_desc with |
|
122 |
| TypeDef tdef -> |
|
123 |
(match tdef.tydef_desc with |
|
124 |
| Tydec_enum tags -> List.map (fun tag -> let cdecl = { const_id = tag; const_loc = top_decl.top_decl_loc; const_value = Const_tag tag; const_type = Type_predef.type_const tdef.tydef_id } in { top_decl with top_decl_desc = Const cdecl }) tags |
|
125 |
| _ -> []) |
|
126 |
| _ -> assert false |
|
127 |
|
|
96 | 128 |
(************************************************************) |
97 | 129 |
(* Eexpr functions *) |
98 | 130 |
(************************************************************) |
... | ... | |
142 | 174 |
let (node_table : (ident, top_decl) Hashtbl.t) = Hashtbl.create 30 |
143 | 175 |
let consts_table = Hashtbl.create 30 |
144 | 176 |
|
177 |
let print_node_table fmt () = |
|
178 |
begin |
|
179 |
Format.fprintf fmt "{ /* node table */@."; |
|
180 |
Hashtbl.iter (fun id nd -> |
|
181 |
Format.fprintf fmt "%s |-> %a" |
|
182 |
id |
|
183 |
Printers.pp_short_decl nd |
|
184 |
) node_table; |
|
185 |
Format.fprintf fmt "}@." |
|
186 |
end |
|
187 |
|
|
188 |
let print_consts_table fmt () = |
|
189 |
begin |
|
190 |
Format.fprintf fmt "{ /* consts table */@."; |
|
191 |
Hashtbl.iter (fun id const -> |
|
192 |
Format.fprintf fmt "%s |-> %a" |
|
193 |
id |
|
194 |
Printers.pp_const_decl (const_of_top const) |
|
195 |
) consts_table; |
|
196 |
Format.fprintf fmt "}@." |
|
197 |
end |
|
198 |
|
|
145 | 199 |
let node_name td = |
146 | 200 |
match td.top_decl_desc with |
147 | 201 |
| Node nd -> nd.node_id |
... | ... | |
174 | 228 |
|
175 | 229 |
|
176 | 230 |
(* alias and type definition table *) |
231 |
|
|
232 |
let top_int_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "int"; tydef_desc = Tydec_int}) |
|
233 |
let top_bool_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "bool"; tydef_desc = Tydec_bool}) |
|
234 |
let top_float_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "float"; tydef_desc = Tydec_float}) |
|
235 |
let top_real_type = mktop_decl Location.dummy_loc Version.prefix false (TypeDef {tydef_id = "real"; tydef_desc = Tydec_real}) |
|
236 |
|
|
177 | 237 |
let type_table = |
178 | 238 |
Utils.create_hashtable 20 [ |
179 |
Tydec_int , Tydec_int;
|
|
180 |
Tydec_bool , Tydec_bool;
|
|
181 |
Tydec_float, Tydec_float;
|
|
182 |
Tydec_real , Tydec_real
|
|
239 |
Tydec_int , top_int_type;
|
|
240 |
Tydec_bool , top_bool_type;
|
|
241 |
Tydec_float, top_float_type;
|
|
242 |
Tydec_real , top_real_type
|
|
183 | 243 |
] |
184 | 244 |
|
245 |
let print_type_table fmt () = |
|
246 |
begin |
|
247 |
Format.fprintf fmt "{ /* type table */@."; |
|
248 |
Hashtbl.iter (fun tydec tdef -> |
|
249 |
Format.fprintf fmt "%a |-> %a" |
|
250 |
Printers.pp_var_type_dec_desc tydec |
|
251 |
Printers.pp_typedef (typedef_of_top tdef) |
|
252 |
) type_table; |
|
253 |
Format.fprintf fmt "}@." |
|
254 |
end |
|
255 |
|
|
185 | 256 |
let rec is_user_type typ = |
186 | 257 |
match typ with |
187 | 258 |
| Tydec_int | Tydec_bool | Tydec_real |
... | ... | |
190 | 261 |
| _ -> true |
191 | 262 |
|
192 | 263 |
let get_repr_type typ = |
193 |
let typ_def = Hashtbl.find type_table typ in
|
|
264 |
let typ_def = (typedef_of_top (Hashtbl.find type_table typ)).tydef_desc in
|
|
194 | 265 |
if is_user_type typ_def then typ else typ_def |
195 | 266 |
|
196 | 267 |
let rec coretype_equal ty1 ty2 = |
197 |
(*let res =*)
|
|
268 |
let res =
|
|
198 | 269 |
match ty1, ty2 with |
199 | 270 |
| Tydec_any , _ |
200 | 271 |
| _ , Tydec_any -> assert false |
201 | 272 |
| Tydec_const _ , Tydec_const _ -> get_repr_type ty1 = get_repr_type ty2 |
202 |
| Tydec_const _ , _ -> let ty1' = Hashtbl.find type_table ty1
|
|
273 |
| Tydec_const _ , _ -> let ty1' = (typedef_of_top (Hashtbl.find type_table ty1)).tydef_desc
|
|
203 | 274 |
in (not (is_user_type ty1')) && coretype_equal ty1' ty2 |
204 | 275 |
| _ , Tydec_const _ -> coretype_equal ty2 ty1 |
205 | 276 |
| Tydec_int , Tydec_int |
... | ... | |
215 | 286 |
(List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl1) |
216 | 287 |
(List.sort (fun (f1,_) (f2,_) -> compare f1 f2) fl2) |
217 | 288 |
| _ -> false |
218 |
(*in (Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res; res)*)
|
|
289 |
in ((*Format.eprintf "coretype_equal %a %a = %B@." Printers.pp_var_type_dec_desc ty1 Printers.pp_var_type_dec_desc ty2 res;*) res)
|
|
219 | 290 |
|
220 | 291 |
let tag_true = "true" |
221 | 292 |
let tag_false = "false" |
... | ... | |
262 | 333 |
(* To guarantee uniqueness of tags in enum types *) |
263 | 334 |
let tag_table = |
264 | 335 |
Utils.create_hashtable 20 [ |
265 |
tag_true, Tydec_bool;
|
|
266 |
tag_false, Tydec_bool
|
|
336 |
tag_true, top_bool_type;
|
|
337 |
tag_false, top_bool_type
|
|
267 | 338 |
] |
268 | 339 |
|
269 | 340 |
(* To guarantee uniqueness of fields in struct types *) |
... | ... | |
272 | 343 |
] |
273 | 344 |
|
274 | 345 |
let get_enum_type_tags cty = |
346 |
(*Format.eprintf "get_enum_type_tags %a@." Printers.pp_var_type_dec_desc cty;*) |
|
275 | 347 |
match cty with |
276 | 348 |
| Tydec_bool -> [tag_true; tag_false] |
277 |
| Tydec_const _ -> (match Hashtbl.find type_table cty with
|
|
349 |
| Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
|
|
278 | 350 |
| Tydec_enum tl -> tl |
279 | 351 |
| _ -> assert false) |
280 | 352 |
| _ -> assert false |
281 | 353 |
|
282 | 354 |
let get_struct_type_fields cty = |
283 | 355 |
match cty with |
284 |
| Tydec_const _ -> (match Hashtbl.find type_table cty with
|
|
356 |
| Tydec_const _ -> (match (typedef_of_top (Hashtbl.find type_table cty)).tydef_desc with
|
|
285 | 357 |
| Tydec_struct fl -> fl |
286 | 358 |
| _ -> assert false) |
287 | 359 |
| _ -> assert false |
... | ... | |
403 | 475 |
List.fold_left ( |
404 | 476 |
fun nodes decl -> |
405 | 477 |
match decl.top_decl_desc with |
406 |
| Node nd -> nd::nodes
|
|
407 |
| Consts _ | ImportedNode _ | Open _ | Type _ -> nodes
|
|
478 |
| Node _ -> decl::nodes
|
|
479 |
| Const _ | ImportedNode _ | Open _ | TypeDef _ -> nodes
|
|
408 | 480 |
) [] prog |
409 | 481 |
|
410 |
let get_consts prog =
|
|
482 |
let get_imported_nodes prog =
|
|
411 | 483 |
List.fold_left ( |
412 |
fun consts decl ->
|
|
484 |
fun nodes decl ->
|
|
413 | 485 |
match decl.top_decl_desc with |
414 |
| Consts clist -> clist@consts
|
|
415 |
| Node _ | ImportedNode _ | Open _ | Type _ -> consts
|
|
486 |
| ImportedNode _ -> decl::nodes
|
|
487 |
| Const _ | Node _ | Open _ | TypeDef _-> nodes
|
|
416 | 488 |
) [] prog |
417 | 489 |
|
418 |
let get_types prog =
|
|
419 |
List.fold_left (
|
|
420 |
fun types decl ->
|
|
490 |
let get_consts prog =
|
|
491 |
List.fold_right (
|
|
492 |
fun decl consts ->
|
|
421 | 493 |
match decl.top_decl_desc with |
422 |
| Type typ -> typ::types |
|
423 |
| Node _ | ImportedNode _ | Open _ | Consts _ -> types |
|
424 |
) [] prog |
|
494 |
| Const _ -> decl::consts |
|
495 |
| Node _ | ImportedNode _ | Open _ | TypeDef _ -> consts |
|
496 |
) prog [] |
|
497 |
|
|
498 |
let get_typedefs prog = |
|
499 |
List.fold_right ( |
|
500 |
fun decl types -> |
|
501 |
match decl.top_decl_desc with |
|
502 |
| TypeDef _ -> decl::types |
|
503 |
| Node _ | ImportedNode _ | Open _ | Const _ -> types |
|
504 |
) prog [] |
|
505 |
|
|
506 |
let get_dependencies prog = |
|
507 |
List.fold_right ( |
|
508 |
fun decl deps -> |
|
509 |
match decl.top_decl_desc with |
|
510 |
| Open _ -> decl::deps |
|
511 |
| Node _ | ImportedNode _ | TypeDef _ | Const _ -> deps |
|
512 |
) prog [] |
|
425 | 513 |
|
426 | 514 |
let get_node_interface nd = |
427 | 515 |
{nodei_id = nd.node_id; |
... | ... | |
582 | 670 |
(match top.top_decl_desc with |
583 | 671 |
| Node nd -> |
584 | 672 |
{ top with top_decl_desc = Node (rename_node f_node f_var f_const nd) } |
585 |
| Consts c ->
|
|
586 |
{ top with top_decl_desc = Consts (List.map (rename_const f_const) c) }
|
|
673 |
| Const c -> |
|
674 |
{ top with top_decl_desc = Const (rename_const f_const c) }
|
|
587 | 675 |
| ImportedNode _ |
588 | 676 |
| Open _ |
589 |
| Type _ -> top) |
|
677 |
| TypeDef _ -> top)
|
|
590 | 678 |
::accu |
591 | 679 |
) [] prog |
592 | 680 |
) |
... | ... | |
604 | 692 |
fprintf fmt "%s: " ind.nodei_id; |
605 | 693 |
Utils.reset_names (); |
606 | 694 |
fprintf fmt "%a@ " Types.print_ty ind.nodei_type |
607 |
| Consts _ | Open _ | Type _ -> ()
|
|
695 |
| Const _ | Open _ | TypeDef _ -> ()
|
|
608 | 696 |
|
609 | 697 |
let pp_prog_type fmt tdecl_list = |
610 | 698 |
Utils.fprintf_list ~sep:"" pp_decl_type fmt tdecl_list |
... | ... | |
619 | 707 |
fprintf fmt "%s: " ind.nodei_id; |
620 | 708 |
Utils.reset_names (); |
621 | 709 |
fprintf fmt "%a@ " Clocks.print_ck ind.nodei_clock |
622 |
| Consts _ | Open _ | Type _ -> ()
|
|
710 |
| Const _ | Open _ | TypeDef _ -> ()
|
|
623 | 711 |
|
624 | 712 |
let pp_prog_clock fmt prog = |
625 | 713 |
Utils.fprintf_list ~sep:"" pp_decl_clock fmt prog |
... | ... | |
642 | 730 |
fprintf fmt |
643 | 731 |
"%s is already defined.@." |
644 | 732 |
sym |
733 |
| Unknown_library sym -> |
|
734 |
fprintf fmt |
|
735 |
"impossible to load library %s.@." |
|
736 |
sym |
|
645 | 737 |
|
646 | 738 |
(* filling node table with internal functions *) |
647 | 739 |
let vdecls_of_typ_ck cpt ty = |
... | ... | |
659 | 751 |
let (tin, tout) = Types.split_arrow ty in |
660 | 752 |
(*eprintf "internal fun %s: %d -> %d@." id (List.length (Types.type_list_of_type tin)) (List.length (Types.type_list_of_type tout));*) |
661 | 753 |
let cpt = ref (-1) in |
662 |
mktop_decl Location.dummy_loc |
|
754 |
mktop_decl Location.dummy_loc Version.prefix false
|
|
663 | 755 |
(ImportedNode |
664 | 756 |
{nodei_id = id; |
665 | 757 |
nodei_type = ty; |
Also available in: Unified diff