Project

General

Profile

Revision ef34b4ae src/typing.ml

View differences:

src/typing.ml
130 130
 | Tstatic (_, t) -> coretype_type t
131 131
 | _         -> assert false
132 132

  
133
let get_type_definition tname =
133
let get_coretype_definition tname =
134 134
  try
135
    type_coretype (fun d -> ()) (Hashtbl.find type_table (Tydec_const tname))
135
    let top = Hashtbl.find type_table (Tydec_const tname) in
136
    match top.top_decl_desc with
137
    | TypeDef tdef -> tdef.tydef_desc
138
    | _ -> assert false
136 139
  with Not_found -> raise (Error (Location.dummy_loc, Unbound_type tname))
137 140

  
141
let get_type_definition tname =
142
    type_coretype (fun d -> ()) (get_coretype_definition tname)
143

  
138 144
(* Equality on ground types only *)
139 145
(* Should be used between local variables which must have a ground type *)
140 146
let rec eq_ground t1 t2 =
......
240 246

  
241 247
let rec type_struct_const_field loc (label, c) =
242 248
  if Hashtbl.mem field_table label
243
  then let tydec = Hashtbl.find field_table label in
249
  then let tydef = Hashtbl.find field_table label in
250
       let tydec = (typedef_of_top tydef).tydef_desc in 
244 251
       let tydec_struct = get_struct_type_fields tydec in
245 252
       let ty_label = type_coretype (fun d -> ()) (List.assoc label tydec_struct) in
246 253
       begin
......
260 267
		      Type_predef.type_array d ty
261 268
  | Const_tag t     ->
262 269
    if Hashtbl.mem tag_table t
263
    then type_coretype (fun d -> ()) (Hashtbl.find tag_table t)
270
    then 
271
      let tydef = typedef_of_top (Hashtbl.find tag_table t) in
272
      let tydec =
273
	if is_user_type tydef.tydef_desc
274
	then Tydec_const tydef.tydef_id
275
	else tydef.tydef_desc in
276
      type_coretype (fun d -> ()) tydec
264 277
    else raise (Error (loc, Unbound_value ("enum tag " ^ t)))
265 278
  | Const_struct fl ->
266 279
    let ty_struct = new_var () in
......
642 655
  nd.nodei_type <- ty_node;
643 656
  new_env
644 657

  
658
let type_top_const env cdecl =
659
  let ty = type_const cdecl.const_loc cdecl.const_value in
660
  let d =
661
    if is_dimension_type ty
662
    then dimension_of_const cdecl.const_loc cdecl.const_value
663
    else Dimension.mkdim_var () in
664
  let ty = Type_predef.type_static d ty in
665
  let new_env = Env.add_value env cdecl.const_id ty in
666
  cdecl.const_type <- ty;
667
  new_env
668

  
645 669
let type_top_consts env clist =
646
  List.fold_left (fun env cdecl ->
647
    let ty = type_const cdecl.const_loc cdecl.const_value in
648
    let d =
649
      if is_dimension_type ty
650
      then dimension_of_const cdecl.const_loc cdecl.const_value
651
      else Dimension.mkdim_var () in
652
    let ty = Type_predef.type_static d ty in
653
    let new_env = Env.add_value env cdecl.const_id ty in
654
    cdecl.const_type <- ty;
655
    new_env) env clist
656

  
657
let type_top_decl env decl =
670
  List.fold_left type_top_const env clist
671

  
672
let rec type_top_decl env decl =
658 673
  match decl.top_decl_desc with
659 674
  | Node nd -> (
660 675
      try
......
668 683
  )
669 684
  | ImportedNode nd ->
670 685
      type_imported_node env nd decl.top_decl_loc
671
  | Consts clist ->
672
      type_top_consts env clist
673
  | Type _
686
  | Const c ->
687
      type_top_const env c
688
  | TypeDef _ -> List.fold_left type_top_decl env (consts_of_enum_type decl)
674 689
  | Open _  -> env
