(** Time-stamp: <modified the 23/07/2008 (at 15:36) by Erwan Jahier> *)
open Lxm
open Predef
open SyntaxTree
open SyntaxTreeCore
open CompiledData
open Errors
(******************************************************************************)
exception GetEffType_error of string
(* exported *)
let rec (typ:CompiledData.id_solver -> SyntaxTreeCore.type_exp ->
CompiledData.type_eff)=
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))
(* exported *)
let rec (clock : CompiledData.id_solver -> var_info -> CompiledData.clock_eff)=
fun id_solver v ->
match v.var_clock with
| Base -> On(v.var_name,BaseEff)
| NamedClock id ->
let id_v = id_solver.id2var (Ident.to_idref id.it) id.src in
On(v.var_name, id_v.var_clock_eff)
(******************************************************************************)
(* Checks that the left part has the same type as the right one. *)
and (type_check_equation: id_solver -> eq_info srcflagged -> left_eff list ->
val_exp_eff -> unit) =
fun id_solver eq_info lpl_eff ve_eff ->
let lpl_teff = List.map type_eff_of_left_eff lpl_eff in
let right_part = EvalType.f id_solver ve_eff in
if (List.length lpl_teff <> List.length right_part) then
raise (Compile_error(eq_info.src,
"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"))
else
List.iter2
(fun le re ->
if le <> re then
let msg = "type mismatch: \n***\t'"
^ (LicDump.string_of_type_eff le) ^
"' (left-hand-side) \n*** is not compatible with \n***\t'"
^ (LicDump.string_of_type_eff re) ^ "' (right-hand-side)"
in
raise (Compile_error(eq_info.src, msg))
)
lpl_teff
right_part
(* Checks that the left part has the same clock as the right one. *)
and (clock_check_equation:id_solver -> eq_info srcflagged -> left_eff list ->
val_exp_eff -> unit) =
fun id_solver eq_info lpl_eff ve_eff ->
let right_part,s = EvalClock.f id_solver UnifyClock.empty_subst ve_eff in
EvalClock.check_res eq_info.src s lpl_eff right_part
(******************************************************************************)
let (get_static_params_from_idref : SymbolTab.t -> Lxm.t -> Ident.idref ->
static_param srcflagged list) =
fun symbols lxm idref ->
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
(* exported *)
let rec (node : CompiledData.id_solver -> SyntaxTreeCore.node_exp srcflagged ->
CompiledData.node_exp_eff) =
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 =
assert(List.length static_params = List.length static_args);
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_eff
*)
and (check_static_arg : CompiledData.id_solver ->
SyntaxTreeCore.static_param srcflagged ->
SyntaxTreeCore.static_arg srcflagged ->
CompiledData.static_arg_eff) =
fun node_id_solver sp sa ->
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
ConstStaticArgEff (id, ceff)
| StaticArgIdent idref, StaticParamType(id) ->
let teff = node_id_solver.id2type idref sa.src in
TypeStaticArgEff (id, teff)
| StaticArgIdent idref, StaticParamNode(id,_,_,_) ->
let sargs = [] in
(* We suppose that static arg cannot themselves be
template calls (eg, f<<g<<3>>>> is forbidden)
*)
let neff = node_id_solver.id2node idref sargs sa.src in
NodeStaticArgEff (id, neff)
| StaticArgConst ce, StaticParamConst(id, _type_exp) -> (
let ceff = EvalConst.f node_id_solver ce in
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)
| StaticArgNode(CALL_n ne), StaticParamNode(id,_,_,_) ->
let neff = node node_id_solver ne in
NodeStaticArgEff (id, neff)
| StaticArgNode(Predef (op,sargs)), StaticParamNode(id,_,_,_) ->
let sargs_eff =
translate_predef_static_args node_id_solver sargs sa.src
in
let opeff = PredefEvalType.make_node_exp_eff op sa.src sargs_eff in
NodeStaticArgEff (id, opeff)
| 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 : id_solver -> eq_info srcflagged -> eq_info_eff 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 ve_eff = translate_val_exp id_solver ve
in
type_check_equation id_solver eq_info lpl_eff ve_eff;
clock_check_equation id_solver eq_info lpl_eff ve_eff;
flagit (lpl_eff, ve_eff) eq_info.src
and (translate_left_part : id_solver -> left_part -> left_eff) =
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 = CompiledData.type_eff_of_left_eff 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 = CompiledData.type_eff_of_left_eff 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 size 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 = CompiledData.type_eff_of_left_eff lp_eff in
match teff with
| Array_type_eff(teff_elt, size) ->
let sieff = translate_slice_info id_solver sif.it size 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 : id_solver -> val_exp -> val_exp_eff) =
fun id_solver ve ->
match ve with
| CallByName(by_name_op, field_list) ->
(CallByNameEff(
flagit (translate_by_name_op by_name_op.it) by_name_op.src,
List.map (translate_field id_solver) field_list))
| CallByPos(by_pos_op, Oper vel) ->
let vel_eff = List.map (translate_val_exp id_solver) vel in
let by_pos_op_eff = translate_by_pos_op id_solver by_pos_op vel in
CallByPosEff(flagit by_pos_op_eff by_pos_op.src, OperEff vel_eff)
and translate_by_name_op = function
| STRUCT_n idref -> STRUCT_eff idref
| STRUCT_anonymous_n -> STRUCT_anonymous_eff
and translate_field id_solver (id, ve) = (id, translate_val_exp id_solver 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 (* I should do something more clever here to support
imbricated use of iterators (e.g., "map<<map<<..." *)
id_solver.id2node id sargs lxm
| StaticArgNode(CALL_n ne) -> node id_solver ne
| StaticArgNode(Predef (op,sargs)) ->
let sargs_eff = translate_predef_static_args id_solver sargs lxm in
PredefEvalType.make_node_exp_eff op lxm sargs_eff
| StaticArgNode(_) -> assert false
| StaticArgType _
| StaticArgConst _ -> raise (Compile_error(lxm, "a node was expected"))
(* exported *)
and (translate_predef_static_args: id_solver -> static_arg srcflagged list ->
Lxm.t -> static_arg_eff 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
[NodeStaticArgEff(Ident.of_string "node", node_eff);
ConstStaticArgEff(Ident.of_string "size",get_const id_solver const lxm_c)]
| _ ->
raise (Compile_error(lxm, "bad arguments number for array iterator"))
and (translate_iteror: id_solver -> by_pos_op -> Lxm.t -> by_pos_op_eff) =
fun id_solver op lxm ->
match op with
| Predef(iter_op, sargs) ->
Predef_eff(iter_op, translate_predef_static_args id_solver sargs lxm)
| _ -> assert false
and (translate_by_pos_op : id_solver -> by_pos_op srcflagged -> val_exp list ->
by_pos_op_eff) =
fun id_solver {it=by_pos_op;src=lxm} args ->
match by_pos_op with
(* put that in another module ? yes, see above.*)
| Predef(Map, _)
| Predef(Fill, _)
| Predef(Red, _)
| Predef(FillRed, _)
| Predef(BoolRed, _) -> translate_iteror id_solver by_pos_op lxm
(* other predef operators *)
| Predef(op, args) -> assert (args=[]); Predef_eff (op,[])
| CALL_n node_exp_f ->
CALL_eff (flagit (node id_solver node_exp_f) node_exp_f.src)
| IDENT_n idref -> (
try
match Ident.pack_of_idref idref with
| Some pn -> IDENT_eff idref
(* Constant with a pack name are treated as
IDENT_eff. Indeed, I do not see any means to
know if idref denotes a constant or not, since
the SymbolTab tables are indexed by
Ident.t... Anyway, CONST_eff was introduced
precisely to handle idref constants with no pack
name, so handling idref with a pack name as
before should be ok (albeit being quite
inelegant). *)
| None ->
let id = Ident.of_idref idref in
let pn = fst (SymbolTab.find_const2 id_solver.symbols id lxm) in
CONST_eff (idref, pn)
with _ -> IDENT_eff idref
)
| IDENT_n idref -> IDENT_eff idref
| CURRENT_n -> CURRENT_eff
| PRE_n -> PRE_eff
| ARROW_n -> ARROW_eff
| FBY_n -> FBY_eff
| CONCAT_n -> CONCAT_eff
| TUPLE_n -> TUPLE_eff
| ARRAY_n -> ARRAY_eff
| WITH_n(c,e1,e2) ->
let c_eff = EvalConst.f id_solver c in
if c_eff = [ Bool_const_eff true ] then
WITH_eff (translate_val_exp id_solver e1)
else
WITH_eff (translate_val_exp id_solver e2)
| STRUCT_ACCESS_n id -> STRUCT_ACCESS_eff id
| WHEN_n ->
(match List.map (translate_val_exp id_solver) args with
| [_;CallByPosEff({it=IDENT_eff id; src=lxm}, _)] ->
let clk = try (id_solver.id2var id lxm) with _ -> assert false in
WHEN_eff clk
| [_;CallByPosEff
({it=Predef_eff(NOT_n,[])},
OperEff [CallByPosEff({src = lxm; it = IDENT_eff id}, _)])] ->
let clk = try (id_solver.id2var id lxm) with _ -> assert false in
WHENOT_eff clk
| _ ->
let msg = "syntax error: clock expr expected" in
raise (Compile_error(lxm, msg))
)
| ARRAY_ACCES_n ve_index ->
let teff =
assert (List.length args = 1);
EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
in
let size, teff_elt =
match teff with
| [Array_type_eff(teff_elt, size)] -> size, teff_elt
| _ ->
raise (Compile_error(
lxm, "\n*** Type error: '" ^
(LicDump.string_of_type_eff_list teff) ^
"' was expected to be an array"))
in
ARRAY_ACCES_eff(
EvalConst.eval_array_index id_solver ve_index size lxm,
teff_elt
)
| ARRAY_SLICE_n si ->
let teff =
assert (List.length args = 1);
EvalType.f id_solver (translate_val_exp id_solver (List.hd args))
in
let size, teff_elt =
match teff with
| [Array_type_eff(teff_elt, size)] -> size, teff_elt
| _ ->
raise (Compile_error(
lxm, "\n*** Type error: '" ^
(LicDump.string_of_type_eff_list teff) ^
"' was expected to be an array"))
in
ARRAY_SLICE_eff(EvalConst.eval_array_slice id_solver si size lxm,
teff_elt)
| HAT_n -> (
match args with
| [exp; ve_size] ->
let size_const_eff = EvalConst.f id_solver ve_size
and exp_eff = translate_val_exp id_solver exp in
(match size_const_eff with
| [Int_const_eff size] -> HAT_eff(size, exp_eff)
| _ -> assert false)
| _ -> assert false
)
| MERGE_n(id, idl) -> MERGE_eff(id, idl)
and (translate_slice_info : id_solver -> slice_info -> int -> Lxm.t ->
slice_info_eff) =
fun id_solver si size lxm ->
EvalConst.eval_array_slice id_solver si size lxm
(**********************************************************************************)
(* exported *)
let (assertion : CompiledData.id_solver -> SyntaxTreeCore.val_exp Lxm.srcflagged ->
CompiledData.val_exp_eff Lxm.srcflagged) =
fun id_solver vef ->
let val_exp_eff = translate_val_exp id_solver vef.it in
(* Check that the assert is a bool. *)
let 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_eff ve)
^ " whereas it shoud be a Boolean\n"
in
raise (Compile_error(vef.src, msg))
)
evaled_exp;
(* type is ok *)
Lxm.flagit val_exp_eff vef.src
(******************************************************************************)