CristalCaveGem » LustreC

(* ty1 is a subtype of ty2 *)

(*

let rec sub_unify sub ty1 ty2 =

  match (repr ty1).tdesc, (repr ty2).tdesc with

  | Ttuple tl1         , Ttuple tl2         ->

    if List.length tl1 <> List.length tl2

    then raise (Unify (ty1, ty2))

    else List.iter2 (sub_unify sub) tl1 tl2

  | Ttuple [t1]        , _                  -> sub_unify sub t1 ty2

  | _                  , Ttuple [t2]        -> sub_unify sub ty1 t2

  | Tstruct tl1        , Tstruct tl2        ->

    if List.map fst tl1 <> List.map fst tl2

    then raise (Unify (ty1, ty2))

    else List.iter2 (fun (_, t1) (_, t2) -> sub_unify sub t1 t2) tl1 tl2

  | Tclock t1          , Tclock t2          -> sub_unify sub t1 t2

  | Tclock t1          , _   when sub       -> sub_unify sub t1 ty2

  | Tstatic (d1, t1)   , Tstatic (d2, t2)   ->

    begin

      sub_unify sub t1 t2;

      Dimension.eval Basic_library.eval_env (fun c -> None) d1;

      Dimension.eval Basic_library.eval_env (fun c -> None) d2;

      Dimension.unify d1 d2

    end

  | Tstatic (r_d, t1)  , _         when sub -> sub_unify sub t1 ty2

  | _                                       -> unify ty1 ty2

*)

let rec type_standard_args env in_main const expr_list =

  let ty_list =

    List.map

      (fun e -> let ty = dynamic_type (type_expr env in_main const e) in

		match get_clock_base_type ty with

		| None    -> ty

		| Some ty -> ty)

      expr_list in

  let ty_res = new_var () in

  List.iter2 (fun e ty -> try_unify ty_res ty e.expr_loc) expr_list ty_list;

  ty_res

  let real_type = type_expr env in_main const real_arg in

  let real_type =

    if const

    then let d =

	   if is_dimension_type real_type

	   then dimension_of_expr real_arg

	   else Dimension.mkdim_var () in

	 let eval_const id = Types.get_static_value (Env.lookup_value (fst env) id) in

	 Dimension.eval Basic_library.eval_env eval_const d;

	 let real_static_type = Type_predef.type_static d (Types.dynamic_type real_type) in

	 (match Types.get_static_value real_type with

	 | None    -> ()

	 | Some d' -> try_unify real_type real_static_type loc);

	 real_static_type

    else real_type in

  let args = expr_list_of_expr args in

  if Basic_library.is_internal_fun f && List.exists is_tuple_expr args

      let args = Utils.transpose_list (List.map expr_list_of_expr args) in

      Types.type_of_type_list (List.map (type_call env in_main loc const f) args)

    type_call env in_main loc const f args

(* type a (single) call. [args] is here a list of arguments. *)

and type_call env in_main loc const f args =

  if List.length args <> List.length tins then

    raise (Error (loc, WrongArity (List.length tins, List.length args)))

    List.iter2 (type_subtyping_arg env in_main const) args tins;

    let ty_elt = type_standard_args env in_main const elist in

    let ty_elt = type_standard_args env in_main const [e1] in

    let ty = type_standard_args env in_main const [t; e] in

    let touts = type_appl env in_main expr.expr_loc const id args in

    let ty = type_standard_args env in_main const [e1; e2] in

    let ty = type_standard_args env in_main const [e] in

    (*update_clock env in_main c expr.expr_loc typ_l;*)

    let ty = type_standard_args env in_main const [e1] in

    (*update_clock env in_main c expr.expr_loc typ_l;*)

(*

and update_clock env in_main id loc typ =

 (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "update_clock %s with %a@ " id print_ty typ);*)

 try

   let vdecl = List.find (fun v -> v.var_id = id) (snd env)

   in vdecl.var_type <- typ

 with

   Not_found ->

   raise (Error (loc, Unbound_value ("clock " ^ id)))

*)