(* Time-stamp: <modified the 21/07/2017 (at 15:02) by Erwan Jahier> *)
(* *)
open Lic
open Lv6errors
(* exported *)
let get_node_and_int_const (lxm: Lxm.t) (sargs: Lic.static_arg list)
: (Lic.node_key * int) =
match sargs with
| (NodeStaticArgLic (_,nk))::(ConstStaticArgLic carg)::_ -> (
let c = match carg with
| (_, Int_const_eff c) -> c
| (_, Abstract_const_eff(_,_,Int_const_eff c, true)) -> c
| (_, zcl) ->
let msg = "immediate integer expected, but get \""
^ (LicDump.string_of_const_eff false zcl)
^ "\"\n"
in raise (Compile_error(lxm, msg))
in
(nk, int_of_string c)
)
| _ ->
let msg = "*** an integer and a node are expected.\n" in
raise (Compile_error(lxm, msg))
(* transforme en array une variable *)
let var_to_array (c:int) (vi: Lic.var_info) : Lic.var_info =
{ vi with var_type_eff = Array_type_eff(vi.var_type_eff,c) }
(***
MESSAGES D'ERREUR :
Pour rester homogène, utiliser les fonctions de LicEvalType:
raise_type_error (provided: string) (expect: string) (msg: string)
raise_arity_error (msg:string) (provided:int) (expect:int)
*)
let raise_type_error = LicEvalType.raise_type_error
let raise_arity_error = LicEvalType.raise_arity_error
exception EvalType_error = LicEvalType.EvalType_error
(*
On a éventuellement besoin du node_exp des args
*)
let rec do_node
(nk2nd: Lic.node_key -> Lic.node_exp)
(nk: Lic.node_key)
(lxm: Lxm.t)
: (Lic.node_exp) =
let (pk,id) = fst nk in
match (pk, id) with
| ("Lustre", "map") -> do_map nk2nd nk lxm
| ("Lustre", "red")
| ("Lustre", "fill")
| ("Lustre", "fillred") -> do_fillred nk2nd nk lxm
| ("Lustre", "boolred") -> do_boolred nk2nd nk lxm
| ("Lustre", "condact") -> do_condact nk2nd nk lxm
| _ -> raise Not_found
(*--------------------------------------------------------------------
MAP
----------------------------------------------------------------------
Given :
- A node n of type: a_1 * ... * a_n -> b_1 * ... * b_k
- A (int) const c
Gen a node of type : a_1^c * ... * a_n^c -> b_1^c * ... * b_k^c
--------------------------------------------------------------------*)
and do_map nk2nd nk lxm =
let sargs = snd nk in
let (np, c) = get_node_and_int_const lxm sargs in
let nd = nk2nd np in
let ins = nd.inlist_eff in
let outs = nd.outlist_eff in
{
node_key_eff = nk;
inlist_eff = List.map (var_to_array c) ins;
outlist_eff = List.map (var_to_array c) outs;
loclist_eff = None;
def_eff = MetaOpLic;
has_mem_eff = nd.has_mem_eff;
is_safe_eff = nd.is_safe_eff;
lxm = lxm;
}
(*--------------------------------------------------------------------
FILLRED
----------------------------------------------------------------------
Given :
- A node : aa * a_1 * ... * a_n -> aa * b_1 * ... * b_k
- An int c
Gen a node : aa * a_1^c * ... * a_n^c -> aa * b_1^c * ... * b_k^c
--------------------------------------------------------------------*)
and do_fillred nk2nd nk lxm =
let sargs = snd nk in
let (np, c) = get_node_and_int_const lxm sargs in
let nd = nk2nd np in
let ins = nd.inlist_eff in
let outs = nd.outlist_eff in
let _ = assert (ins <> [] && outs <> []) in
let ins' = (List.hd ins)::(List.map (var_to_array c) (List.tl ins)) in
let outs' = (List.hd outs)::(List.map (var_to_array c) (List.tl outs)) in
(* pas d'unif : egalité et c'est tout ! *)
let t1 = (List.hd ins').var_type_eff in
let t2 = (List.hd outs').var_type_eff in
if t1 <> t2 then
let msg = Printf.sprintf
"node can't be used in iterator, first input type '%s' differs from first output type '%s'"
(LicDump.string_of_type_eff false t1)
(LicDump.string_of_type_eff false t2)
in
raise (Compile_error(lxm, msg))
else
{
node_key_eff = nk;
inlist_eff = ins';
outlist_eff = outs';
loclist_eff = None;
def_eff = MetaOpLic;
has_mem_eff = nd.has_mem_eff;
is_safe_eff = nd.is_safe_eff;
lxm = lxm;
}
(*--------------------------------------------------------------------
CONDACT
----------------------------------------------------------------------
Given :
- A node n of type: a_1 * ... * a_n -> b_1 * ... * b_k
- A (tuple) const: b_1 * ... * b_k
Gen a node of type : bool * a_1 * ... * a_n -> b_1 * ... * b_k
---------------------------------------------------------------------*)
(*
nb :
node condact_xx(c,i1,...,in) returns(res1,...,resk);
let
res1,...,resk = condact<<node,(dft_res1,...,dft_resk)>>(c,i1,...,in)
tel
could be translated into
node condact_xx(c,i1,...,in) returns(res1,...,resk);
let
res1,...,resk =
merge c (true -> node(i1,...,in))
(false -> (dft_res1,...,dft_resk) fby (res1,...,resk)
tel
is it a good idea?
*)
and (do_condact : (Lic.node_key -> Lic.node_exp) -> node_key -> Lxm.t -> Lic.node_exp) =
fun nk2nd nk lxm ->
try
let sargs = snd nk in
let np, dflt =
match sargs with
| [NodeStaticArgLic(_,np) ; ConstStaticArgLic(_,dflt)] -> np, dflt
| _ -> assert false
in
(* recherche le profil de np ... *)
let ne = nk2nd np in
let inlist = ne.inlist_eff in
let outlist = ne.outlist_eff in
(* dflt_types doit êre compatiple avec outlist *)
let dflt_types = types_of_const dflt in
let out_types = List.map (fun x -> x.var_type_eff) outlist in
let matches = try
UnifyType.is_matched out_types dflt_types
with UnifyType.Match_failed msg ->
raise (Compile_error(lxm, "in condact default output "^msg))
in
let out_types = Lic.apply_type_matches matches out_types in
let in_types = Lic.apply_type_matches matches
(Bool_type_eff::(List.map (fun x -> x.var_type_eff) inlist))
in
(* ok pour les args statiques, le profil dynamique est : *)
let clk = Lic.create_var AstCore.VarInput Bool_type_eff "activate" in
assert(in_types<>[]);
let ins = clk::
Lic.create_var_list AstCore.VarInput (List.tl in_types) in
let outs = Lic.create_var_list AstCore.VarOutput out_types in
{
node_key_eff = nk;
inlist_eff = ins;
outlist_eff = outs;
loclist_eff = None;
def_eff = MetaOpLic;
has_mem_eff = ne.has_mem_eff;
is_safe_eff = ne.is_safe_eff;
lxm = lxm;
}
with
| EvalType_error msg -> raise (Compile_error(lxm, "type error: "^msg))
(*--------------------------------------------------------------------
BOOLRED
----------------------------------------------------------------------
Given
- 3 integer constant i, j, k
returns the profile bool^k -> bool
---------------------------------------------------------------------*)
and do_boolred nk2nd nk lxm =
let sargs = snd nk in
let (i,j,k) = match sargs with
| [
ConstStaticArgLic(_,Int_const_eff i);
ConstStaticArgLic(_,Int_const_eff j);
ConstStaticArgLic(_,Int_const_eff k)
] -> i,j,k
| _ -> raise (Compile_error(lxm, "\n*** type error: 3 int were expected"))
in
let k = int_of_string k in
let ins = Lic.create_var AstCore.VarInput (Array_type_eff(Bool_type_eff,k)) "i1" in
let outs = Lic.create_var AstCore.VarOutput Bool_type_eff "out" in
{
node_key_eff = nk;
inlist_eff = [ins];
outlist_eff = [outs];
loclist_eff = None;
def_eff = MetaOpLic;
has_mem_eff = false;
is_safe_eff = true;
lxm = lxm;
}