Project

General

Profile

Revision 52cfee34 src/typing.ml

View differences:

src/typing.ml
284 284
    if List.map fst tl1 <> List.map fst tl2
285 285
    then raise (Unify (ty1, ty2))
286 286
    else List.iter2 (fun (_, t1) (_, t2) -> sub_unify sub t1 t2) tl1 tl2
287
  | Tclock t1          , Tclock t2          -> sub_unify sub t1 t2
288
  | Tclock t1          , _   when sub       -> sub_unify sub t1 ty2
287 289
  | Tstatic (d1, t1)   , Tstatic (d2, t2)   ->
288 290
    begin
289 291
      sub_unify sub t1 t2;
......
291 293
      Dimension.eval Basic_library.eval_env (fun c -> None) d2;
292 294
      Dimension.unify d1 d2
293 295
    end
294
  | Tstatic (r_d, t1)  , _         when sub -> sub_unify sub ty2 t1
295
  | _                                       -> unify ty2 ty1
296
  | Tstatic (r_d, t1)  , _         when sub -> sub_unify sub t1 ty2
297
  | _                                       -> unify ty1 ty2
296 298

  
297 299
let try_sub_unify sub ty1 ty2 loc =
298 300
  try
......
387 389
	 | Some d' -> try_unify real_type real_static_type loc);
388 390
	 real_static_type
389 391
    else real_type in
390
(*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*)
392
  (*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*)
391 393
  try_sub_unify sub real_type formal_type loc
392
(*
393
and type_subtyping_tuple loc real_type formal_type =
394
  let real_types   = type_list_of_type real_type in
395
  let formal_types = type_list_of_type formal_type in
396
  if (List.length real_types) <> (List.length formal_types)
397
  then raise (Unify (real_type, formal_type))
398
  else List.iter2 (type_subtyping loc sub) real_types formal_types
399

  
400
and type_subtyping loc sub real_type formal_type =
401
  match (repr real_type).tdesc, (repr formal_type).tdesc with
402
  | Tstatic _          , Tstatic _ when sub -> try_unify formal_type real_type loc
403
  | Tstatic (r_d, r_ty), _         when sub -> try_unify formal_type r_ty loc
404
  | _                                       -> try_unify formal_type real_type loc
405
*)
394

  
406 395
and type_ident env in_main loc const id =
407 396
  type_expr env in_main const (expr_of_ident id loc)
408 397

  
......
691 680
  nd.nodei_type <- ty_node;
692 681
  new_env
693 682

  
694
let type_imported_fun env nd loc =
695
  let new_env = type_var_decl_list nd.fun_inputs env nd.fun_inputs in
696
  let vd_env =  nd.fun_inputs@nd.fun_outputs in
697
  check_vd_env vd_env;
698
  ignore(type_var_decl_list vd_env new_env nd.fun_outputs);
699
  let ty_ins = type_of_vlist nd.fun_inputs in
700
  let ty_outs = type_of_vlist nd.fun_outputs in
701
  let ty_node = new_ty (Tarrow (ty_ins,ty_outs)) in
702
  generalize ty_node;
703
(*
704
  if (is_polymorphic ty_node) then
705
    raise (Error (loc, Poly_imported_node nd.fun_id));
706
*)
707
  let new_env = Env.add_value env nd.fun_id ty_node in
708
  nd.fun_type <- ty_node;
709
  new_env
710

  
711 683
let type_top_consts env clist =
712 684
  List.fold_left (fun env cdecl ->
713 685
    let ty = type_const cdecl.const_loc cdecl.const_value in
......
734 706
  )
735 707
  | ImportedNode nd ->
736 708
      type_imported_node env nd decl.top_decl_loc
737
  | ImportedFun nd ->
738
      type_imported_fun env nd decl.top_decl_loc
739 709
  | Consts clist ->
740 710
      type_top_consts env clist
741 711
  | Open _  -> env
......
769 739
      uneval_node_generics (nd.node_inputs @ nd.node_outputs)
770 740
  | ImportedNode nd ->
771 741
      uneval_node_generics (nd.nodei_inputs @ nd.nodei_outputs)
772
  | ImportedFun nd ->
773
      ()
774 742
  | Consts clist -> ()
775 743
  | Open _  -> ()
776 744

  

Also available in: Unified diff