Newer
Older
(** Time-stamp: <modified the 28/08/2008 (at 10:27) by Erwan Jahier> *)
Erwan Jahier
committed
open SyntaxTabUtils
Erwan Jahier
committed
let (doit:
(Ident.t, SyntaxTree.model_info Lxm.srcflagged) Hashtbl.t ->
Erwan Jahier
committed
SyntaxTree.pack_given) =
fun mtab pdata -> (
match (pdata.it.pa_def) with
Erwan Jahier
committed
| PackInstance pi -> (
(* recherche du modle *)
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 modle, 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
(*--------------------------------------------------*)
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
(* 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 rcoltes *)
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 modle + 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 modle + les packages utiliss 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))
)
)