Project

General

Profile

Revision ef34b4ae src/corelang.ml

View differences:

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