Revision d50b0dc0 src/typing.ml
src/typing.ml  

111  111 
 Tydec_struct fl > Type_predef.type_struct (List.map (fun (f, ty) > (f, type_coretype type_dim ty)) fl) 
112  112 
 Tydec_array (d, ty) > 
113  113 
begin 
114 
let d = Dimension.copy (ref []) d in 

114  115 
type_dim d; 
115  116 
Type_predef.type_array d (type_coretype type_dim ty) 
116  117 
end 
...  ...  
311  312 
then raise (Error (loc, Not_a_constant)) 
312  313  
313  314 
let rec type_add_const env const arg targ = 
315 
(*Format.eprintf "Typing.type_add_const %a %a@." Printers.pp_expr arg Types.print_ty targ;*) 

314  316 
if const 
315  317 
then let d = 
316  318 
if is_dimension_type targ 
...  ...  
357  359  
358  360 
(* type a call with possible dependent types. [targs] is here a list of (argument, type) pairs. *) 
359  361 
and type_dependent_call env in_main loc const f targs = 
362 
(*Format.eprintf "Typing.type_dependent_call %s@." f;*) 

360  363 
let tins, touts = new_var (), new_var () in 
361  364 
let tfun = Type_predef.type_arrow tins touts in 
362  365 
type_subtyping_arg env in_main const (expr_of_ident f loc) tfun; 
...  ...  
367  370 
begin 
368  371 
List.iter2 (fun (a,t) ti > 
369  372 
let t' = type_add_const env (const  Types.get_static_value ti <> None) a t 
370 
in try_unify ~sub:true ti t' a.expr_loc) targs tins; 

371 
touts 

373 
in try_unify ~sub:true ti t' a.expr_loc; 

374 
) targs tins; 

375 
(*Format.eprintf "Typing.type_dependent_call END@.";*) 

376 
touts; 

372  377 
end 
373  378  
374  379 
(* type a simple call without dependent types 
...  ...  
506  511  
507  512 
(** [type_eq env eq] types equation [eq] in environment [env] *) 
508  513 
let type_eq env in_main undefined_vars eq = 
514 
(*Format.eprintf "Typing.type_eq %a@." Printers.pp_node_eq eq;*) 

509  515 
(* Check undefined variables, type lhs *) 
510  516 
let expr_lhs = expr_of_expr_list eq.eq_loc (List.map (fun v > expr_of_ident v eq.eq_loc) eq.eq_lhs) in 
511  517 
let ty_lhs = type_expr env in_main false expr_lhs in 
512  518 
(* Check multiple variable definitions *) 
513  519 
let define_var id uvars = 
514 
try 

515 
ignore(IMap.find id uvars); 

516 
IMap.remove id uvars 

517 
with Not_found > 

518 
raise (Error (eq.eq_loc, Already_defined id)) 

520 
if ISet.mem id uvars 

521 
then ISet.remove id uvars 

522 
else raise (Error (eq.eq_loc, Already_defined id)) 

519  523 
in 
520  524 
(* check assignment of declared constant, assignment of clock *) 
521  525 
let ty_lhs = 
...  ...  
566  570 
 _ > () 
567  571  
568  572 
let type_var_decl vd_env env vdecl = 
573 
(*Format.eprintf "Typing.type_var_decl START %a:%a@." Printers.pp_var vdecl Printers.print_dec_ty vdecl.var_dec_type.ty_dec_desc;*) 

569  574 
check_type_declaration vdecl.var_loc vdecl.var_dec_type.ty_dec_desc; 
570  575 
let eval_const id = Types.get_static_value (Env.lookup_value env id) in 
571  576 
let type_dim d = 
572  577 
begin 
573  578 
type_subtyping_arg (env, vd_env) false true (expr_of_dimension d) Type_predef.type_int; 
579  
574  580 
Dimension.eval Basic_library.eval_env eval_const d; 
575  581 
end in 
576  582 
let ty = type_coretype type_dim vdecl.var_dec_type.ty_dec_desc in 
577 
let ty_status = 

583  
584 
let ty_static = 

578  585 
if vdecl.var_dec_const 
579 
then Type_predef.type_static (Dimension.mkdim_var ()) ty 

586 
then Type_predef.type_static (Dimension.mkdim_var ()) ty


580  587 
else ty in 
581 
let new_env = Env.add_value env vdecl.var_id ty_status in 

588 
(match vdecl.var_dec_value with 

589 
 None > () 

590 
 Some v > type_subtyping_arg (env, vd_env) false ~sub:false true v ty_static); 

591 
try_unify ty_static vdecl.var_type vdecl.var_loc; 

592 
let new_env = Env.add_value env vdecl.var_id ty_static in 

582  593 
type_coreclock (new_env,vd_env) vdecl.var_dec_clock vdecl.var_id vdecl.var_loc; 
583 
vdecl.var_type < ty_status;


594 
(*Format.eprintf "END %a@." Types.print_ty ty_static;*)


584  595 
new_env 
585  596  
586  597 
let type_var_decl_list vd_env env l = 
...  ...  
612  623 
let new_env = Env.overwrite env delta_env in 
613  624 
let undefined_vars_init = 
614  625 
List.fold_left 
615 
(fun uvs v > IMap.add v.var_id () uvs)


616 
IMap.empty vd_env_ol in


626 
(fun uvs v > ISet.add v.var_id uvs)


627 
ISet.empty vd_env_ol in


617  628 
let undefined_vars = 
618  629 
List.fold_left (type_eq (new_env, vd_env) is_main) undefined_vars_init (get_node_eqs nd) 
619  630 
in 
...  ...  
624  635 
) nd.node_asserts; 
625  636 

