(** Time-stamp: <modified the 26/05/2009 (at 15:27) by Erwan Jahier> *)
open Lxm
open Predef
open SyntaxTree
open SyntaxTreeCore
open Eff
open Errors
open Ident
(******************************************************************************)
exception GetEffType_error of string
(* exported *)
let rec (typ:Eff.id_solver -> SyntaxTreeCore.type_exp -> Eff.type_) =
fun env texp ->
try (
match texp.it with
| Bool_type_exp -> Bool_type_eff
| Int_type_exp -> Int_type_eff
| Real_type_exp -> Real_type_eff
| Named_type_exp s -> env.id2type s texp.src
| Array_type_exp (elt_texp, szexp) ->
let elt_teff = typ env elt_texp in
try
let sz = EvalConst.eval_array_size env szexp in
Array_type_eff (elt_teff, sz)
with EvalConst.EvalArray_error msg -> raise(GetEffType_error msg)
)
with GetEffType_error msg ->
raise (Compile_error(texp.src, "can't eval type: "^msg))
let (add_pack_name : id_solver -> Lxm.t -> Ident.idref -> Ident.idref) =
fun id_solver lxm cc ->
try
match Ident.pack_of_idref cc with
| Some _ -> cc
| None ->
let id = Ident.of_idref cc in
let pn =
SymbolTab.find_pack_of_const id_solver.symbols id lxm
in
Ident.make_idref pn id
with _ -> cc (* raise en error? *)
(* exported *)
let rec (clock : Eff.id_solver -> SyntaxTreeCore.var_info -> Eff.id_clock)=
fun id_solver v ->
match v.var_clock with
| Base -> v.var_name, BaseEff
| NamedClock({ it=(cc,cv) ; src=lxm }) ->
let cc = add_pack_name id_solver lxm cc in
let vi = id_solver.id2var (Ident.to_idref cv) lxm in
let id, clk = vi.var_clock_eff in
v.var_name, On((cc,cv), clk)
(******************************************************************************)
(* Checks that the left part has the same type as the right one. *)
and (type_check_equation: Eff.id_solver -> Lxm.t -> Eff.left list ->
Eff.val_exp -> unit) =
fun id_solver lxm lpl_eff ve_eff ->
let lpl_teff = List.map Eff.type_of_left lpl_eff in
let ve_eff, right_part = EvalType.f id_solver ve_eff in
if (List.length lpl_teff <> List.length right_part) then
raise (Compile_error(lxm,
"tuple size error: \n*** the tuple size is\n***\t"^
(string_of_int (List.length lpl_teff)) ^
" for the left-hand-side, and \n***\t" ^
(string_of_int (List.length right_part)) ^
" for the right-hand-side (in " ^
(String.concat ","
(List.map LicDump.string_of_leff lpl_eff)) ^ " = " ^
(LicDump.string_of_val_exp_eff ve_eff) ^
")\n"
))
else
List.iter2
(fun le re ->
if le <> re then
let msg = "type mismatch: \n***\t'"
^ (LicDump.string_of_type_eff4msg le) ^
"' (left-hand-side) \n*** is not compatible with \n***\t'"
^ (LicDump.string_of_type_eff4msg re) ^ "' (right-hand-side)"
in
raise (Compile_error(lxm, msg))
)
lpl_teff
right_part
(* Checks that the left part has the same clock as the right one. *)
and (clock_check_equation:Eff.id_solver -> Lxm.t -> UnifyClock.subst ->
Eff.left list -> Eff.val_exp -> unit) =
fun id_solver lxm s lpl_eff ve_eff ->
let clk_list = List.map Eff.clock_of_left lpl_eff in
let _, right_part_clks, s = EvalClock.f lxm id_solver s ve_eff clk_list in
EvalClock.check_res lxm s lpl_eff right_part_clks
(******************************************************************************)
(* exported *)
let (dump_polymorphic_nodes : Eff.type_ -> unit) =
fun t ->
let nodes =
Polymorphism.unstack_polymorphic_nodes StructArrayExpand.node t
in
List.iter
(fun (id_solver,nenv,node) ->
let node =
if !Global.inline_iterator
then Inline.iterators nenv id_solver node
else node
in
let str = LicDump.node_of_node_exp_eff node in
output_string !Global.oc str
)
nodes;
Polymorphism.reset_type ()
(******************************************************************************)
let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
static_param srcflagged list) =
fun symbols lxm idref ->
try
match SymbolTab.find_node symbols (Ident.name_of_idref idref) lxm with
| SymbolTab.Local ni -> ni.it.static_params
| SymbolTab.Imported(imported_node, params) -> params
with _ ->
(* can occur for static node parameters, which cannot
themselves have static parameters. A better solution ougth
to be to add node static parameters in the SymbolTab.t
however (in Lazycompiler.node_check_do most probably). *)
[]
(* exported *)
let rec (node : Eff.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
Eff.node_exp) =
fun id_solver { src = lxm; it=(idref, static_args) } ->
let static_params = get_static_params_from_idref id_solver.symbols lxm idref in
let static_args_eff =
let sp_l = List.length static_params
and sa_l = List.length static_args in
if (sp_l <> sa_l) then
let msg = "Bad number of (static) arguments: " ^
(string_of_int sp_l) ^ " expected, and " ^
(string_of_int sa_l) ^ " provided."
in
raise (Compile_error(lxm, msg))
else
List.map2 (check_static_arg id_solver)
static_params
static_args
in
id_solver.id2node idref static_args_eff lxm
(** [check_static_arg this pn id sa (symbols, acc)] compile a static arg
into a static_arg
*)
and (check_static_arg : Eff.id_solver ->
SyntaxTreeCore.static_param srcflagged ->
SyntaxTreeCore.static_arg srcflagged ->
Eff.static_arg) =
fun node_id_solver sp sa ->
let rec (eff_type_and_type_exp_are_equal:
Eff.type_ -> SyntaxTreeCore.type_exp_core -> bool) =
fun teff texp ->
match teff, texp with
| Bool_type_eff, Bool_type_exp
| Real_type_eff, Real_type_exp
| Int_type_eff, Int_type_exp -> true
| Abstract_type_eff(l,_), Named_type_exp idref ->
l = Ident.long_of_idref idref
| External_type_eff(l), Named_type_exp idref ->
(* This seems a little bit wrong *)
l = Ident.long_of_idref idref
| _ , Named_type_exp idref -> true
| Array_type_eff(teff_ext,i),Array_type_exp(texp,j) ->
i=(EvalConst.eval_array_size node_id_solver j)
& (eff_type_and_type_exp_are_equal teff texp.it)
| Any,_ -> assert false (* for TTB, polymorphism is not supported *)
| Overload, _ -> assert false (* ditto *)
| Struct_type_eff(_),_ -> assert false (* impossible *)
| Enum_type_eff(_),_ -> assert false (* ditto *)
| _ -> false
in
let check_type_arg type_eff type_exp =
if not (eff_type_and_type_exp_are_equal type_eff type_exp.it) then
let msg = "Bad (static) type argument: '" ^
(LicDump.string_of_type_eff4msg type_eff) ^
"' and '" ^ (string_of_type_exp type_exp) ^ "' differs."
in
raise (Compile_error(type_exp.src, msg))
else ()
in
let type_check_var_info acc vi_eff vi_exp = acc &
eff_type_and_type_exp_are_equal vi_eff.var_type_eff vi_exp.it.var_type.it
in
let type_check_var_info_list vil_eff vil_exp =
List.fold_left2 type_check_var_info true vil_eff vil_exp
in
let check_node_arg neff vii vio =
let str = "Bad (static) node argument: " in
if (List.length neff.inlist_eff) <> (List.length vii) then
raise (Compile_error(sa.src, str ^ "arity error (inputs)."))
else if (List.length neff.outlist_eff) <> (List.length vio) then
raise (Compile_error(sa.src, str ^ "arity error (outputs)."))
else if not (type_check_var_info_list neff.inlist_eff vii) then
raise (Compile_error(sa.src, str ^ "wrong input type profile."))
else if not (type_check_var_info_list neff.outlist_eff vio) then
raise (Compile_error(sa.src, str ^ "wrong output type profile."))
else (neff.inlist_eff, neff.outlist_eff)
in
let sa_eff =
match sa.it, sp.it with
| StaticArgIdent idref, StaticParamConst(id, type_exp) ->
let ceff = node_id_solver.id2const idref sa.src in
let t_ceff = type_of_const ceff in
check_type_arg t_ceff type_exp;
ConstStaticArgEff (id, ceff)
| StaticArgIdent idref, StaticParamType(id) ->
let teff = node_id_solver.id2type idref sa.src in
TypeStaticArgEff (id, teff)
| StaticArgConst ce, StaticParamConst(id, type_exp) -> (
let ceff = EvalConst.f node_id_solver ce in
let t_ceff = type_of_const (List.hd ceff) in
check_type_arg t_ceff type_exp;
match ceff with
| [ceff] -> ConstStaticArgEff (id,ceff)
| _ -> assert false (* should not occur *)
)
| StaticArgType te, StaticParamType id ->
let teff = typ node_id_solver te in
TypeStaticArgEff (id, teff)
| StaticArgIdent idref, StaticParamNode(id, vii, vio,_) ->
(* idref is an alias, hence it cannot have static argument *)
let sargs = [] in
let neff = node_id_solver.id2node idref sargs sa.src in
let (inlist, outlist) = check_node_arg neff vii vio in
let neff = fst neff.node_key_eff in
NodeStaticArgEff (id, (neff, inlist, outlist))
| StaticArgNode(CALL_n ne), StaticParamNode(id,vii,vio,_) ->
let neff = node node_id_solver ne in
let (inlist, outlist) = check_node_arg neff vii vio in
let neff = fst neff.node_key_eff in
NodeStaticArgEff (id, (neff, inlist, outlist))
| StaticArgNode(Predef_n (op,sargs)), StaticParamNode(id,vii,vio,_) ->
let sargs_eff =
translate_predef_static_args node_id_solver sargs sa.src
in
let opeff = PredefEvalType.make_node_exp_eff None op sa.src sargs_eff in
let (inlist, outlist) = check_node_arg opeff vii vio in
let opeff = fst opeff.node_key_eff in
NodeStaticArgEff (id, (opeff, inlist, outlist))
| StaticArgNode(
(MERGE_n _|ARRAY_SLICE_n _|ARRAY_ACCES_n _|STRUCT_ACCESS_n _|IDENT_n _
|ARRAY_n|HAT_n|CONCAT_n|WITH_n(_)|TUPLE_n|WHEN_n(_)|CURRENT_n|FBY_n
|ARROW_n|PRE_n)), _ -> assert false
| StaticArgType _, StaticParamNode(id,_,_,_)
| StaticArgType _, StaticParamConst(id,_)
| StaticArgNode _, StaticParamType(id)
| StaticArgNode _, StaticParamConst(id,_)
| StaticArgConst _, StaticParamNode(id,_,_,_)
| StaticArgConst _, StaticParamType(id)
->
assert false (* can it occur actually? Let's wait it occurs...*)
in
sa_eff
(******************************************************************************)
(* exported *)
and (eq:Eff.id_solver -> SyntaxTreeCore.eq_info srcflagged -> Eff.eq_info srcflagged) =
fun id_solver eq_info ->
let (lpl, ve) = eq_info.it in
let lpl_eff = List.map (translate_left_part id_solver) lpl
and clk_subst,ve_eff = translate_val_exp id_solver UnifyClock.empty_subst ve
in
type_check_equation id_solver eq_info.src lpl_eff ve_eff;
clock_check_equation id_solver eq_info.src clk_subst lpl_eff ve_eff;
flagit (lpl_eff, ve_eff) eq_info.src
and (translate_left_part : id_solver -> SyntaxTreeCore.left_part -> Eff.left) =
fun id_solver lp_top ->
match lp_top with
| LeftVar id ->
let vi_eff =
id_solver.id2var (Ident.idref_of_string (Ident.to_string id.it)) id.src
in
LeftVarEff (vi_eff, id.src)
| LeftField (lp, id) -> (
let lp_eff = translate_left_part id_solver lp in
let teff = Eff.type_of_left lp_eff in
(* check that [lp_eff] is a struct that have a field named [id] *)
match teff with
| Struct_type_eff(_, fl) -> (
try let (teff_field,_) = List.assoc id.it fl in
LeftFieldEff(lp_eff, id.it, teff_field)
with Not_found ->
raise (Compile_error(id.src, "bad field name in structure"))
)
| _ -> raise (Compile_error(id.src, "a structure was expected"))
)
| LeftArray (lp, vef) -> (
let lp_eff = translate_left_part id_solver lp in
let teff = Eff.type_of_left lp_eff in
let lxm = vef.src in
match teff with
| Array_type_eff(teff_elt, size) ->
let index = EvalConst.eval_array_index id_solver vef.it lxm in
LeftArrayEff(lp_eff, index, teff_elt)
| _ -> raise (Compile_error(vef.src, "an array was expected"))
)
| LeftSlice (lp, sif) -> (
let lp_eff = translate_left_part id_solver lp in
let teff = Eff.type_of_left lp_eff in
match teff with
| Array_type_eff(teff_elt, size) ->
let sieff = translate_slice_info id_solver sif.it sif.src in
let size_slice = sieff.se_width in
let teff_slice = Array_type_eff(teff_elt, size_slice) in
LeftSliceEff(lp_eff, sieff, teff_slice)
| _ -> raise (Compile_error(sif.src, "an array was expected"))
)
and (translate_val_exp : Eff.id_solver -> UnifyClock.subst ->
SyntaxTreeCore.val_exp -> UnifyClock.subst * Eff.val_exp) =
fun id_solver s ve ->
let s, vef_core, lxm =
match ve with
| CallByName(by_name_op, field_list) ->
let s,fl = List.fold_left
(fun (s,fl) f ->
let s,f = translate_field id_solver s f in
s,f::fl
)
(s,[])
field_list
in
let fl = List.rev fl in
s,
(CallByNameEff(
flagit (translate_by_name_op id_solver by_name_op) by_name_op.src, fl)),
by_name_op.src
| CallByPos(by_pos_op, Oper vel) ->
let s, vel_eff =
List.fold_left
(fun (s,vel) ve ->
let s, ve = translate_val_exp id_solver s ve in
s,ve::vel
)
(s,[]) vel
in
let vel_eff = List.rev vel_eff in
let lxm = by_pos_op.src in
let by_pos_op = by_pos_op.it in
let mk_by_pos_op by_pos_op_eff =
CallByPosEff(flagit by_pos_op_eff lxm, OperEff vel_eff)
in
let s, vef_core =
match by_pos_op with
(* put that in another module ? yes, see above.*)
| Predef_n(Map, sargs)
| Predef_n(Fill, sargs)
| Predef_n(Red, sargs)
| Predef_n(FillRed, sargs)
| Predef_n(BoolRed, sargs) ->
(* We will make use of [vel_eff] to resolve the polymorphism *)
let vel_eff, type_ll =
List.split (List.map (EvalType.f id_solver) vel_eff)
in
let type_l : Eff.type_ list = List.flatten type_ll in
let sargs_eff = translate_predef_static_args id_solver sargs lxm in
let iter_op = match by_pos_op with
Predef_n(op,_) -> op | _ -> assert false
in
let iter_profile = match by_pos_op with
| Predef_n(Map,_) ->
PredefEvalType.map_profile lxm sargs_eff
| Predef_n(Fill,_) | Predef_n(Red,_) | Predef_n(FillRed,_) ->
PredefEvalType.fillred_profile lxm sargs_eff
| Predef_n(BoolRed,_) ->
PredefEvalType.boolred_profile lxm sargs_eff
| _ -> assert false
in
let type_l_exp = snd (List.split (fst iter_profile)) in
let sargs_eff =
if List.length type_l <> List.length type_l_exp then
raise (Compile_error(lxm, "the iterator has a wrong arity."))
else
match UnifyType.f type_l type_l_exp with
| UnifyType.Equal -> sargs_eff
| UnifyType.Unif typ ->
(* the iterated nodes was polymorphic, but we know here
that the type variable was [typ].
*)
dump_polymorphic_nodes typ;
List.map (instanciate_type typ) sargs_eff
| UnifyType.Ko str -> raise (Compile_error(lxm, str))
in
s, mk_by_pos_op (Eff.Predef(iter_op, sargs_eff))
(* other predef operators *)
| Predef_n(op, args) ->
assert (args=[]); s, mk_by_pos_op(Predef (op,[]))
| CALL_n node_exp_f ->
s, mk_by_pos_op(Eff.CALL (flagit (node id_solver node_exp_f)
node_exp_f.src))
| IDENT_n idref -> (
try
let s, const = UnifyClock.const_to_val_eff lxm false s
(id_solver.id2const idref lxm)
in
s, const.core
with _ -> (* In case idref is not a static constant. *)
match Ident.pack_of_idref idref with
| Some pn -> s, mk_by_pos_op(Eff.IDENT idref)
(** Constant with a pack name are treated as
Eff.IDENT. *)
| None ->
try
(* try to add its pack name... *)
let id = Ident.of_idref idref in
let pn =
SymbolTab.find_pack_of_const id_solver.symbols id lxm
in
let idref = Ident.make_idref pn id in
s, mk_by_pos_op(Eff.IDENT (idref))
with _ ->
s, mk_by_pos_op(Eff.IDENT idref)
)
| CURRENT_n -> s, mk_by_pos_op Eff.CURRENT
| PRE_n -> s, mk_by_pos_op Eff.PRE
| ARROW_n -> s, mk_by_pos_op Eff.ARROW
| FBY_n -> s, mk_by_pos_op Eff.FBY
| CONCAT_n -> s, mk_by_pos_op Eff.CONCAT
| TUPLE_n -> s, mk_by_pos_op Eff.TUPLE
| ARRAY_n ->
s, CallByPosEff(flagit (Eff.ARRAY vel_eff) lxm, OperEff [])
| WITH_n(c,e1,e2) ->
let c_eff = EvalConst.f id_solver c in
if c_eff = [ Bool_const_eff true ] then
let s, ve1 = translate_val_exp id_solver s e1 in
s, mk_by_pos_op (Eff.WITH (ve1))
else
let s, ve2 = translate_val_exp id_solver s e2 in
s, mk_by_pos_op (Eff.WITH (ve2))
| STRUCT_ACCESS_n fid ->
s, mk_by_pos_op (Eff.STRUCT_ACCESS (fid))
| WHEN_n Base -> s, mk_by_pos_op (Eff.WHEN Base)
| WHEN_n (NamedClock { it = (cc,cv) ; src = lxm }) ->
let cc = add_pack_name id_solver lxm cc in
s,
mk_by_pos_op (Eff.WHEN (NamedClock { it = (cc,cv) ; src = lxm }))
| ARRAY_ACCES_n ve_index ->
s, mk_by_pos_op (
Eff.ARRAY_ACCES(
EvalConst.eval_array_index id_solver ve_index lxm))
| ARRAY_SLICE_n si ->
s, mk_by_pos_op
(Eff.ARRAY_SLICE(
EvalConst.eval_array_slice id_solver si lxm))
| HAT_n -> (
match vel with
| [exp; ve_size] ->
let size_const_eff = EvalConst.f id_solver ve_size
and s, exp_eff = translate_val_exp id_solver s exp in
(match size_const_eff with
| [Int_const_eff size] ->
s, mk_by_pos_op (Eff.HAT(size, exp_eff))
| _ -> assert false)
| _ -> assert false
)
| MERGE_n(id, idl) -> s, mk_by_pos_op (Eff.MERGE(id, idl))
in
s, vef_core, lxm
in
let vef, tl = EvalType.f id_solver { core=vef_core; typ=[]; clk = [] } in
let vef, _, s = EvalClock.f lxm id_solver s vef [] in
s, vef
and translate_by_name_op id_solver op =
match op.it with
| STRUCT_anonymous_n -> STRUCT_anonymous
| STRUCT_n idref ->
match Ident.pack_of_idref idref with
| None ->
(* If no pack name is provided, we lookup it in the symbol table *)
let id = Ident.of_idref idref in
let pn = SymbolTab.find_pack_of_type id_solver.symbols id op.src in
STRUCT (pn, idref)
| Some pn -> STRUCT (pn, idref)
and translate_field id_solver s (id, ve) =
let s, ve = translate_val_exp id_solver s ve in
s, (id, ve)
(* XXX autre nom, autre module ?
ca fait partie de la definition des iterateurs d'une certaine maniere...
-> cr�er 2 modules, Iterator + IteratorSemantics
*)
and get_const id_solver const_or_const_ident lxm =
match const_or_const_ident with
| StaticArgConst(c) -> List.hd (EvalConst.f id_solver c)
| StaticArgIdent(id) -> id_solver.id2const id lxm
| StaticArgType _
| StaticArgNode _ -> raise (Compile_error(lxm, "a constant was expected"))
and get_node id_solver node_or_node_ident lxm =
match node_or_node_ident with
| StaticArgIdent(id) ->
let sargs = [] in (* it is an alias: no static arg *)
id_solver.id2node id sargs lxm
| StaticArgNode(CALL_n ne) -> node id_solver ne
| StaticArgNode(Predef_n (op,sargs)) ->
let sargs_eff = translate_predef_static_args id_solver sargs lxm in
PredefEvalType.make_node_exp_eff None op lxm sargs_eff
| StaticArgNode(_) -> assert false
| StaticArgType _
| StaticArgConst _ -> raise (Compile_error(lxm, "a node was expected"))
and (instanciate_type: Eff.type_ -> Eff.static_arg -> Eff.static_arg) =
fun t sarg ->
let make_long pstr idstr =
Ident.long_of_idref { id_pack = Some pstr ; id_id = idstr }
in
let instanciate_var_info vi =
{ vi with var_type_eff = Eff.subst_type t vi.var_type_eff }
in
match sarg with
| ConstStaticArgEff _ -> sarg
| TypeStaticArgEff _ -> sarg (* we cannot denote polymorphic type... *)
| NodeStaticArgEff(id,(node,il,ol)) ->
let node = match Ident.idref_of_long node with
| { id_pack = Some "Lustre" ; id_id = "times" } ->
let op = if t = Int_type_eff then "itimes" else "rtimes" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "slash" } ->
let op = if t = Int_type_eff then "islash" else "rslash" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "plus" } ->
let op = if t = Int_type_eff then "iplus" else "rplus" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "minus" } ->
let op = if t = Int_type_eff then "iminus" else "rminus" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "uminus" } ->
let op = if t = Int_type_eff then "iuminus" else "ruminus" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "div" } ->
let op = if t = Int_type_eff then "div" else "rdiv" in
make_long "Lustre" op
(* polymorphic op. what should be done for type different from
int and real?
*)
(* Lustre::ilt and co are not compiled yet. *)
(* | { id_pack = Some "Lustre" ; id_id = "lt" } -> *)
(* let op = if t = Int_type_eff then "ilt" *)
(* else if t = Real_type_eff then "rlt" else "lt" in *)
(* make_long "Lustre" op *)
(* | { id_pack = Some "Lustre" ; id_id = "gt" } -> *)
(* let op = if t = Int_type_eff then "igt" *)
(* else if t = Real_type_eff then "rgt" else "gt" in *)
(* make_long "Lustre" op *)
(* | { id_pack = Some "Lustre" ; id_id = "lte" } -> *)
(* let op = if t = Int_type_eff then "ilte" *)
(* else if t = Real_type_eff then "rlte" else "lte" in *)
(* make_long "Lustre" op *)
(* | { id_pack = Some "Lustre" ; id_id = "gte" } -> *)
(* let op = if t = Int_type_eff then "igte" *)
(* else if t = Real_type_eff then "rgte" else "gte" in *)
(* make_long "Lustre" op *)
| { id_pack = Some "Lustre" ; id_id = "equal" } ->
let op = if t = Int_type_eff then "iequal"
else if t = Real_type_eff then "requal"
else if t = Bool_type_eff then "bequal" else "equal" in
make_long "Lustre" op
| { id_pack = Some "Lustre" ; id_id = "diff" } ->
let op = if t = Int_type_eff then "idiff"
else if t = Real_type_eff then "rdiff"
else if t = Bool_type_eff then "bdiff" else "diff" in
make_long "Lustre" op
| _ -> node
in
let il = List.map instanciate_var_info il
and ol = List.map instanciate_var_info ol
in
NodeStaticArgEff(id,(node,il,ol))
(* exported *)
and (translate_predef_static_args: Eff.id_solver ->
SyntaxTreeCore.static_arg srcflagged list -> Lxm.t ->
Eff.static_arg list) =
fun id_solver sargs lxm ->
match sargs with
| [] -> []
| [{src=lxm_c1;it=c1}; {src=lxm_c2;it=c2}; {src=lxm_c3;it=c3}] ->
[
ConstStaticArgEff(Ident.of_string "min", get_const id_solver c1 lxm_c1);
ConstStaticArgEff(Ident.of_string "max", get_const id_solver c2 lxm_c2);
ConstStaticArgEff(Ident.of_string "size",get_const id_solver c3 lxm_c3)
]
| [{src=lxm_n;it=node}; {src=lxm_c;it=const}] ->
let node_eff = get_node id_solver node lxm_n in
(* There is two cases:
- node_eff is a simple node (no static arg). Then there
is nothing special todo. We use it to build the static arg.
- node_eff is a node with static arguments. We need to
unnest this. Therefore, we create on-the-fly an alias
pointing to this node_eff, compile it, and use the
result (which is then a simple node) as the current
node_eff. *)
let node_eff =
if snd node_eff.node_key_eff = [] then
node_eff
else
(*
- create a fresh node alias name (node_alias)
- build a fake node_info containing the alias definition
- add this entry in the SymbolTab (via id_solver.symbols)
- call id_solver.id2node on node_alias to compile this new node
*)
let node_alias_str = Name.node_key node_eff.node_key_eff "node_alias" in
let node_alias_idref = Ident.idref_of_string node_alias_str in
let node_alias_ident = Ident.of_string node_alias_str in
let by_pos_op =
match node with
| StaticArgNode(by_pos_op) -> by_pos_op
| StaticArgIdent(id) -> assert false
| StaticArgType _
| StaticArgConst _ ->
raise (Compile_error(lxm_n, "a node was expected"))
in
let node_alias_info =
{ src = lxm_n ;
it = {
name = node_alias_ident;
static_params = [] ;
vars = None;
def = Alias { src = lxm_n ; it = by_pos_op };
has_mem = node_eff.has_mem_eff;
is_safe = node_eff.is_safe_eff;
}
}
in
let _ =
SymbolTab.add_node id_solver.symbols node_alias_ident node_alias_info
in
id_solver.id2node node_alias_idref [] lxm_n
in
let node_arg =
fst node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff
in
[NodeStaticArgEff(Ident.of_string "node", node_arg);
ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
| _ ->
raise (Compile_error(lxm, "bad arguments number for array iterator"))
and (translate_slice_info : Eff.id_solver -> SyntaxTreeCore.slice_info ->
Lxm.t -> Eff.slice_info) =
fun id_solver si lxm ->
EvalConst.eval_array_slice id_solver si lxm
(**********************************************************************************)
(* exported *)
let (assertion : Eff.id_solver -> SyntaxTreeCore.val_exp Lxm.srcflagged ->
Eff.val_exp Lxm.srcflagged) =
fun id_solver vef ->
let s, val_exp_eff = translate_val_exp id_solver UnifyClock.empty_subst vef.it in
(* Check that the assert is a bool. *)
let val_exp_eff, evaled_exp = EvalType.f id_solver val_exp_eff in
List.iter
(fun ve ->
if ve <> Bool_type_eff then
let msg = "type mismatch: \n\tthe content of the assertion is of type "
^ (LicDump.string_of_type_eff4msg ve)
^ " whereas it shoud be a Boolean\n"
in
raise (Compile_error(vef.src, msg))
)
evaled_exp;
(* type is ok *)
(* Clock check the assertion*)
let _, clock_eff_list, _s =
EvalClock.f vef.src id_solver s val_exp_eff [BaseEff]
in
match clock_eff_list with
| [id, BaseEff]
| [id, On(_,BaseEff)]
| [id, ClockVar _] -> Lxm.flagit val_exp_eff vef.src
| [id, ce] ->
let msg = "clock error: assert should be on the base clock, "^
"but it is on "^ (LicDump.string_of_clock2 ce) ^ "\n"
in
raise (Compile_error(vef.src, msg))
| _ -> assert false
(******************************************************************************)