(** Time-stamp: <modified the 28/08/2008 (at 10:27) by Erwan Jahier> *)
open Lxm
open SyntaxTree
open SyntaxTreeCore
open Errors
open SyntaxTabUtils
let (doit:
(Ident.t, SyntaxTree.model_info Lxm.srcflagged) Hashtbl.t ->
(SyntaxTree.pack_info Lxm.srcflagged) ->
SyntaxTree.pack_given) =
fun mtab pdata -> (
match (pdata.it.pa_def) with
PackGiven pg -> pg
(* on garde tel-quel ... *)
| PackInstance pi -> (
(* recherche du mod�le *)
let mi = try Hashtbl.find mtab pi.pi_model
with Not_found ->
let msg = Printf.sprintf "bad pack instance: model %s undeclared"
(Ident.to_string pi.pi_model)
in
raise ( Compile_error (pdata.src, msg))
in
(*-----------INIT-----------------------------------*)
(* On part du packbody du mod�le, dont on duplique les tables :*)
let ctab = Hashtbl.copy mi.it.mo_body.pk_const_table in
let ttab = Hashtbl.copy mi.it.mo_body.pk_type_table in
let otab = Hashtbl.copy mi.it.mo_body.pk_node_table in
(* liste des nouveaux define ... *)
let newdefs = ref [] in
(* liste des nouveaux provides ... *)
let newprov = ref [] in
(* On met en correspondance les pi_args avec les mo_needs *)
let args = pi.pi_args in
let pars = mi.it.mo_needs in
(*--------------------------------------------------*)
(* la fonction qui traite un couple ... *)
let (check_arg : static_param srcflagged -> static_arg srcflagged -> unit) =
fun param arg ->
(* message d'erreur standard *)
let instance_error () =
let msg = Printf.sprintf
"bad argument in package instance: %s" (Lxm.details param.src)
in
raise (Compile_error (arg.src, msg))
in
(* on a soit un ident, � checker plus tard, soit une
expression de la bonne nature *)
match (param.it) with
| StaticParamType s -> (
let te = match (arg.it) with
StaticArgIdent idr ->
Lxm.flagit (Named_type_exp idr) arg.src
| StaticArgType x -> x
| _ -> instance_error ()
in
let ti = AliasedType (s, te) in
let x = Lxm.flagit (TypeInfo ti) param.src in
newprov := x::!newprov ;
let y = Lxm.flagit ti param.src in
put_in_tab "type" ttab s y ;
newdefs := (TypeItem s)::!newdefs
)
| StaticParamConst (s,te) -> (
let ce = match (arg.it) with
| StaticArgIdent idr ->
ParserUtils.leafexp arg.src (IDENT_n idr)
| StaticArgConst x -> x
| _ -> instance_error ()
in
let ci = DefinedConst (s, Some te, ce) in
let x = Lxm.flagit (ConstInfo ci) param.src in
newprov := x::!newprov ;
let y = Lxm.flagit ci param.src in
put_in_tab "const" ctab s y ;
newdefs := (ConstItem s)::!newdefs
)
| StaticParamNode (s, inl, outl, has_memory) -> (
let by_pos_op = match (arg.it) with
| StaticArgIdent idr ->
CALL_n(Lxm.flagit ((idr,[])) arg.src)
| StaticArgNode by_pos_op -> by_pos_op
| _ -> instance_error ()
in
let sparams = [] in
let ni = {
name = s;
static_params = sparams;
vars = Some (ParserUtils.build_node_var inl outl None);
def = Alias (flagit by_pos_op arg.src);
has_mem = has_memory;
is_safe = true;
}
in
let x = Lxm.flagit (NodeInfo ni) param.src in
newprov := x::!newprov ;
let y = Lxm.flagit ni param.src in
put_in_tab "node" otab s y ;
newdefs := (NodeItem (s,sparams))::!newdefs
)
(* check_arg *)
in
let (sargs_pack : Ident.pack_name srcflagged list) =
List.fold_left
(fun acc arg ->
(match arg.it with
| StaticArgIdent(idref) ->
(match Ident.pack_of_idref idref with
| None -> acc
| Some p ->
let p_flagged = Lxm.flagit p arg.src in
if List.mem p_flagged acc then acc else p_flagged::acc
)
| _ -> acc
)
)
[]
args
in
let pars_nb = string_of_int (List.length pars)
and args_nb = string_of_int (List.length args) in
try (
(*------------TRAITEMENT---------------------------------*)
if (pars_nb <> args_nb) then
raise(Compile_error
(pdata.src,
("\n*** " ^pars_nb ^
" arguments are expected, but "^args_nb^
" were provided when defining package "^
(Ident.pack_name_to_string pdata.it.pa_name)
)));
List.iter2 check_arg pars args;
(* on fabrique un pack_given valide avec les infos r�colt�es *)
let body = {
pk_const_table = ctab ;
pk_type_table = ttab ;
pk_node_table = otab ;
pk_def_list = List.append
(mi.it.mo_body.pk_def_list)
(List.rev !newdefs)
} in
(* les provides du mod�le + les nouveaux de newprov *)
(* SAUF SI ON EXPORTE DEJA TOUT ! *)
let prov = match (mi.it.mo_provides) with
Some l -> (
Some (List.append l (List.rev !newprov))
)
| None -> None
in
let pg = {
(* les uses du mod�le + les packages utilis�s par les arg statiques *)
pg_uses = mi.it.mo_uses @ sargs_pack;
pg_provides = prov ;
pg_body = body ;
} in
pg
) with Invalid_argument _ -> (
let msg = Printf.sprintf
"bad pack instance: %d args provided while model %s has %d params"
(List.length args)
(Ident.to_string pi.pi_model)
(List.length pars)
in
raise ( Compile_error (pdata.src, msg))
)
)
)