Project

General

Profile

Revision d50b0dc0 src/typing.ml

View differences:

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