Commit | Line | Data |
---|---|---|
34e49164 | 1 | (* |
faf9a90c | 2 | * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen |
34e49164 C |
3 | * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller |
4 | * This file is part of Coccinelle. | |
5 | * | |
6 | * Coccinelle is free software: you can redistribute it and/or modify | |
7 | * it under the terms of the GNU General Public License as published by | |
8 | * the Free Software Foundation, according to version 2 of the License. | |
9 | * | |
10 | * Coccinelle is distributed in the hope that it will be useful, | |
11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | * GNU General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU General Public License | |
16 | * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>. | |
17 | * | |
18 | * The authors reserve the right to distribute this or future versions of | |
19 | * Coccinelle under other licenses. | |
20 | *) | |
21 | ||
22 | ||
23 | (* For each rule return the list of variables that are used after it. | |
24 | Also augment various parts of each rule with unitary, inherited, and freshness | |
25 | informations *) | |
26 | ||
27 | module Ast = Ast_cocci | |
28 | module V = Visitor_ast | |
29 | module TC = Type_cocci | |
30 | ||
31 | let rec nub = function | |
32 | [] -> [] | |
33 | | (x::xs) when (List.mem x xs) -> nub xs | |
34 | | (x::xs) -> x::(nub xs) | |
35 | ||
36 | (* Collect all variable references in a minirule. For a disj, we collect | |
37 | the maximum number (2 is enough) of references in any branch. *) | |
38 | ||
39 | let collect_unitary_nonunitary free_usage = | |
40 | let free_usage = List.sort compare free_usage in | |
41 | let rec loop1 todrop = function (* skips multiple occurrences *) | |
42 | [] -> [] | |
43 | | (x::xs) as all -> if x = todrop then loop1 todrop xs else all in | |
44 | let rec loop2 = function | |
45 | [] -> ([],[]) | |
46 | | [x] -> ([x],[]) | |
47 | | x::y::xs -> | |
48 | if x = y (* occurs more than once in free_usage *) | |
49 | then | |
50 | let (unitary,non_unitary) = loop2(loop1 x xs) in | |
51 | (unitary,x::non_unitary) | |
52 | else (* occurs only once in free_usage *) | |
53 | let (unitary,non_unitary) = loop2 (y::xs) in | |
54 | (x::unitary,non_unitary) in | |
55 | loop2 free_usage | |
56 | ||
57 | let collect_refs include_constraints = | |
58 | let bind x y = x @ y in | |
59 | let option_default = [] in | |
60 | ||
61 | let donothing recursor k e = k e in (* just combine in the normal way *) | |
62 | ||
63 | let donothing_a recursor k e = (* anything is not wrapped *) | |
64 | k e in (* just combine in the normal way *) | |
65 | ||
66 | (* the following considers that anything that occurs non-unitarily in one | |
67 | branch occurs nonunitarily in all branches. This is not optimal, but | |
68 | doing better seems to require a breadth-first traversal, which is | |
69 | perhaps better to avoid. Also, unitarily is represented as occuring once, | |
70 | while nonunitarily is represented as twice - more is irrelevant *) | |
71 | (* cases for disjs and metavars *) | |
72 | let bind_disj refs_branches = | |
73 | let (unitary,nonunitary) = | |
74 | List.split (List.map collect_unitary_nonunitary refs_branches) in | |
75 | let unitary = nub (List.concat unitary) in | |
76 | let nonunitary = nub (List.concat nonunitary) in | |
77 | let unitary = | |
78 | List.filter (function x -> not (List.mem x nonunitary)) unitary in | |
79 | unitary@nonunitary@nonunitary in | |
80 | ||
81 | let metaid (x,_,_,_) = x in | |
82 | ||
83 | let astfvident recursor k i = | |
84 | bind (k i) | |
85 | (match Ast.unwrap i with | |
86 | Ast.MetaId(name,_,_,_) | Ast.MetaFunc(name,_,_,_) | |
87 | | Ast.MetaLocalFunc(name,_,_,_) -> [metaid name] | |
88 | | _ -> option_default) in | |
89 | ||
90 | let rec type_collect res = function | |
91 | TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty) | |
92 | | TC.Array(ty) -> type_collect res ty | |
93 | | TC.MetaType(tyname,_,_) -> bind [tyname] res | |
faf9a90c | 94 | | TC.SignedT(_,Some ty) -> type_collect res ty |
34e49164 C |
95 | | ty -> res in |
96 | ||
97 | let astfvexpr recursor k e = | |
98 | bind (k e) | |
99 | (match Ast.unwrap e with | |
100 | Ast.MetaExpr(name,_,_,Some type_list,_,_) -> | |
101 | let types = List.fold_left type_collect option_default type_list in | |
102 | bind [metaid name] types | |
103 | | Ast.MetaErr(name,_,_,_) | Ast.MetaExpr(name,_,_,_,_,_) -> [metaid name] | |
104 | | Ast.MetaExprList(name,None,_,_) -> [metaid name] | |
105 | | Ast.MetaExprList(name,Some (lenname,_,_),_,_) -> | |
106 | [metaid name;metaid lenname] | |
107 | | Ast.DisjExpr(exps) -> bind_disj (List.map k exps) | |
108 | | _ -> option_default) in | |
109 | ||
110 | let astfvdecls recursor k d = | |
111 | bind (k d) | |
112 | (match Ast.unwrap d with | |
113 | Ast.DisjDecl(decls) -> bind_disj (List.map k decls) | |
114 | | _ -> option_default) in | |
115 | ||
116 | let astfvfullType recursor k ty = | |
117 | bind (k ty) | |
118 | (match Ast.unwrap ty with | |
119 | Ast.DisjType(types) -> bind_disj (List.map k types) | |
120 | | _ -> option_default) in | |
121 | ||
122 | let astfvtypeC recursor k ty = | |
123 | bind (k ty) | |
124 | (match Ast.unwrap ty with | |
125 | Ast.MetaType(name,_,_) -> [metaid name] | |
126 | | _ -> option_default) in | |
127 | ||
113803cf C |
128 | let astfvinit recursor k ty = |
129 | bind (k ty) | |
130 | (match Ast.unwrap ty with | |
131 | Ast.MetaInit(name,_,_) -> [metaid name] | |
132 | | _ -> option_default) in | |
133 | ||
34e49164 C |
134 | let astfvparam recursor k p = |
135 | bind (k p) | |
136 | (match Ast.unwrap p with | |
137 | Ast.MetaParam(name,_,_) -> [metaid name] | |
138 | | Ast.MetaParamList(name,None,_,_) -> [metaid name] | |
139 | | Ast.MetaParamList(name,Some(lenname,_,_),_,_) -> | |
140 | [metaid name;metaid lenname] | |
141 | | _ -> option_default) in | |
142 | ||
143 | let astfvrule_elem recursor k re = | |
144 | (*within a rule_elem, pattern3 manages the coherence of the bindings*) | |
145 | bind (k re) | |
146 | (nub | |
147 | (match Ast.unwrap re with | |
148 | Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_) | |
149 | | Ast.MetaStmtList(name,_,_) -> [metaid name] | |
150 | | _ -> option_default)) in | |
151 | ||
152 | let astfvstatement recursor k s = | |
153 | bind (k s) | |
154 | (match Ast.unwrap s with | |
155 | Ast.Disj(stms) -> | |
156 | bind_disj (List.map recursor.V.combiner_statement_dots stms) | |
157 | | _ -> option_default) in | |
158 | ||
159 | let mcode r mc = | |
160 | if include_constraints | |
161 | then | |
162 | match Ast.get_pos_var mc with | |
163 | Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints | |
164 | | _ -> option_default | |
165 | else option_default in | |
166 | ||
167 | V.combiner bind option_default | |
168 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 | 169 | donothing donothing donothing donothing |
113803cf | 170 | astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam |
34e49164 C |
171 | astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a |
172 | ||
173 | let collect_all_refs = collect_refs true | |
174 | let collect_non_constraint_refs = collect_refs false | |
175 | ||
176 | let collect_all_rule_refs minirules = | |
177 | List.fold_left (@) [] | |
178 | (List.map collect_all_refs.V.combiner_top_level minirules) | |
179 | ||
180 | let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level | |
181 | ||
182 | (* ---------------------------------------------------------------- *) | |
183 | ||
184 | let collect_saved = | |
185 | let bind = Common.union_set in | |
186 | let option_default = [] in | |
187 | ||
188 | let donothing recursor k e = k e in (* just combine in the normal way *) | |
189 | ||
190 | let metaid (x,_,_,_) = x in | |
191 | ||
192 | (* cases for metavariables *) | |
193 | let astfvident recursor k i = | |
194 | bind (k i) | |
195 | (match Ast.unwrap i with | |
196 | Ast.MetaId(name,_,TC.Saved,_) | Ast.MetaFunc(name,_,TC.Saved,_) | |
197 | | Ast.MetaLocalFunc(name,_,TC.Saved,_) -> [metaid name] | |
198 | | _ -> option_default) in | |
199 | ||
200 | let rec type_collect res = function | |
201 | TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty) | |
202 | | TC.Array(ty) -> type_collect res ty | |
203 | | TC.MetaType(tyname,TC.Saved,_) -> bind [tyname] res | |
faf9a90c | 204 | | TC.SignedT(_,Some ty) -> type_collect res ty |
34e49164 C |
205 | | ty -> res in |
206 | ||
207 | let astfvexpr recursor k e = | |
208 | let tymetas = | |
209 | match Ast.unwrap e with | |
210 | Ast.MetaExpr(name,_,_,Some type_list,_,_) -> | |
211 | List.fold_left type_collect option_default type_list | |
212 | | _ -> [] in | |
213 | let vars = | |
214 | bind (k e) | |
215 | (match Ast.unwrap e with | |
216 | Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_) | |
217 | | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name] | |
218 | | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) -> | |
219 | let namesaved = | |
220 | match ns with TC.Saved -> [metaid name] | _ -> [] in | |
221 | let lensaved = | |
222 | match ls with TC.Saved -> [metaid lenname] | _ -> [] in | |
223 | lensaved @ namesaved | |
224 | | _ -> option_default) in | |
225 | bind tymetas vars in | |
226 | ||
227 | let astfvtypeC recursor k ty = | |
228 | bind (k ty) | |
229 | (match Ast.unwrap ty with | |
230 | Ast.MetaType(name,TC.Saved,_) -> [metaid name] | |
231 | | _ -> option_default) in | |
232 | ||
113803cf C |
233 | let astfvinit recursor k ty = |
234 | bind (k ty) | |
235 | (match Ast.unwrap ty with | |
236 | Ast.MetaInit(name,TC.Saved,_) -> [metaid name] | |
237 | | _ -> option_default) in | |
238 | ||
34e49164 C |
239 | let astfvparam recursor k p = |
240 | bind (k p) | |
241 | (match Ast.unwrap p with | |
242 | Ast.MetaParam(name,TC.Saved,_) | |
243 | | Ast.MetaParamList(name,None,_,_) -> [metaid name] | |
244 | | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) -> | |
245 | let namesaved = | |
246 | match ns with TC.Saved -> [metaid name] | _ -> [] in | |
247 | let lensaved = | |
248 | match ls with TC.Saved -> [metaid lenname] | _ -> [] in | |
249 | lensaved @ namesaved | |
250 | | _ -> option_default) in | |
251 | ||
252 | let astfvrule_elem recursor k re = | |
253 | (*within a rule_elem, pattern3 manages the coherence of the bindings*) | |
254 | bind (k re) | |
255 | (nub | |
256 | (match Ast.unwrap re with | |
257 | Ast.MetaRuleElem(name,TC.Saved,_) | Ast.MetaStmt(name,TC.Saved,_,_) | |
258 | | Ast.MetaStmtList(name,TC.Saved,_) -> [metaid name] | |
259 | | _ -> option_default)) in | |
260 | ||
261 | let mcode r e = | |
262 | match Ast.get_pos_var e with | |
263 | Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name] | |
264 | | _ -> option_default in | |
265 | ||
266 | V.combiner bind option_default | |
267 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 | 268 | donothing donothing donothing donothing |
113803cf | 269 | astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam |
34e49164 C |
270 | donothing astfvrule_elem donothing donothing donothing donothing |
271 | ||
272 | (* ---------------------------------------------------------------- *) | |
273 | ||
274 | (* For the rules under a given metavariable declaration, collect all of the | |
275 | variables that occur in the plus code *) | |
276 | ||
277 | let cip_mcodekind r mck = | |
278 | let process_anything_list_list anythings = | |
279 | let astfvs = collect_all_refs.V.combiner_anything in | |
280 | List.fold_left (@) [] | |
281 | (List.map (function l -> List.fold_left (@) [] (List.map astfvs l)) | |
282 | anythings) in | |
283 | match mck with | |
708f4980 | 284 | Ast.MINUS(_,_,_,anythings) -> process_anything_list_list anythings |
34e49164 C |
285 | | Ast.CONTEXT(_,befaft) -> |
286 | (match befaft with | |
287 | Ast.BEFORE(ll) -> process_anything_list_list ll | |
288 | | Ast.AFTER(ll) -> process_anything_list_list ll | |
289 | | Ast.BEFOREAFTER(llb,lla) -> | |
290 | (process_anything_list_list lla) @ | |
291 | (process_anything_list_list llb) | |
292 | | Ast.NOTHING -> []) | |
293 | | Ast.PLUS -> [] | |
294 | ||
295 | let collect_in_plus_term = | |
296 | let bind x y = x @ y in | |
297 | let option_default = [] in | |
298 | let donothing r k e = k e in | |
299 | ||
300 | (* no positions in the + code *) | |
301 | let mcode r (_,_,mck,_) = cip_mcodekind r mck in | |
302 | ||
303 | (* case for things with bef/aft mcode *) | |
304 | ||
305 | let astfvrule_elem recursor k re = | |
306 | match Ast.unwrap re with | |
307 | Ast.FunHeader(bef,_,fi,nm,_,params,_) -> | |
308 | let fi_metas = | |
309 | List.concat | |
310 | (List.map | |
311 | (function | |
312 | Ast.FType(ty) -> collect_all_refs.V.combiner_fullType ty | |
313 | | _ -> []) | |
314 | fi) in | |
315 | let nm_metas = collect_all_refs.V.combiner_ident nm in | |
316 | let param_metas = | |
317 | match Ast.unwrap params with | |
318 | Ast.DOTS(params) | Ast.CIRCLES(params) -> | |
319 | List.concat | |
320 | (List.map | |
321 | (function p -> | |
322 | match Ast.unwrap p with | |
323 | Ast.VoidParam(t) | Ast.Param(t,_) -> | |
324 | collect_all_refs.V.combiner_fullType t | |
325 | | _ -> []) | |
326 | params) | |
327 | | _ -> failwith "not allowed for params" in | |
328 | bind fi_metas | |
329 | (bind nm_metas | |
330 | (bind param_metas | |
331 | (bind (cip_mcodekind recursor bef) (k re)))) | |
332 | | Ast.Decl(bef,_,_) -> | |
333 | bind (cip_mcodekind recursor bef) (k re) | |
334 | | _ -> k re in | |
335 | ||
336 | let astfvstatement recursor k s = | |
337 | match Ast.unwrap s with | |
338 | Ast.IfThen(_,_,(_,_,_,aft)) | Ast.IfThenElse(_,_,_,_,(_,_,_,aft)) | |
339 | | Ast.While(_,_,(_,_,_,aft)) | Ast.For(_,_,(_,_,_,aft)) | |
340 | | Ast.Iterator(_,_,(_,_,_,aft)) -> | |
341 | bind (k s) (cip_mcodekind recursor aft) | |
342 | | _ -> k s in | |
343 | ||
344 | V.combiner bind option_default | |
345 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 C |
346 | donothing donothing donothing donothing |
347 | donothing donothing donothing donothing donothing donothing | |
348 | donothing astfvrule_elem astfvstatement donothing donothing donothing | |
349 | ||
350 | let collect_in_plus minirules = | |
351 | nub | |
352 | (List.concat | |
353 | (List.map collect_in_plus_term.V.combiner_top_level minirules)) | |
354 | ||
355 | (* ---------------------------------------------------------------- *) | |
356 | ||
357 | (* For the rules under a given metavariable declaration, collect all of the | |
358 | variables that occur only once and more than once in the minus code *) | |
359 | ||
360 | let collect_all_multirefs minirules = | |
361 | let refs = List.map collect_all_refs.V.combiner_top_level minirules in | |
362 | collect_unitary_nonunitary (List.concat refs) | |
363 | ||
364 | (* ---------------------------------------------------------------- *) | |
365 | ||
366 | (* classify as unitary (no binding) or nonunitary (env binding) or saved | |
367 | (witness binding) *) | |
368 | ||
369 | let classify_variables metavars minirules used_after = | |
370 | let metavars = List.map Ast.get_meta_name metavars in | |
371 | let (unitary,nonunitary) = collect_all_multirefs minirules in | |
372 | let inplus = collect_in_plus minirules in | |
faf9a90c | 373 | |
34e49164 C |
374 | let donothing r k e = k e in |
375 | let check_unitary name inherited = | |
376 | if List.mem name inplus or List.mem name used_after | |
377 | then TC.Saved | |
378 | else if not inherited && List.mem name unitary | |
379 | then TC.Unitary | |
380 | else TC.Nonunitary in | |
381 | ||
382 | let get_option f = function Some x -> Some (f x) | None -> None in | |
383 | ||
384 | let classify (name,_,_,_) = | |
385 | let inherited = not (List.mem name metavars) in | |
386 | (check_unitary name inherited,inherited) in | |
387 | ||
388 | let mcode mc = | |
389 | match Ast.get_pos_var mc with | |
390 | Ast.MetaPos(name,constraints,per,unitary,inherited) -> | |
391 | let (unitary,inherited) = classify name in | |
392 | Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited)) | |
393 | mc | |
394 | | _ -> mc in | |
395 | ||
396 | let ident r k e = | |
397 | let e = k e in | |
398 | match Ast.unwrap e with | |
399 | Ast.MetaId(name,constraints,_,_) -> | |
400 | let (unitary,inherited) = classify name in | |
401 | Ast.rewrap e (Ast.MetaId(name,constraints,unitary,inherited)) | |
402 | | Ast.MetaFunc(name,constraints,_,_) -> | |
403 | let (unitary,inherited) = classify name in | |
404 | Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited)) | |
405 | | Ast.MetaLocalFunc(name,constraints,_,_) -> | |
406 | let (unitary,inherited) = classify name in | |
407 | Ast.rewrap e (Ast.MetaLocalFunc(name,constraints,unitary,inherited)) | |
408 | | _ -> e in | |
409 | ||
410 | let rec type_infos = function | |
411 | TC.ConstVol(cv,ty) -> TC.ConstVol(cv,type_infos ty) | |
412 | | TC.Pointer(ty) -> TC.Pointer(type_infos ty) | |
413 | | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty) | |
414 | | TC.Array(ty) -> TC.Array(type_infos ty) | |
415 | | TC.MetaType(name,_,_) -> | |
416 | let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in | |
417 | Type_cocci.MetaType(name,unitary,inherited) | |
faf9a90c | 418 | | TC.SignedT(sgn,Some ty) -> TC.SignedT(sgn,Some (type_infos ty)) |
34e49164 C |
419 | | ty -> ty in |
420 | ||
421 | let expression r k e = | |
422 | let e = k e in | |
423 | match Ast.unwrap e with | |
424 | Ast.MetaErr(name,constraints,_,_) -> | |
425 | let (unitary,inherited) = classify name in | |
426 | Ast.rewrap e (Ast.MetaErr(name,constraints,unitary,inherited)) | |
427 | | Ast.MetaExpr(name,constraints,_,ty,form,_) -> | |
428 | let (unitary,inherited) = classify name in | |
429 | let ty = get_option (List.map type_infos) ty in | |
430 | Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited)) | |
431 | | Ast.MetaExprList(name,None,_,_) -> | |
432 | (* lenname should have the same properties of being unitary or | |
433 | inherited as name *) | |
434 | let (unitary,inherited) = classify name in | |
435 | Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited)) | |
436 | | Ast.MetaExprList(name,Some(lenname,_,_),_,_) -> | |
437 | (* lenname should have the same properties of being unitary or | |
438 | inherited as name *) | |
439 | let (unitary,inherited) = classify name in | |
440 | let (lenunitary,leninherited) = classify lenname in | |
441 | Ast.rewrap e | |
442 | (Ast.MetaExprList | |
443 | (name,Some(lenname,lenunitary,leninherited),unitary,inherited)) | |
444 | | _ -> e in | |
445 | ||
446 | let typeC r k e = | |
447 | let e = k e in | |
448 | match Ast.unwrap e with | |
449 | Ast.MetaType(name,_,_) -> | |
450 | let (unitary,inherited) = classify name in | |
451 | Ast.rewrap e (Ast.MetaType(name,unitary,inherited)) | |
452 | | _ -> e in | |
453 | ||
113803cf C |
454 | let init r k e = |
455 | let e = k e in | |
456 | match Ast.unwrap e with | |
457 | Ast.MetaInit(name,_,_) -> | |
458 | let (unitary,inherited) = classify name in | |
459 | Ast.rewrap e (Ast.MetaInit(name,unitary,inherited)) | |
460 | | _ -> e in | |
461 | ||
34e49164 C |
462 | let param r k e = |
463 | let e = k e in | |
464 | match Ast.unwrap e with | |
465 | Ast.MetaParam(name,_,_) -> | |
466 | let (unitary,inherited) = classify name in | |
467 | Ast.rewrap e (Ast.MetaParam(name,unitary,inherited)) | |
468 | | Ast.MetaParamList(name,None,_,_) -> | |
469 | let (unitary,inherited) = classify name in | |
470 | Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited)) | |
471 | | Ast.MetaParamList(name,Some (lenname,_,_),_,_) -> | |
472 | let (unitary,inherited) = classify name in | |
473 | let (lenunitary,leninherited) = classify lenname in | |
474 | Ast.rewrap e | |
475 | (Ast.MetaParamList | |
476 | (name,Some (lenname,lenunitary,leninherited),unitary,inherited)) | |
477 | | _ -> e in | |
478 | ||
479 | let rule_elem r k e = | |
480 | let e = k e in | |
481 | match Ast.unwrap e with | |
482 | Ast.MetaStmt(name,_,msi,_) -> | |
483 | let (unitary,inherited) = classify name in | |
484 | Ast.rewrap e (Ast.MetaStmt(name,unitary,msi,inherited)) | |
485 | | Ast.MetaStmtList(name,_,_) -> | |
486 | let (unitary,inherited) = classify name in | |
487 | Ast.rewrap e (Ast.MetaStmtList(name,unitary,inherited)) | |
488 | | _ -> e in | |
489 | ||
490 | let fn = V.rebuilder | |
491 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 | 492 | donothing donothing donothing donothing |
113803cf | 493 | ident expression donothing typeC init param donothing rule_elem |
34e49164 C |
494 | donothing donothing donothing donothing in |
495 | ||
496 | List.map fn.V.rebuilder_top_level minirules | |
497 | ||
498 | (* ---------------------------------------------------------------- *) | |
499 | ||
500 | (* For a minirule, collect the set of non-local (not in "bound") variables that | |
501 | are referenced. Store them in a hash table. *) | |
502 | ||
503 | (* bound means the metavariable was declared previously, not locally *) | |
504 | ||
505 | (* Highly inefficient, because we call collect_all_refs on nested code | |
506 | multiple times. But we get the advantage of not having too many variants | |
507 | of the same functions. *) | |
508 | ||
509 | (* Inherited doesn't include position constraints. If they are not bound | |
510 | then there is no constraint. *) | |
511 | ||
512 | let astfvs metavars bound = | |
513 | let fresh = | |
514 | List.fold_left | |
515 | (function prev -> | |
516 | function | |
b1b2de81 C |
517 | Ast.MetaFreshIdDecl(_,seed) as x -> |
518 | ((Ast.get_meta_name x),seed)::prev | |
34e49164 C |
519 | | _ -> prev) |
520 | [] metavars in | |
521 | ||
b1b2de81 C |
522 | let collect_fresh l = |
523 | List.rev | |
524 | (List.fold_left | |
525 | (function prev -> | |
526 | function x -> | |
527 | try let v = List.assoc x fresh in (x,v)::prev | |
528 | with Not_found -> prev) | |
529 | [] l) in | |
34e49164 C |
530 | |
531 | (* cases for the elements of anything *) | |
532 | let astfvrule_elem recursor k re = | |
533 | let minus_free = nub (collect_all_refs.V.combiner_rule_elem re) in | |
534 | let minus_nc_free = | |
535 | nub (collect_non_constraint_refs.V.combiner_rule_elem re) in | |
536 | let plus_free = collect_in_plus_term.V.combiner_rule_elem re in | |
537 | let free = Common.union_set minus_free plus_free in | |
538 | let nc_free = Common.union_set minus_nc_free plus_free in | |
539 | let unbound = | |
540 | List.filter (function x -> not(List.mem x bound)) free in | |
541 | let inherited = | |
542 | List.filter (function x -> List.mem x bound) nc_free in | |
543 | let munbound = | |
544 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
545 | {(k re) with | |
546 | Ast.free_vars = unbound; | |
547 | Ast.minus_free_vars = munbound; | |
548 | Ast.fresh_vars = collect_fresh unbound; | |
549 | Ast.inherited = inherited; | |
550 | Ast.saved_witness = []} in | |
551 | ||
552 | let astfvstatement recursor k s = | |
553 | let minus_free = nub (collect_all_refs.V.combiner_statement s) in | |
554 | let minus_nc_free = | |
555 | nub (collect_non_constraint_refs.V.combiner_statement s) in | |
556 | let plus_free = collect_in_plus_term.V.combiner_statement s in | |
557 | let free = Common.union_set minus_free plus_free in | |
558 | let nc_free = Common.union_set minus_nc_free plus_free in | |
559 | let classify free minus_free = | |
560 | let (unbound,inherited) = | |
561 | List.partition (function x -> not(List.mem x bound)) free in | |
562 | let munbound = | |
563 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
564 | (unbound,munbound,collect_fresh unbound,inherited) in | |
565 | let res = k s in | |
566 | let s = | |
567 | match Ast.unwrap res with | |
568 | Ast.IfThen(header,branch,(_,_,_,aft)) -> | |
569 | let (unbound,_,fresh,inherited) = | |
570 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
571 | Ast.IfThen(header,branch,(unbound,fresh,inherited,aft)) | |
572 | | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) -> | |
573 | let (unbound,_,fresh,inherited) = | |
574 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
575 | Ast.IfThenElse(header,branch1,els,branch2, | |
576 | (unbound,fresh,inherited,aft)) | |
577 | | Ast.While(header,body,(_,_,_,aft)) -> | |
578 | let (unbound,_,fresh,inherited) = | |
579 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
580 | Ast.While(header,body,(unbound,fresh,inherited,aft)) | |
581 | | Ast.For(header,body,(_,_,_,aft)) -> | |
582 | let (unbound,_,fresh,inherited) = | |
583 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
584 | Ast.For(header,body,(unbound,fresh,inherited,aft)) | |
585 | | Ast.Iterator(header,body,(_,_,_,aft)) -> | |
586 | let (unbound,_,fresh,inherited) = | |
587 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
588 | Ast.Iterator(header,body,(unbound,fresh,inherited,aft)) | |
589 | | s -> s in | |
faf9a90c | 590 | |
34e49164 C |
591 | let (unbound,munbound,fresh,_) = classify free minus_free in |
592 | let inherited = | |
593 | List.filter (function x -> List.mem x bound) nc_free in | |
594 | {res with | |
595 | Ast.node = s; | |
596 | Ast.free_vars = unbound; | |
597 | Ast.minus_free_vars = munbound; | |
598 | Ast.fresh_vars = collect_fresh unbound; | |
599 | Ast.inherited = inherited; | |
600 | Ast.saved_witness = []} in | |
601 | ||
602 | let astfvstatement_dots recursor k sd = | |
603 | let minus_free = nub (collect_all_refs.V.combiner_statement_dots sd) in | |
604 | let minus_nc_free = | |
605 | nub (collect_non_constraint_refs.V.combiner_statement_dots sd) in | |
606 | let plus_free = collect_in_plus_term.V.combiner_statement_dots sd in | |
607 | let free = Common.union_set minus_free plus_free in | |
608 | let nc_free = Common.union_set minus_nc_free plus_free in | |
609 | let unbound = | |
610 | List.filter (function x -> not(List.mem x bound)) free in | |
611 | let inherited = | |
612 | List.filter (function x -> List.mem x bound) nc_free in | |
613 | let munbound = | |
614 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
615 | {(k sd) with | |
616 | Ast.free_vars = unbound; | |
617 | Ast.minus_free_vars = munbound; | |
618 | Ast.fresh_vars = collect_fresh unbound; | |
619 | Ast.inherited = inherited; | |
620 | Ast.saved_witness = []} in | |
621 | ||
622 | let astfvtoplevel recursor k tl = | |
623 | let saved = collect_saved.V.combiner_top_level tl in | |
624 | {(k tl) with Ast.saved_witness = saved} in | |
625 | ||
626 | let mcode x = x in | |
627 | let donothing r k e = k e in | |
628 | ||
629 | V.rebuilder | |
630 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 C |
631 | donothing donothing astfvstatement_dots donothing |
632 | donothing donothing donothing donothing donothing donothing donothing | |
633 | astfvrule_elem astfvstatement donothing astfvtoplevel donothing | |
634 | ||
635 | (* | |
636 | let collect_astfvs rules = | |
637 | let rec loop bound = function | |
638 | [] -> [] | |
639 | | (metavars,(nm,rule_info,minirules))::rules -> | |
640 | let bound = | |
641 | Common.minus_set bound (List.map Ast.get_meta_name metavars) in | |
642 | (nm,rule_info, | |
643 | (List.map (astfvs metavars bound).V.rebuilder_top_level minirules)):: | |
644 | (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in | |
645 | loop [] rules | |
646 | *) | |
647 | ||
648 | let collect_astfvs rules = | |
649 | let rec loop bound = function | |
650 | [] -> [] | |
651 | | (metavars, rule)::rules -> | |
652 | match rule with | |
b1b2de81 C |
653 | Ast.ScriptRule (_,_,_,_) |
654 | | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) -> | |
34e49164 C |
655 | (* bound stays as is because script rules have no names, so no |
656 | inheritance is possible *) | |
657 | rule::(loop bound rules) | |
faf9a90c | 658 | | Ast.CocciRule (nm, rule_info, minirules, isexp, ruletype) -> |
34e49164 C |
659 | let bound = |
660 | Common.minus_set bound (List.map Ast.get_meta_name metavars) in | |
661 | (Ast.CocciRule | |
662 | (nm, rule_info, | |
663 | (List.map (astfvs metavars bound).V.rebuilder_top_level | |
664 | minirules), | |
faf9a90c | 665 | isexp, ruletype)):: |
34e49164 C |
666 | (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in |
667 | loop [] rules | |
668 | ||
669 | (* ---------------------------------------------------------------- *) | |
670 | (* position variables that appear as a constraint on another position variable. | |
671 | a position variable also cannot appear both positively and negatively in a | |
672 | single rule. *) | |
673 | ||
674 | let get_neg_pos_list (_,rule) used_after_list = | |
675 | let donothing r k e = k e in | |
676 | let bind (p1,np1) (p2,np2) = | |
677 | (Common.union_set p1 p2, Common.union_set np1 np2) in | |
678 | let option_default = ([],[]) in | |
679 | let metaid (x,_,_,_) = x in | |
680 | let mcode r mc = | |
681 | match Ast.get_pos_var mc with | |
682 | Ast.MetaPos(name,constraints,Ast.PER,_,_) -> | |
683 | ([metaid name],constraints) | |
684 | | Ast.MetaPos(name,constraints,Ast.ALL,_,_) -> | |
685 | ([],(metaid name)::constraints) | |
686 | | _ -> option_default in | |
687 | let v = | |
688 | V.combiner bind option_default | |
689 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
34e49164 C |
690 | donothing donothing donothing donothing |
691 | donothing donothing donothing donothing donothing donothing | |
692 | donothing donothing donothing donothing donothing donothing in | |
693 | match rule with | |
faf9a90c | 694 | Ast.CocciRule(_,_,minirules,_,_) -> |
34e49164 C |
695 | List.map |
696 | (function toplevel -> | |
697 | let (positions,neg_positions) = v.V.combiner_top_level toplevel in | |
698 | (if List.exists (function p -> List.mem p neg_positions) positions | |
699 | then | |
700 | failwith | |
701 | "a variable cannot be used both as a position and a constraint"); | |
702 | neg_positions) | |
703 | minirules | |
b1b2de81 C |
704 | | Ast.ScriptRule _ | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> |
705 | (*no negated positions*) [] | |
34e49164 C |
706 | |
707 | (* ---------------------------------------------------------------- *) | |
708 | ||
709 | (* collect used after lists, per minirule *) | |
710 | ||
711 | (* defined is a list of variables that were declared in a previous metavar | |
712 | declaration *) | |
713 | ||
714 | (* Top-level used after: For each rule collect the set of variables that | |
715 | are inherited, ie used but not defined. These are accumulated back to | |
716 | their point of definition. *) | |
717 | ||
718 | ||
719 | let collect_top_level_used_after metavar_rule_list = | |
720 | let (used_after,used_after_lists) = | |
721 | List.fold_right | |
722 | (function (metavar_list,r) -> | |
723 | function (used_after,used_after_lists) -> | |
724 | let locally_defined = List.map Ast.get_meta_name metavar_list in | |
725 | let continue_propagation = | |
726 | List.filter (function x -> not(List.mem x locally_defined)) | |
727 | used_after in | |
728 | let free_vars = | |
729 | match r with | |
730 | Ast.ScriptRule (_,_,mv,_) -> | |
731 | List.map (function (_,(r,v)) -> (r,v)) mv | |
b1b2de81 | 732 | | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) -> [] |
faf9a90c | 733 | | Ast.CocciRule (_,_,rule,_,_) -> |
34e49164 C |
734 | Common.union_set (nub (collect_all_rule_refs rule)) |
735 | (collect_in_plus rule) in | |
736 | let inherited = | |
737 | List.filter (function x -> not (List.mem x locally_defined)) | |
738 | free_vars in | |
739 | (Common.union_set inherited continue_propagation, | |
740 | used_after::used_after_lists)) | |
741 | metavar_rule_list ([],[]) in | |
742 | match used_after with | |
743 | [] -> used_after_lists | |
744 | | _ -> | |
745 | failwith | |
746 | (Printf.sprintf "collect_top_level_used_after: unbound variables %s" | |
747 | (String.concat " " (List.map (function (_,x) -> x) used_after))) | |
faf9a90c | 748 | |
34e49164 C |
749 | let collect_local_used_after metavars minirules used_after = |
750 | let locally_defined = List.map Ast.get_meta_name metavars in | |
751 | let rec loop defined = function | |
752 | [] -> (used_after,[],[]) | |
753 | | minirule::rest -> | |
754 | let free_vars = | |
755 | Common.union_set | |
756 | (nub (collect_all_minirule_refs minirule)) | |
757 | (collect_in_plus_term.V.combiner_top_level minirule) in | |
758 | let local_free_vars = | |
759 | List.filter (function x -> List.mem x locally_defined) free_vars in | |
760 | let new_defined = Common.union_set local_free_vars defined in | |
761 | let (mini_used_after,fvs_lists,mini_used_after_lists) = | |
762 | loop new_defined rest in | |
763 | let local_used = Common.union_set local_free_vars mini_used_after in | |
764 | let (new_used_after,new_list) = | |
765 | List.partition (function x -> List.mem x defined) mini_used_after in | |
766 | let new_used_after = Common.union_set local_used new_used_after in | |
767 | (new_used_after,free_vars::fvs_lists, | |
768 | new_list::mini_used_after_lists) in | |
769 | let (_,fvs_lists,used_after_lists) = loop [] minirules in | |
770 | (fvs_lists,used_after_lists) | |
771 | ||
772 | ||
773 | let collect_used_after metavar_rule_list = | |
774 | let used_after_lists = collect_top_level_used_after metavar_rule_list in | |
775 | List.map2 | |
776 | (function (metavars,r) -> | |
777 | function used_after -> | |
778 | match r with | |
b1b2de81 C |
779 | Ast.ScriptRule (_,_,_,_) |
780 | | Ast.InitialScriptRule (_,_) | Ast.FinalScriptRule (_,_) -> | |
781 | ([], [used_after]) | |
faf9a90c | 782 | | Ast.CocciRule (name, rule_info, minirules, _,_) -> |
34e49164 C |
783 | collect_local_used_after metavars minirules used_after |
784 | ) | |
785 | metavar_rule_list used_after_lists | |
786 | ||
787 | (* ---------------------------------------------------------------- *) | |
788 | (* entry point *) | |
789 | ||
790 | let free_vars rules = | |
791 | let metavars = List.map (function (mv,rule) -> mv) rules in | |
792 | let (fvs_lists,used_after_lists) = List.split (collect_used_after rules) in | |
793 | let neg_pos_lists = List.map2 get_neg_pos_list rules used_after_lists in | |
794 | let positions_list = (* for all rules, assume all positions are used after *) | |
795 | List.map | |
796 | (function (mv, r) -> | |
797 | match r with | |
b1b2de81 C |
798 | Ast.ScriptRule _ |
799 | | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> [] | |
faf9a90c | 800 | | Ast.CocciRule (_,_,rule,_,_) -> |
34e49164 C |
801 | let positions = |
802 | List.fold_left | |
803 | (function prev -> | |
804 | function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev) | |
805 | [] mv in | |
806 | List.map (function _ -> positions) rule) | |
807 | rules in | |
808 | let new_rules = | |
809 | List.map2 | |
810 | (function (mv,r) -> | |
811 | function ua -> | |
812 | match r with | |
b1b2de81 C |
813 | Ast.ScriptRule _ |
814 | | Ast.InitialScriptRule _ | Ast.FinalScriptRule _ -> r | |
faf9a90c | 815 | | Ast.CocciRule (nm, rule_info, r, is_exp,ruletype) -> |
34e49164 C |
816 | Ast.CocciRule |
817 | (nm, rule_info, classify_variables mv r (List.concat ua), | |
faf9a90c | 818 | is_exp,ruletype)) |
34e49164 C |
819 | rules used_after_lists in |
820 | let new_rules = collect_astfvs (List.combine metavars new_rules) in | |
faf9a90c C |
821 | (metavars,new_rules, |
822 | fvs_lists,neg_pos_lists,used_after_lists,positions_list) |