(** Time-stamp: <modified the 29/08/2008 (at 10:21) by Erwan Jahier> *)
open Printf
open Lxm
open Errors
open SyntaxTree
open Eff
open SyntaxTreeCore
open Predef
open PredefEvalConst
open PredefEvalType
(*----------------------------------------------------
EvalArray_error :
- lev�e par les fonctions d�di�es aux tableaux
----------------------------------------------------*)
exception EvalArray_error of string
(*----------------------------------------------------
EvalConst_error :
- lev�e localement dans les sous-fonctions,
- capt�e dans EvalConst.f et tranform�e en Compile_error.
----------------------------------------------------*)
let finish_me msg = print_string ("\n\tXXX evalConst.ml:"^msg^" -> finish me!\n")
let not_evaluable_construct str =
raise (EvalConst_error(
Printf.sprintf "The construct %s is not allowed in static expression"
str))
(*----------------------------------------------------
Utilitaire :
extraire une tranche de tableau
N.B. first_ix last_ix step et width sont suppos�s
venir de eva et donc �tre corrects
N.B. Puisque correct, last_ix est inutile, mais bon ...
-----------------------------------------------------*)
let (make_slice_const :
Eff.const array -> Eff.type_ -> Eff.slice_info -> Eff.const list) =
fun ctab ctype slice ->
let get_res (ix : int) = Array.get ctab (slice.se_first + ix*slice.se_step) in
[Array_const_eff (Array.init slice.se_width get_res, ctype)]
(** Utilitaire : fabriquer si possible une constante tableau *)
let (make_array_const : Eff.const list array -> Eff.const) =
fun ops ->
let expected_type = ref None in
let treat_arg (op : Eff.const list) =
match op with
| [x] -> (
(* non tuple *)
let xtyp = Eff.type_of_const x in
match (!expected_type) with
| None -> expected_type := Some xtyp; x
| Some t -> (
if (t = xtyp) then x else
raise (EvalConst_error(
"type error in array, "^
(LicDump.string_of_type_eff xtyp)^
" mixed with " ^ LicDump.string_of_type_eff t
))
)
)
| _ -> (* tuple *)
raise (EvalConst_error("array of tuple not allowed"))
in
let res = Array.map treat_arg ops in
match (!expected_type) with
| None -> raise (EvalConst_error("empty array"))
| Some t -> Array_const_eff(res, t)
(** Utilitaire : fabriquer si possible une constante structure
N.B. Par construction on sait que nops n'a pas de doublons
*)
let make_struct_const
(teff : Eff.type_)
(arg_tab : (Ident.t, Lxm.t * Eff.const) Hashtbl.t) =
(
(* on verifie qu'on a bien un type struct *)
match teff with
Struct_type_eff (tnm, flst) -> (
(* on construit la liste dans le BON ordre *)
let make_eff_field ((fn: Ident.t),((ft:Eff.type_),(fv:Eff.const option))) = (
try (
(* on prend en priorit� dans arg_tab *)
match (Hashtbl.find arg_tab fn) with
(lxm, v) -> (
(* effet de bord : on vire la valeur de arg_tab *)
Hashtbl.remove arg_tab fn ;
let vt = Eff.type_of_const v in
if (vt = ft) then (fn, v) (*ok*)
else raise (Compile_error(
lxm ,
sprintf
"\n*** type error in struct %s, %s instead of %s"
(Ident.string_of_long tnm)
(LicDump.string_of_type_eff vt)
(LicDump.string_of_type_eff ft)
))
)
) with Not_found -> (
(* sinon la valeur par d�faut *)
match fv with
Some v -> (fn, v) (* ok : v correcte par construction *)
| None ->
raise (EvalConst_error(
sprintf
"bad struct expression, no value given for field %s"
(Ident.to_string fn)
))
)
) in
(* on mappe flst pour avoir la liste dans le bon ordre *)
let eff_fields = List.map make_eff_field flst in
(* si arg_tab n'est pas vide, erreur sur le premier *)
let raise_error (id : Ident.t) ((lxm : Lxm.t), (veff : Eff.const))
= raise(Compile_error(
lxm,
sprintf
"\n*** %s is not a field of struct %s"
(Ident.to_string id)
(LicDump.string_of_type_eff(teff))
))
in
Hashtbl.iter raise_error arg_tab ;
(* ok : tout s'est bien pass� ! *)
Struct_const_eff (eff_fields, teff)
)
| _ -> raise (EvalConst_error(
sprintf
"struct type expected instead of %s"
(LicDump.string_of_type_eff teff)
))
)
let l2ll l = if l = [] then [] else [l]
(*----------------------------------------------------
Evaluation r�cursive des expressions constantes
------------------------------------------------------
f :
- entr�es : Eff.id_solver et val_exp
- sortie : Eff.const list
- Effet de bord : Compile_error
R�le :
-> r�soud les r�f�rences aux idents
-> g�re les appels r�cursifs (�valuation des arguments)
----------------------------------------------------*)
let rec f
(env : Eff.id_solver)
(vexp : val_exp)
= (
(*-----------------------------------
fonction r�cursive principale
-> capte les nv
-> r�cup�re les EvalConst_error
-----------------------------------*)
let rec rec_eval_const (vexp : SyntaxTreeCore.val_exp) = (
match vexp with
| SyntaxTreeCore.CallByPos ({it=posop; src=lxm}, Oper args) -> (
try eval_by_pos_const posop lxm args
with
| EvalType_error msg ->
raise (Compile_error(lxm, "type error: "^msg))
| EvalConst_error msg ->
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
)
| SyntaxTreeCore.CallByName ({it=nmop; src=lxm}, nmargs ) -> (
try eval_by_name_const nmop lxm nmargs
with EvalConst_error msg ->
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
)
)
(*-----------------------------------
fonction r�cursive secondaire
eval. exp classique (by pos)
N.B. On distingue les op�rations
classiques (avec extention tableau
implicie) des autres. Ici, on traite
toutes les op�rations non classiques.
-----------------------------------*)
and eval_by_pos_const
(posop : by_pos_op) (* l'operateur *)
(lxm : Lxm.t) (* source de l'op�rateur *)
(args : val_exp list) (* arguments *)
= (
match (posop) with
(* capte les idents de constantes *)
IDENT_n id -> (
(* 2007-07 on interdit les externes *)
match (env.id2const id lxm) with
| Extern_const_eff(_,_, Some const_eff) -> [const_eff]
| Extern_const_eff(_,_,None) ->
raise (EvalConst_error(
sprintf "\n*** cannot access this abstract constant value"))
| x -> [ x ]
)
(* op�rateur lazzy *)
| WITH_n(a0,a1,a2) -> (
match (rec_eval_const a0) with
[ Bool_const_eff true] -> rec_eval_const a1
| [ Bool_const_eff false] -> rec_eval_const a2
| x -> type_error_const x "bool"
)
(* mettre � plat la liste des args *)
| TUPLE_n -> ( List.flatten (List.map rec_eval_const args))
(* les tableaux de tuples sont interdits *)
| HAT_n -> (
match args with
| [cexp; szexp] -> (
try
let sz = eval_array_size env szexp in
match rec_eval_const cexp with
| [cst] ->
let atab = Array.make sz cst in
[ Array_const_eff (atab, Eff.type_of_const cst) ]
| x ->
raise (EvalConst_error("array of tuple not allowed"))
with
EvalArray_error msg -> raise(EvalConst_error msg)
)
| _ -> raise(EvalConst_error
(sprintf "arity error: 2 expected instead of %d"
(List.length args)))
)
| CONCAT_n -> (
let ops = (List.map rec_eval_const args) in
match ops with
| [[Array_const_eff (v0, t0)];
[Array_const_eff (v1, t1)]] -> (
if(t0 = t1) then
[Array_const_eff (Array.append v0 v1, t0)]
else
raise(EvalConst_error(
sprintf
"\n*** type combination error, can't concat %s with %s"
(LicDump.string_of_type_eff(t0))
(LicDump.string_of_type_eff(t1))
))
)
| [_;_] ->
raise(EvalConst_error(
"type combination error, array type expected"))
| _ -> raise(EvalConst_error
(sprintf "arity error: 2 expected instead of %d"
(List.length ops)))
)
| ARRAY_n -> (
let ops = (List.map rec_eval_const args) in
[make_array_const (Array.of_list ops)]
)
| ARRAY_ACCES_n ix -> (
let effargs = List.flatten (List.map rec_eval_const args) in
match effargs with
| [Array_const_eff (elts, typelts)] -> (
try
let sz = Array.length elts in
let effix = eval_array_index env ix sz lxm in
[Array.get elts effix ]
with EvalArray_error msg -> raise(EvalConst_error msg)
)
| _ -> type_error_const effargs "some array"
)
| ARRAY_SLICE_n sl -> (
let (elts, typelts) =
match List.flatten (List.map rec_eval_const args) with
| [Array_const_eff (l, t)] -> (l, t)
| x -> type_error_const x "some array"
in
(* on en d�duit la taille du tableau *)
let sz = Array.length elts in
(* �value la slice *)
try
let sliceff = eval_array_slice env sl sz lxm in
make_slice_const elts typelts sliceff
with
EvalArray_error msg -> raise(EvalConst_error msg)
)
| STRUCT_ACCESS_n fid ->
let ceff_list = List.flatten (List.map rec_eval_const args) in
(match ceff_list with
| [Struct_const_eff (flst, typ)] -> (
try [(List.assoc fid flst)]
with Not_found ->
raise (EvalConst_error
(Printf.sprintf "%s is not a field of struct %s"
(Ident.to_string fid)
(LicDump.string_of_type_eff(typ))))
)
| [x] -> type_error_const [x] "struct type"
| x -> arity_error_const x "1"
)
| CALL_n _ -> not_evaluable_construct "node call"
| MERGE_n _ -> not_evaluable_construct "merge"
| WHEN_n -> not_evaluable_construct "when"
| FBY_n -> not_evaluable_construct "fby"
| ARROW_n -> not_evaluable_construct "->"
| CURRENT_n -> not_evaluable_construct "current"
| PRE_n -> not_evaluable_construct "pre"
| Predef_n(op,sargs)
->
if sargs = [] then
let effargs = (List.map rec_eval_const args) in
PredefEvalConst.f op lxm [] effargs
else
(* Well, it migth be possible after all... TODO *)
not_evaluable_construct (op2string op)
) (* FIN DE : eval_by_pos_const *)
(*-------------------------------------*)
(* Fonction r�cursive secondaire *)
(*-------------------------------------*)
(* -> Eval. d'une expression sp�ciale *)
(* "par nom" *)
(*-------------------------------------*)
and eval_by_name_const
(namop : by_name_op) (* l'operateur *)
(lxm : Lxm.t) (* source de l'op�rateur *)
(namargs : (Ident.t srcflagged * val_exp) list) (* arguments *)
= (
match namop with
| STRUCT_anonymous_n ->
finish_me "anonymous struct";
assert false
| STRUCT_n opid -> (
(* effet de bord : on tabule les param effectif *)
let arg_tab = Hashtbl.create 50 in
let treat_one_arg ((pid:Ident.t srcflagged), (pexp:val_exp)) =
if
(Hashtbl.mem arg_tab pid.it)
then
raise(EvalConst_error(
sprintf
"multiple definition of param %s in %s call"
(Ident.to_string pid.it)
(Ident.string_of_idref opid)))
else
let v = rec_eval_const pexp in
match v with
| [x] -> Hashtbl.add arg_tab pid.it (pid.src, x)
| _ ->
raise(
EvalConst_error(
sprintf
"unexpected tuple value for param %s in %s call"
(Ident.to_string pid.it)
(Ident.string_of_idref opid)
))
in
List.iter treat_one_arg namargs ;
(* pour l'instant, on ne traite que les constructions de struct *)
try let teff = env.id2type opid lxm in
[make_struct_const teff arg_tab]
with _ ->
raise(EvalConst_error(
sprintf "struct type expected instead of %s"
(Ident.string_of_idref opid)))
)
) (* FIN DE : eval_by_name_const *)
(*-------------------------------------*)
(* Corps de la fonction principale *)
(*-------------------------------------*)
in
rec_eval_const vexp
) (* fin de f *)
(*---------------------------------------------------------------------
eval_array_size
-----------------------------------------------------------------------
R�le : calcule une taille de tableau
Entr�es:
Sorties :
int (strictement positif)
Effets de bord :
EvalArray_error "bad array size, type int expected but get <t>" si t pas int
EvalArray_error "bad array size <n>" si n <= 0
----------------------------------------------------------------------*)
and (eval_array_size: Eff.id_solver -> val_exp -> int) =
fun id_solver szexp ->
match (f id_solver szexp) with
| [Int_const_eff sz] ->
if (sz > 0) then sz else
raise(EvalArray_error(sprintf "bad array size %d" sz))
| [x] ->
raise(EvalArray_error(sprintf "bad array size, int expected but get %s"
(LicDump.string_of_type_eff(Eff.type_of_const x))))
| _ ->
raise(EvalArray_error(sprintf "bad array size, int expected, not a tuple"))
(*---------------------------------------------------------------------
eval_array_index
-----------------------------------------------------------------------
R�le :
Entr�es :
id_solver, val_exp, taille du tableau
Sorties :
int (entre 0 et taille du tableau -1
Effets de bord :
EvalArray_error msg si pas bon
----------------------------------------------------------------------*)
and eval_array_index
(env : Eff.id_solver)
(ixexp : val_exp)
(sz : int)
(lxm : Lxm.t)
=
try
(
match (f env ixexp) with
| [Int_const_eff i]
| [Extern_const_eff(_,_, Some (Int_const_eff i))] -> check_int i sz
| [Extern_const_eff(id,_,None)] ->
raise(EvalArray_error("The extern const " ^ (Ident.string_of_long id) ^
" is abstract"))
| [Extern_const_eff(_,_, Some x)]
| [x] -> raise(EvalArray_error(sprintf
"bad array index, int expected but get %s"
(LicDump.string_of_type_eff(Eff.type_of_const x)))
)
| _ -> raise(EvalArray_error(
sprintf "bad array index, int expected but get a tuple"))
)
with
EvalArray_error msg ->
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
and check_int i sz =
if ((i >= 0) && (i < sz)) then i
else raise(EvalArray_error(
sprintf "array index %d out of bounds 0..%d" i (sz-1)))
(*---------------------------------------------------------------------
eval_array_slice
-----------------------------------------------------------------------
R�le :
Entr�es :
Eff.id_solver, slice_info, size du tableau,
lxm (source de l'op�ration slice pour warning)
Eff.Sor :
slice_info_eff, i.e.
(fisrt,last,step,width) tels que step <> 0 et
- si step > 0 alors 0<=first<=last<=sz
- si step < 0 alors 0<=last<=first<=sz
- 1<=width<=sz
Effets de bord :
EvalArray_error msg si pas bon
----------------------------------------------------------------------*)
and eval_array_slice (env : Eff.id_solver) (sl : slice_info) (sz : int) (lxm : Lxm.t) =
try
let first_ix = eval_array_index env sl.si_first sz lxm in
let last_ix = eval_array_index env sl.si_last sz lxm in
let step =
match sl.si_step with
| Some stepexp -> (
match (f env stepexp) with
| [Int_const_eff s] -> s (* ok *)
| [x] -> raise(EvalArray_error(
sprintf "bad array step, int expected but get %s"
(LicDump.string_of_type_eff (Eff.type_of_const x))))
| _ -> raise(EvalArray_error(
sprintf "bad array step, int expected but get a tuple"))
)
| None -> if (first_ix <= last_ix) then 1 else -1
in
if
(step = 0)
|| ((step > 0) && (first_ix > last_ix))
|| ((step < 0) && (first_ix < last_ix))
then
let msg = sprintf "bad array slice [%d..%d] step %d" first_ix last_ix step in
raise (EvalArray_error msg)
else
(* index relatif du dernier *)
let last_rel = abs (last_ix-first_ix) in
let abs_step = abs step in
(* le dernier est-il pris dans la tranche ? *)
if ((last_rel mod abs_step) <> 0) then
warning lxm (sprintf "last index out of slice [%d..%d step %d]"
first_ix last_ix step);
let width = 1 + last_rel/abs_step in
(* on force le dernier a �tre dans la tranche *)
let real_last_ix = first_ix + (width-1) * step in
(* (first_ix,last_ix,step,width) *)
{
se_first = first_ix;
se_last = real_last_ix;
se_step = step;
se_width = width
}
with
EvalArray_error msg ->
raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))