-
Pascal Raymond authoredPascal Raymond authored
getEff.ml 34.51 KiB
(** Time-stamp: <modified the 01/06/2011 (at 13:38) by Erwan Jahier> *)
open Lxm
open Predef
open SyntaxTree
open SyntaxTreeCore
open Eff
open Errors
open Ident
(** debug flag: on prend le meme que LazyCompiler ... *)
let dbg = Verbose.get_flag "lazyc"
(******************************************************************************)
exception GetEffType_error of string
(* exported *)
let rec (of_type: 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 = of_type 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.global_symbols id lxm
in
Ident.make_idref pn id
with _ -> cc (* raise en error? *)
(* exported *)
let rec (of_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'"
^ (Eff.string_of_type le) ^
"' (left-hand-side) \n*** is not compatible with \n***\t'"
^ (Eff.string_of_type 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
(******************************************************************************)
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).
OUI MAIS GROS BUG : qu'est-ce-qui se passe si si le
'static node parameter' porte le meme nom qu'un noeud
existant dans SymbolTab ???
C'est clairement pas la bonne mthode ...
Voir + bas ...
*)
[]
(* exported *)
let rec (of_node : Eff.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
Eff.node_exp) =
fun id_solver { src = lxm; it=(idref, static_args) } ->
(* BUG des param statique node avec le meme nom
qu'un node template global :
pis-aller : si static_args = [],
on a peut-etre affaire un static param node, donc
on appelle directement id_solver.id2node et c'est lui
qui plantera si ce n'est pas le cas et qu'il fallait
des static_args... si static_args <> [], de toute maniere ca ne peut PAS
etre un static param node
*)
(*
TRAITER LES MACROS PREDEF :
- ici, on juste besoin de fabriquer les arguments statiques effectifs
partir des arguments donns et des args attendus.
- on cherche pas faire rentrer dans le moule, on dlgue
*)
let static_args_eff = match static_args with
| [] -> []
| _ ->
let static_params = get_static_params_from_idref id_solver.global_symbols lxm idref in
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
(node_id_solver: Eff.id_solver)
(sp: SyntaxTreeCore.static_param srcflagged)
(sa: SyntaxTreeCore.static_arg srcflagged)
: Eff.static_arg =
(
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)
| TypeVar Any,_ -> assert false (* for TTB, polymorphism is not supported *)
| TypeVar AnyNum , _ -> 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: '" ^
(Eff.string_of_type 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
(* sa = donn ; sp = attendu *)
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 = of_type 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
(* ICI a revoir ? *)
(* let (inlist, outlist) = check_node_arg neff vii vio in *)
let _ = check_node_arg neff vii vio in
NodeStaticArgEff (id, neff.node_key_eff)
| StaticArgNode(CALL_n ne), StaticParamNode(id,vii,vio,_) ->
let neff = of_node node_id_solver ne in
(* ICI a revoir ? *)
(* let (inlist, outlist) = check_node_arg neff vii vio in *)
let _ = check_node_arg neff vii vio in
NodeStaticArgEff (id, neff.node_key_eff)
| StaticArgNode(Predef_n (op,sargs)), StaticParamNode(id,vii,vio,_) ->
let sargs_eff =
translate_predef_static_args node_id_solver op.it sargs sa.src
in let opeff = PredefEvalType.make_node_exp_eff node_id_solver None op.it sa.src sargs_eff in
(* ICI a revoir ? *)
(* let (inlist, outlist) = check_node_arg opeff vii vio in *)
let _ = check_node_arg opeff vii vio in
NodeStaticArgEff (id, opeff.node_key_eff)
| 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 (of_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(op, sargs) -> (
(* 12/07 SOLUTION INTERMEDIAIRE
- les macros predefs ne sont plus traites ici
on les transforme en CALL standard
N.B. on garde pour l'instant la notion de
PREDEF_CALL pour les op simple, mais terme
a devrait disparaitre aussi ...
*)
(* OBSOLETE
try translate_predef_macro id_solver lxm op sargs (s, vel_eff)
with Not_found ->
assert (sargs=[]);
s, mk_by_pos_op(PREDEF_CALL (op,[]))
*)
match sargs with
| [] -> s, mk_by_pos_op(PREDEF_CALL (op.it,[]))
| _ -> (* on re-construit une SyntaxTreeCore.node_exp srcflagged
parce que c'est ca qu'attend of_node ...
*)
let node_exp_f = flagit (Predef.op_to_idref op.it, sargs) op.src in
let neff = of_node id_solver node_exp_f in
let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
Verbose.exe ~flag:dbg (fun () ->
Printf.fprintf stderr "#DBG: GetEff.translate_val_exp Predef_n '%!";
SyntaxTreeDump.print_node_exp stderr node_exp_f.it;
Printf.fprintf stderr " gives type: %s\n%!"
(Eff.string_of_type_profile (profile_of_node_exp neff))
) ;
(s, mk_by_pos_op ceff)
)
| CALL_n node_exp_f ->
let neff = of_node id_solver node_exp_f in
let ceff = Eff.CALL (flagit neff.node_key_eff node_exp_f.src) in
Verbose.exe ~flag:dbg (fun () ->
Printf.fprintf stderr "#DBG: GetEff.translate_val_exp CALL_n '%!";
SyntaxTreeDump.print_node_exp stderr node_exp_f.it;
Printf.fprintf stderr " gives type: %s\n%!"
(Eff.string_of_type_profile (profile_of_node_exp neff))
) ;
(s, mk_by_pos_op ceff)
| IDENT_n idref -> (
try
let var = id_solver.id2var idref lxm in
s, mk_by_pos_op(Eff.VAR_REF var.var_name_eff)
with _ ->
let s, const = UnifyClock.const_to_val_eff lxm false s
(id_solver.id2const idref lxm)
in
s, const.ve_core
)
(* OBSOLETE et un peu faux ?
| IDENT_n idref -> (
try
let s, const = UnifyClock.const_to_val_eff lxm false s
(id_solver.id2const idref lxm)
in
s, const.ve_core
with
| Unknown_constant _ -> (* In case idref is not a static constant. *) (
match Ident.pack_of_idref idref with
| Some pn -> s, mk_by_pos_op(Eff.CONST_REF 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.global_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 { ve_core=vef_core; ve_typ=[]; ve_clk = [] } in
let vef, _, s = EvalClock.f lxm id_solver s vef [] in
s, vef
(*
Un peu ad hoc :
- on traite part,
- on peut sans doute faire plus propre ?
--> raise Not_found
*)
and translate_predef_macro id_solver lxm zemacro sargs (s,vel_eff) =
(* ??? *)
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
(* Vrif lgre du profil statique : vrifie si le nombre et la nature
d'arg peut convenir *)
let sargs_eff = translate_predef_static_args id_solver zemacro.it sargs lxm in
(* Vrif complte du type, on utilise des fonctions ad hoc pour
chaque macro predef, (AFAIRE : pas trs beau ...)
N.B. le resultat est un Eff.node_profile = ins -> outs
o les in/out sont des ident * type_
*)
let iter_profile = match zemacro.it with | Map ->
PredefEvalType.map_profile id_solver lxm sargs_eff
| Fill | Red | FillRed ->
PredefEvalType.fillred_profile id_solver lxm sargs_eff
| BoolRed ->
PredefEvalType.boolred_profile id_solver lxm sargs_eff
| CondAct ->
PredefEvalType.condact_profile id_solver lxm sargs_eff
| _ -> raise Not_found
in
(* Filtre uniquement la liste des types d'entres attendus *)
let type_l_exp = snd (List.split (fst iter_profile)) in
(* Correction ventuelle des static args par le
"any(num)" ncssaire l'unification des
types d'entre AFAIRE : moche moche ...
*)
let sargs_eff =
if List.length type_l <> List.length type_l_exp then
let str = Printf.sprintf
"the iterator has a wrong arity: %s instead of %s"
(string_of_int (List.length type_l))
(string_of_int (List.length type_l_exp))
in
raise (Compile_error(lxm, str))
else
let tmatches = try UnifyType.is_matched type_l_exp type_l
with UnifyType.Match_failed msg -> raise (Compile_error(lxm, msg))
in
match tmatches with
| [] -> sargs_eff
| _ ->
(** ICI Est-ce qu'on garde la match ?
peut-tre qq chose faire mais
sans doute pas le 'instanciate_type' *)
sargs_eff
in
(*
match U nifyType.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 MISSING type variable was [typ].
*)
(* dump_polymorphic_nodes typ; *)
List.map (instanciate_type typ) sargs_eff
| UnifyType.Ko str -> raise (Compile_error(lxm, str))
*)
let mk_by_pos_op by_pos_op_eff =
CallByPosEff(flagit by_pos_op_eff lxm, OperEff vel_eff)
in s, mk_by_pos_op (Eff.PREDEF_CALL(zemacro.it, sargs_eff))
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.global_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 ?
node_of_static_arg : appel QUAND ON SAIT qu'un sarg doit etre un NODE
const_of_static_arg : appel QUAND ON SAIT qu'un sarg doit etre une CONST
-> sert pour les macros predefs
ca fait partie de la definition des iterateurs d'une certaine maniere...
-> crer 2 modules, Iterator + IteratorSemantics
*)
and const_of_static_arg id_solver const_or_const_ident lxm =
match const_or_const_ident with
| StaticArgConst(c) -> (
match EvalConst.f id_solver c with
| [x] -> x
| xl ->
(* EvalConst.f ne fabrique PAS de tuple, on le fait ici *)
Tuple_const_eff xl
)
| StaticArgIdent(id) -> id_solver.id2const id lxm
| StaticArgType _
| StaticArgNode _ -> raise (Compile_error(lxm, "a constant was expected"))
and node_of_static_arg 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) -> of_node id_solver ne
| StaticArgNode(Predef_n (op,sargs)) ->
let sargs_eff = translate_predef_static_args id_solver op.it sargs lxm in
PredefEvalType.make_node_exp_eff id_solver None op.it lxm sargs_eff
| StaticArgNode(_) -> assert false
| StaticArgType _
| StaticArgConst _ -> raise (Compile_error(lxm, "a node was expected"))
(** OBSOLETE
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, sargs),il,ol),neff) ->
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
let neff = {
neff with
node_key_eff = (node,sargs);
inlist_eff = il;
outlist_eff = ol;
}
in
NodeStaticArgEff(id,((node,sargs),il,ol),neff)
*)
(* exported *)
and translate_predef_static_args
(id_solver: Eff.id_solver)
(op: Predef.op)
(sargs: SyntaxTreeCore.static_arg srcflagged list)
(lxm: Lxm.t) : Eff.static_arg list =
match op with
| BoolRed -> (
(* expects 3 constants *)
match sargs with
| [c1; c2; c3] ->
[
ConstStaticArgEff(Ident.of_string "min", const_of_static_arg id_solver c1.it c1.src);
ConstStaticArgEff(Ident.of_string "max", const_of_static_arg id_solver c2.it c2.src);
ConstStaticArgEff(Ident.of_string "size",const_of_static_arg id_solver c3.it c3.src)
]
| _ -> raise (Compile_error(lxm, "bad arguments number for boolred iterator"))
)
| Map | Fill | Red | FillRed -> ( (* expects 1 node, 1 constant *)
match sargs with
| [n; s] ->
let node_eff = node_of_static_arg id_solver n.it n.src in
(* OBSO *)
(* let node_arg = node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff in *)
[
NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
ConstStaticArgEff(Ident.of_string "size", const_of_static_arg id_solver s.it s.src)
]
| _ -> raise (Compile_error(lxm, "bad arguments number for array iterator"))
)
| CondAct -> (
(* expects 1 node, 1 (tuple) constant *)
match sargs with
| [n; d] ->
(*
(match d.it with StaticArgConst ve ->
Printf.fprintf stdout "=== default =";
SyntaxTreeDump.print_val_exp stdout ve;
Printf.fprintf stdout "\n\n";
);
*)
let node_eff = node_of_static_arg id_solver n.it n.src in
(* let node_arg = node_eff.node_key_eff, node_eff.inlist_eff, node_eff.outlist_eff in *)
let dflt = const_of_static_arg id_solver d.it d.src in
[
NodeStaticArgEff(Ident.of_string "node", node_eff.node_key_eff);
ConstStaticArgEff(Ident.of_string "default", dflt)
]
| _ -> raise (Compile_error(lxm, "bad arguments number for condact macro"))
)
| _ -> (
(* expects 0 sargs ! *)
match sargs with
| [] -> []
| _ ->
raise (Compile_error(lxm, "bad arguments number for predef macro"))
)
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 (of_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 "
^ (Eff.string_of_type 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
(******************************************************************************)
(******************************************************************************)