675 690

  
676 691
let type_prog env decls =
......
702 717
      uneval_node_generics (nd.node_inputs @ nd.node_outputs)
703 718
  | ImportedNode nd ->
704 719
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
705
  | Consts _
706
  | Type _
720
  | Const _
721
  | TypeDef _
707 722
  | Open _  -> ()
708 723

  
709 724
let uneval_prog_generics prog =
710 725
 List.iter uneval_top_generics prog
711 726

  
712
let rec get_imported_node decls id =
727
let rec get_imported_symbol decls id =
713 728
  match decls with
714 729
  | [] -> assert false
715 730
  | decl::q ->
716 731
     (match decl.top_decl_desc with
717
      | ImportedNode nd when id = nd.nodei_id -> decl
718
      | _ -> get_imported_node q id)
732
      | ImportedNode nd when id = nd.nodei_id && decl.top_decl_itf -> decl
733
      | Const c when id = c.const_id && decl.top_decl_itf -> decl
734
      | TypeDef _ -> get_imported_symbol (consts_of_enum_type decl @ q) id
735
      | _ -> get_imported_symbol q id)
719 736

  
720 737
let check_env_compat header declared computed = 
721 738
  uneval_prog_generics header;
722
  Env.iter declared (fun k decl_type_k -> 
723
    let computed_t = instantiate (ref []) (ref []) 
724
				 (try Env.lookup_value computed k
725
				  with Not_found ->
726
				    let loc = (get_imported_node header k).top_decl_loc in 
727
				    raise (Error (loc, Declared_but_undefined k))) in
739
  Env.iter declared (fun k decl_type_k ->
740
    let loc = (get_imported_symbol header k).top_decl_loc in 
741
    let computed_t =
742
      instantiate (ref []) (ref []) 
743
	(try Env.lookup_value computed k
744
	 with Not_found -> raise (Error (loc, Declared_but_undefined k))) in
728 745
    (*Types.print_ty Format.std_formatter decl_type_k;
729
    Types.print_ty Format.std_formatter computed_t;*)
730
    try_unify ~sub:true ~semi:true decl_type_k computed_t Location.dummy_loc
731
		    )
746
      Types.print_ty Format.std_formatter computed_t;*)
747
    try_unify ~sub:true ~semi:true decl_type_k computed_t loc
748
  )
749

  
732 750
let check_typedef_top decl =
751
(*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*)
752
(*Printers.pp_var_type_dec_desc (typedef_of_top decl).tydef_id*)
753
(*Format.eprintf "%a" Corelang.print_type_table ();*)
733 754
  match decl.top_decl_desc with
734
  | Type ty ->
735
Format.eprintf "check_typedef %a %a@." Printers.pp_var_type_dec_desc ty.ty_def_desc Printers.pp_var_type_dec_desc (Hashtbl.find type_table (Tydec_const ty.ty_def_id));
736
    if coretype_equal ty.ty_def_desc (Hashtbl.find type_table (Tydec_const ty.ty_def_id)) then ()
737
    else raise (Error (decl.top_decl_loc, Type_mismatch ty.ty_def_id))
755
  | TypeDef ty ->
756
     let owner = decl.top_decl_owner in
757
     let itf = decl.top_decl_itf in
758
     let decl' =
759
       try Hashtbl.find type_table (Tydec_const (typedef_of_top decl).tydef_id)
760
       with Not_found -> raise (Error (decl.top_decl_loc, Declared_but_undefined ("type "^ ty.tydef_id))) in
761
     let owner' = decl'.top_decl_owner in
762
     let itf' = decl'.top_decl_itf in
763
     (match decl'.top_decl_desc with
764
     | Const _ | Node _ | ImportedNode _ -> assert false
765
     | TypeDef ty' when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf && (not itf') -> ()
766
     | _ -> raise (Error (decl.top_decl_loc, Type_mismatch ty.tydef_id)))
738 767
  | _  -> ()
739 768

  
740 769
let check_typedef_compat header =

Also available in: Unified diff