626  637 
(* check that table is empty *) 
627 
if (not (IMap.is_empty undefined_vars)) then 

638 
let local_consts = List.fold_left (fun res vdecl > if vdecl.var_dec_const then ISet.add vdecl.var_id res else res) ISet.empty nd.node_locals in 

639 
let undefined_vars = ISet.diff undefined_vars local_consts in 

640 
if (not (ISet.is_empty undefined_vars)) then 

628  641 
raise (Error (loc, Undefined_var undefined_vars)); 
629  642 
let ty_ins = type_of_vlist nd.node_inputs in 
630  643 
let ty_outs = type_of_vlist nd.node_outputs in 
...  ...  
671  684 
try 
672  685 
type_node env nd decl.top_decl_loc 
673  686 
with Error (loc, err) as exc > ( 
674 
if !Options.global_inline then 

687 
(*if !Options.global_inline then


675  688 
Format.eprintf "Type error: failing node@.%a@.@?" 
676  689 
Printers.pp_node nd 
677 
; 

690 
;*)


678  691 
raise exc) 
679  692 
) 
680  693 
 ImportedNode nd > 
...  ...  
745  758  
746  759 
let check_typedef_top decl = 
747  760 
(*Format.eprintf "check_typedef %a@." Printers.pp_short_decl decl;*) 
748 
(*Printers.pp_var_type_dec_desc (typedef_of_top decl).tydef_id*)


761 
(*Format.eprintf "%a" Printers.pp_typedef (typedef_of_top decl);*)


749  762 
(*Format.eprintf "%a" Corelang.print_type_table ();*) 
750  763 
match decl.top_decl_desc with 
751  764 
 TypeDef ty > 
...  ...  
755  768 
try Hashtbl.find type_table (Tydec_const (typedef_of_top decl).tydef_id) 
756  769 
with Not_found > raise (Error (decl.top_decl_loc, Declared_but_undefined ("type "^ ty.tydef_id))) in 
757  770 
let owner' = decl'.top_decl_owner in 
771 
(*Format.eprintf "def owner = %s@.decl owner = %s@." owner' owner;*) 

758  772 
let itf' = decl'.top_decl_itf in 
759  773 
(match decl'.top_decl_desc with 
760  774 
 Const _  Node _  ImportedNode _ > assert false 
Also available in: Unified diff