Commit | Line | Data |
---|---|---|
113803cf C |
1 | (* |
2 | * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen | |
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 | |
94 | | TC.SignedT(_,Some ty) -> type_collect res ty | |
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 | ||
128 | let astfvparam recursor k p = | |
129 | bind (k p) | |
130 | (match Ast.unwrap p with | |
131 | Ast.MetaParam(name,_,_) -> [metaid name] | |
132 | | Ast.MetaParamList(name,None,_,_) -> [metaid name] | |
133 | | Ast.MetaParamList(name,Some(lenname,_,_),_,_) -> | |
134 | [metaid name;metaid lenname] | |
135 | | _ -> option_default) in | |
136 | ||
137 | let astfvrule_elem recursor k re = | |
138 | (*within a rule_elem, pattern3 manages the coherence of the bindings*) | |
139 | bind (k re) | |
140 | (nub | |
141 | (match Ast.unwrap re with | |
142 | Ast.MetaRuleElem(name,_,_) | Ast.MetaStmt(name,_,_,_) | |
143 | | Ast.MetaStmtList(name,_,_) -> [metaid name] | |
144 | | _ -> option_default)) in | |
145 | ||
146 | let astfvstatement recursor k s = | |
147 | bind (k s) | |
148 | (match Ast.unwrap s with | |
149 | Ast.Disj(stms) -> | |
150 | bind_disj (List.map recursor.V.combiner_statement_dots stms) | |
151 | | _ -> option_default) in | |
152 | ||
153 | let mcode r mc = | |
154 | if include_constraints | |
155 | then | |
156 | match Ast.get_pos_var mc with | |
157 | Ast.MetaPos(name,constraints,_,_,_) -> (metaid name)::constraints | |
158 | | _ -> option_default | |
159 | else option_default in | |
160 | ||
161 | V.combiner bind option_default | |
162 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
163 | donothing donothing donothing donothing | |
164 | astfvident astfvexpr astfvfullType astfvtypeC donothing astfvparam | |
165 | astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a | |
166 | ||
167 | let collect_all_refs = collect_refs true | |
168 | let collect_non_constraint_refs = collect_refs false | |
169 | ||
170 | let collect_all_rule_refs minirules = | |
171 | List.fold_left (@) [] | |
172 | (List.map collect_all_refs.V.combiner_top_level minirules) | |
173 | ||
174 | let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level | |
175 | ||
176 | (* ---------------------------------------------------------------- *) | |
177 | ||
178 | let collect_saved = | |
179 | let bind = Common.union_set in | |
180 | let option_default = [] in | |
181 | ||
182 | let donothing recursor k e = k e in (* just combine in the normal way *) | |
183 | ||
184 | let metaid (x,_,_,_) = x in | |
185 | ||
186 | (* cases for metavariables *) | |
187 | let astfvident recursor k i = | |
188 | bind (k i) | |
189 | (match Ast.unwrap i with | |
190 | Ast.MetaId(name,_,TC.Saved,_) | Ast.MetaFunc(name,_,TC.Saved,_) | |
191 | | Ast.MetaLocalFunc(name,_,TC.Saved,_) -> [metaid name] | |
192 | | _ -> option_default) in | |
193 | ||
194 | let rec type_collect res = function | |
195 | TC.ConstVol(_,ty) | TC.Pointer(ty) | TC.FunctionPointer(ty) | |
196 | | TC.Array(ty) -> type_collect res ty | |
197 | | TC.MetaType(tyname,TC.Saved,_) -> bind [tyname] res | |
198 | | TC.SignedT(_,Some ty) -> type_collect res ty | |
199 | | ty -> res in | |
200 | ||
201 | let astfvexpr recursor k e = | |
202 | let tymetas = | |
203 | match Ast.unwrap e with | |
204 | Ast.MetaExpr(name,_,_,Some type_list,_,_) -> | |
205 | List.fold_left type_collect option_default type_list | |
206 | | _ -> [] in | |
207 | let vars = | |
208 | bind (k e) | |
209 | (match Ast.unwrap e with | |
210 | Ast.MetaErr(name,_,TC.Saved,_) | Ast.MetaExpr(name,_,TC.Saved,_,_,_) | |
211 | | Ast.MetaExprList(name,None,TC.Saved,_) -> [metaid name] | |
212 | | Ast.MetaExprList(name,Some (lenname,ls,_),ns,_) -> | |
213 | let namesaved = | |
214 | match ns with TC.Saved -> [metaid name] | _ -> [] in | |
215 | let lensaved = | |
216 | match ls with TC.Saved -> [metaid lenname] | _ -> [] in | |
217 | lensaved @ namesaved | |
218 | | _ -> option_default) in | |
219 | bind tymetas vars in | |
220 | ||
221 | let astfvtypeC recursor k ty = | |
222 | bind (k ty) | |
223 | (match Ast.unwrap ty with | |
224 | Ast.MetaType(name,TC.Saved,_) -> [metaid name] | |
225 | | _ -> option_default) in | |
226 | ||
227 | let astfvparam recursor k p = | |
228 | bind (k p) | |
229 | (match Ast.unwrap p with | |
230 | Ast.MetaParam(name,TC.Saved,_) | |
231 | | Ast.MetaParamList(name,None,_,_) -> [metaid name] | |
232 | | Ast.MetaParamList(name,Some (lenname,ls,_),ns,_) -> | |
233 | let namesaved = | |
234 | match ns with TC.Saved -> [metaid name] | _ -> [] in | |
235 | let lensaved = | |
236 | match ls with TC.Saved -> [metaid lenname] | _ -> [] in | |
237 | lensaved @ namesaved | |
238 | | _ -> option_default) in | |
239 | ||
240 | let astfvrule_elem recursor k re = | |
241 | (*within a rule_elem, pattern3 manages the coherence of the bindings*) | |
242 | bind (k re) | |
243 | (nub | |
244 | (match Ast.unwrap re with | |
245 | Ast.MetaRuleElem(name,TC.Saved,_) | Ast.MetaStmt(name,TC.Saved,_,_) | |
246 | | Ast.MetaStmtList(name,TC.Saved,_) -> [metaid name] | |
247 | | _ -> option_default)) in | |
248 | ||
249 | let mcode r e = | |
250 | match Ast.get_pos_var e with | |
251 | Ast.MetaPos(name,_,_,TC.Saved,_) -> [metaid name] | |
252 | | _ -> option_default in | |
253 | ||
254 | V.combiner bind option_default | |
255 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
256 | donothing donothing donothing donothing | |
257 | astfvident astfvexpr donothing astfvtypeC donothing astfvparam | |
258 | donothing astfvrule_elem donothing donothing donothing donothing | |
259 | ||
260 | (* ---------------------------------------------------------------- *) | |
261 | ||
262 | (* For the rules under a given metavariable declaration, collect all of the | |
263 | variables that occur in the plus code *) | |
264 | ||
265 | let cip_mcodekind r mck = | |
266 | let process_anything_list_list anythings = | |
267 | let astfvs = collect_all_refs.V.combiner_anything in | |
268 | List.fold_left (@) [] | |
269 | (List.map (function l -> List.fold_left (@) [] (List.map astfvs l)) | |
270 | anythings) in | |
271 | match mck with | |
272 | Ast.MINUS(_,anythings) -> process_anything_list_list anythings | |
273 | | Ast.CONTEXT(_,befaft) -> | |
274 | (match befaft with | |
275 | Ast.BEFORE(ll) -> process_anything_list_list ll | |
276 | | Ast.AFTER(ll) -> process_anything_list_list ll | |
277 | | Ast.BEFOREAFTER(llb,lla) -> | |
278 | (process_anything_list_list lla) @ | |
279 | (process_anything_list_list llb) | |
280 | | Ast.NOTHING -> []) | |
281 | | Ast.PLUS -> [] | |
282 | ||
283 | let collect_in_plus_term = | |
284 | let bind x y = x @ y in | |
285 | let option_default = [] in | |
286 | let donothing r k e = k e in | |
287 | ||
288 | (* no positions in the + code *) | |
289 | let mcode r (_,_,mck,_) = cip_mcodekind r mck in | |
290 | ||
291 | (* case for things with bef/aft mcode *) | |
292 | ||
293 | let astfvrule_elem recursor k re = | |
294 | match Ast.unwrap re with | |
295 | Ast.FunHeader(bef,_,fi,nm,_,params,_) -> | |
296 | let fi_metas = | |
297 | List.concat | |
298 | (List.map | |
299 | (function | |
300 | Ast.FType(ty) -> collect_all_refs.V.combiner_fullType ty | |
301 | | _ -> []) | |
302 | fi) in | |
303 | let nm_metas = collect_all_refs.V.combiner_ident nm in | |
304 | let param_metas = | |
305 | match Ast.unwrap params with | |
306 | Ast.DOTS(params) | Ast.CIRCLES(params) -> | |
307 | List.concat | |
308 | (List.map | |
309 | (function p -> | |
310 | match Ast.unwrap p with | |
311 | Ast.VoidParam(t) | Ast.Param(t,_) -> | |
312 | collect_all_refs.V.combiner_fullType t | |
313 | | _ -> []) | |
314 | params) | |
315 | | _ -> failwith "not allowed for params" in | |
316 | bind fi_metas | |
317 | (bind nm_metas | |
318 | (bind param_metas | |
319 | (bind (cip_mcodekind recursor bef) (k re)))) | |
320 | | Ast.Decl(bef,_,_) -> | |
321 | bind (cip_mcodekind recursor bef) (k re) | |
322 | | _ -> k re in | |
323 | ||
324 | let astfvstatement recursor k s = | |
325 | match Ast.unwrap s with | |
326 | Ast.IfThen(_,_,(_,_,_,aft)) | Ast.IfThenElse(_,_,_,_,(_,_,_,aft)) | |
327 | | Ast.While(_,_,(_,_,_,aft)) | Ast.For(_,_,(_,_,_,aft)) | |
328 | | Ast.Iterator(_,_,(_,_,_,aft)) -> | |
329 | bind (k s) (cip_mcodekind recursor aft) | |
330 | | _ -> k s in | |
331 | ||
332 | V.combiner bind option_default | |
333 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
334 | donothing donothing donothing donothing | |
335 | donothing donothing donothing donothing donothing donothing | |
336 | donothing astfvrule_elem astfvstatement donothing donothing donothing | |
337 | ||
338 | let collect_in_plus minirules = | |
339 | nub | |
340 | (List.concat | |
341 | (List.map collect_in_plus_term.V.combiner_top_level minirules)) | |
342 | ||
343 | (* ---------------------------------------------------------------- *) | |
344 | ||
345 | (* For the rules under a given metavariable declaration, collect all of the | |
346 | variables that occur only once and more than once in the minus code *) | |
347 | ||
348 | let collect_all_multirefs minirules = | |
349 | let refs = List.map collect_all_refs.V.combiner_top_level minirules in | |
350 | collect_unitary_nonunitary (List.concat refs) | |
351 | ||
352 | (* ---------------------------------------------------------------- *) | |
353 | ||
354 | (* classify as unitary (no binding) or nonunitary (env binding) or saved | |
355 | (witness binding) *) | |
356 | ||
357 | let classify_variables metavars minirules used_after = | |
358 | let metavars = List.map Ast.get_meta_name metavars in | |
359 | let (unitary,nonunitary) = collect_all_multirefs minirules in | |
360 | let inplus = collect_in_plus minirules in | |
361 | ||
362 | let donothing r k e = k e in | |
363 | let check_unitary name inherited = | |
364 | if List.mem name inplus or List.mem name used_after | |
365 | then TC.Saved | |
366 | else if not inherited && List.mem name unitary | |
367 | then TC.Unitary | |
368 | else TC.Nonunitary in | |
369 | ||
370 | let get_option f = function Some x -> Some (f x) | None -> None in | |
371 | ||
372 | let classify (name,_,_,_) = | |
373 | let inherited = not (List.mem name metavars) in | |
374 | (check_unitary name inherited,inherited) in | |
375 | ||
376 | let mcode mc = | |
377 | match Ast.get_pos_var mc with | |
378 | Ast.MetaPos(name,constraints,per,unitary,inherited) -> | |
379 | let (unitary,inherited) = classify name in | |
380 | Ast.set_pos_var (Ast.MetaPos(name,constraints,per,unitary,inherited)) | |
381 | mc | |
382 | | _ -> mc in | |
383 | ||
384 | let ident r k e = | |
385 | let e = k e in | |
386 | match Ast.unwrap e with | |
387 | Ast.MetaId(name,constraints,_,_) -> | |
388 | let (unitary,inherited) = classify name in | |
389 | Ast.rewrap e (Ast.MetaId(name,constraints,unitary,inherited)) | |
390 | | Ast.MetaFunc(name,constraints,_,_) -> | |
391 | let (unitary,inherited) = classify name in | |
392 | Ast.rewrap e (Ast.MetaFunc(name,constraints,unitary,inherited)) | |
393 | | Ast.MetaLocalFunc(name,constraints,_,_) -> | |
394 | let (unitary,inherited) = classify name in | |
395 | Ast.rewrap e (Ast.MetaLocalFunc(name,constraints,unitary,inherited)) | |
396 | | _ -> e in | |
397 | ||
398 | let rec type_infos = function | |
399 | TC.ConstVol(cv,ty) -> TC.ConstVol(cv,type_infos ty) | |
400 | | TC.Pointer(ty) -> TC.Pointer(type_infos ty) | |
401 | | TC.FunctionPointer(ty) -> TC.FunctionPointer(type_infos ty) | |
402 | | TC.Array(ty) -> TC.Array(type_infos ty) | |
403 | | TC.MetaType(name,_,_) -> | |
404 | let (unitary,inherited) = classify (name,(),(),Ast.NoMetaPos) in | |
405 | Type_cocci.MetaType(name,unitary,inherited) | |
406 | | TC.SignedT(sgn,Some ty) -> TC.SignedT(sgn,Some (type_infos ty)) | |
407 | | ty -> ty in | |
408 | ||
409 | let expression r k e = | |
410 | let e = k e in | |
411 | match Ast.unwrap e with | |
412 | Ast.MetaErr(name,constraints,_,_) -> | |
413 | let (unitary,inherited) = classify name in | |
414 | Ast.rewrap e (Ast.MetaErr(name,constraints,unitary,inherited)) | |
415 | | Ast.MetaExpr(name,constraints,_,ty,form,_) -> | |
416 | let (unitary,inherited) = classify name in | |
417 | let ty = get_option (List.map type_infos) ty in | |
418 | Ast.rewrap e (Ast.MetaExpr(name,constraints,unitary,ty,form,inherited)) | |
419 | | Ast.MetaExprList(name,None,_,_) -> | |
420 | (* lenname should have the same properties of being unitary or | |
421 | inherited as name *) | |
422 | let (unitary,inherited) = classify name in | |
423 | Ast.rewrap e (Ast.MetaExprList(name,None,unitary,inherited)) | |
424 | | Ast.MetaExprList(name,Some(lenname,_,_),_,_) -> | |
425 | (* lenname should have the same properties of being unitary or | |
426 | inherited as name *) | |
427 | let (unitary,inherited) = classify name in | |
428 | let (lenunitary,leninherited) = classify lenname in | |
429 | Ast.rewrap e | |
430 | (Ast.MetaExprList | |
431 | (name,Some(lenname,lenunitary,leninherited),unitary,inherited)) | |
432 | | _ -> e in | |
433 | ||
434 | let typeC r k e = | |
435 | let e = k e in | |
436 | match Ast.unwrap e with | |
437 | Ast.MetaType(name,_,_) -> | |
438 | let (unitary,inherited) = classify name in | |
439 | Ast.rewrap e (Ast.MetaType(name,unitary,inherited)) | |
440 | | _ -> e in | |
441 | ||
442 | let param r k e = | |
443 | let e = k e in | |
444 | match Ast.unwrap e with | |
445 | Ast.MetaParam(name,_,_) -> | |
446 | let (unitary,inherited) = classify name in | |
447 | Ast.rewrap e (Ast.MetaParam(name,unitary,inherited)) | |
448 | | Ast.MetaParamList(name,None,_,_) -> | |
449 | let (unitary,inherited) = classify name in | |
450 | Ast.rewrap e (Ast.MetaParamList(name,None,unitary,inherited)) | |
451 | | Ast.MetaParamList(name,Some (lenname,_,_),_,_) -> | |
452 | let (unitary,inherited) = classify name in | |
453 | let (lenunitary,leninherited) = classify lenname in | |
454 | Ast.rewrap e | |
455 | (Ast.MetaParamList | |
456 | (name,Some (lenname,lenunitary,leninherited),unitary,inherited)) | |
457 | | _ -> e in | |
458 | ||
459 | let rule_elem r k e = | |
460 | let e = k e in | |
461 | match Ast.unwrap e with | |
462 | Ast.MetaStmt(name,_,msi,_) -> | |
463 | let (unitary,inherited) = classify name in | |
464 | Ast.rewrap e (Ast.MetaStmt(name,unitary,msi,inherited)) | |
465 | | Ast.MetaStmtList(name,_,_) -> | |
466 | let (unitary,inherited) = classify name in | |
467 | Ast.rewrap e (Ast.MetaStmtList(name,unitary,inherited)) | |
468 | | _ -> e in | |
469 | ||
470 | let fn = V.rebuilder | |
471 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
472 | donothing donothing donothing donothing | |
473 | ident expression donothing typeC donothing param donothing rule_elem | |
474 | donothing donothing donothing donothing in | |
475 | ||
476 | List.map fn.V.rebuilder_top_level minirules | |
477 | ||
478 | (* ---------------------------------------------------------------- *) | |
479 | ||
480 | (* For a minirule, collect the set of non-local (not in "bound") variables that | |
481 | are referenced. Store them in a hash table. *) | |
482 | ||
483 | (* bound means the metavariable was declared previously, not locally *) | |
484 | ||
485 | (* Highly inefficient, because we call collect_all_refs on nested code | |
486 | multiple times. But we get the advantage of not having too many variants | |
487 | of the same functions. *) | |
488 | ||
489 | (* Inherited doesn't include position constraints. If they are not bound | |
490 | then there is no constraint. *) | |
491 | ||
492 | let astfvs metavars bound = | |
493 | let fresh = | |
494 | List.fold_left | |
495 | (function prev -> | |
496 | function | |
497 | Ast.MetaFreshIdDecl(_,_) as x -> (Ast.get_meta_name x)::prev | |
498 | | _ -> prev) | |
499 | [] metavars in | |
500 | ||
501 | let collect_fresh = List.filter (function x -> List.mem x fresh) in | |
502 | ||
503 | (* cases for the elements of anything *) | |
504 | let astfvrule_elem recursor k re = | |
505 | let minus_free = nub (collect_all_refs.V.combiner_rule_elem re) in | |
506 | let minus_nc_free = | |
507 | nub (collect_non_constraint_refs.V.combiner_rule_elem re) in | |
508 | let plus_free = collect_in_plus_term.V.combiner_rule_elem re in | |
509 | let free = Common.union_set minus_free plus_free in | |
510 | let nc_free = Common.union_set minus_nc_free plus_free in | |
511 | let unbound = | |
512 | List.filter (function x -> not(List.mem x bound)) free in | |
513 | let inherited = | |
514 | List.filter (function x -> List.mem x bound) nc_free in | |
515 | let munbound = | |
516 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
517 | {(k re) with | |
518 | Ast.free_vars = unbound; | |
519 | Ast.minus_free_vars = munbound; | |
520 | Ast.fresh_vars = collect_fresh unbound; | |
521 | Ast.inherited = inherited; | |
522 | Ast.saved_witness = []} in | |
523 | ||
524 | let astfvstatement recursor k s = | |
525 | let minus_free = nub (collect_all_refs.V.combiner_statement s) in | |
526 | let minus_nc_free = | |
527 | nub (collect_non_constraint_refs.V.combiner_statement s) in | |
528 | let plus_free = collect_in_plus_term.V.combiner_statement s in | |
529 | let free = Common.union_set minus_free plus_free in | |
530 | let nc_free = Common.union_set minus_nc_free plus_free in | |
531 | let classify free minus_free = | |
532 | let (unbound,inherited) = | |
533 | List.partition (function x -> not(List.mem x bound)) free in | |
534 | let munbound = | |
535 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
536 | (unbound,munbound,collect_fresh unbound,inherited) in | |
537 | let res = k s in | |
538 | let s = | |
539 | match Ast.unwrap res with | |
540 | Ast.IfThen(header,branch,(_,_,_,aft)) -> | |
541 | let (unbound,_,fresh,inherited) = | |
542 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
543 | Ast.IfThen(header,branch,(unbound,fresh,inherited,aft)) | |
544 | | Ast.IfThenElse(header,branch1,els,branch2,(_,_,_,aft)) -> | |
545 | let (unbound,_,fresh,inherited) = | |
546 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
547 | Ast.IfThenElse(header,branch1,els,branch2, | |
548 | (unbound,fresh,inherited,aft)) | |
549 | | Ast.While(header,body,(_,_,_,aft)) -> | |
550 | let (unbound,_,fresh,inherited) = | |
551 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
552 | Ast.While(header,body,(unbound,fresh,inherited,aft)) | |
553 | | Ast.For(header,body,(_,_,_,aft)) -> | |
554 | let (unbound,_,fresh,inherited) = | |
555 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
556 | Ast.For(header,body,(unbound,fresh,inherited,aft)) | |
557 | | Ast.Iterator(header,body,(_,_,_,aft)) -> | |
558 | let (unbound,_,fresh,inherited) = | |
559 | classify (cip_mcodekind collect_in_plus_term aft) [] in | |
560 | Ast.Iterator(header,body,(unbound,fresh,inherited,aft)) | |
561 | | s -> s in | |
562 | ||
563 | let (unbound,munbound,fresh,_) = classify free minus_free in | |
564 | let inherited = | |
565 | List.filter (function x -> List.mem x bound) nc_free in | |
566 | {res with | |
567 | Ast.node = s; | |
568 | Ast.free_vars = unbound; | |
569 | Ast.minus_free_vars = munbound; | |
570 | Ast.fresh_vars = collect_fresh unbound; | |
571 | Ast.inherited = inherited; | |
572 | Ast.saved_witness = []} in | |
573 | ||
574 | let astfvstatement_dots recursor k sd = | |
575 | let minus_free = nub (collect_all_refs.V.combiner_statement_dots sd) in | |
576 | let minus_nc_free = | |
577 | nub (collect_non_constraint_refs.V.combiner_statement_dots sd) in | |
578 | let plus_free = collect_in_plus_term.V.combiner_statement_dots sd in | |
579 | let free = Common.union_set minus_free plus_free in | |
580 | let nc_free = Common.union_set minus_nc_free plus_free in | |
581 | let unbound = | |
582 | List.filter (function x -> not(List.mem x bound)) free in | |
583 | let inherited = | |
584 | List.filter (function x -> List.mem x bound) nc_free in | |
585 | let munbound = | |
586 | List.filter (function x -> not(List.mem x bound)) minus_free in | |
587 | {(k sd) with | |
588 | Ast.free_vars = unbound; | |
589 | Ast.minus_free_vars = munbound; | |
590 | Ast.fresh_vars = collect_fresh unbound; | |
591 | Ast.inherited = inherited; | |
592 | Ast.saved_witness = []} in | |
593 | ||
594 | let astfvtoplevel recursor k tl = | |
595 | let saved = collect_saved.V.combiner_top_level tl in | |
596 | {(k tl) with Ast.saved_witness = saved} in | |
597 | ||
598 | let mcode x = x in | |
599 | let donothing r k e = k e in | |
600 | ||
601 | V.rebuilder | |
602 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
603 | donothing donothing astfvstatement_dots donothing | |
604 | donothing donothing donothing donothing donothing donothing donothing | |
605 | astfvrule_elem astfvstatement donothing astfvtoplevel donothing | |
606 | ||
607 | (* | |
608 | let collect_astfvs rules = | |
609 | let rec loop bound = function | |
610 | [] -> [] | |
611 | | (metavars,(nm,rule_info,minirules))::rules -> | |
612 | let bound = | |
613 | Common.minus_set bound (List.map Ast.get_meta_name metavars) in | |
614 | (nm,rule_info, | |
615 | (List.map (astfvs metavars bound).V.rebuilder_top_level minirules)):: | |
616 | (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in | |
617 | loop [] rules | |
618 | *) | |
619 | ||
620 | let collect_astfvs rules = | |
621 | let rec loop bound = function | |
622 | [] -> [] | |
623 | | (metavars, rule)::rules -> | |
624 | match rule with | |
625 | Ast.ScriptRule (_,_,_,_) -> | |
626 | (* bound stays as is because script rules have no names, so no | |
627 | inheritance is possible *) | |
628 | rule::(loop bound rules) | |
629 | | Ast.CocciRule (nm, rule_info, minirules, isexp, ruletype) -> | |
630 | let bound = | |
631 | Common.minus_set bound (List.map Ast.get_meta_name metavars) in | |
632 | (Ast.CocciRule | |
633 | (nm, rule_info, | |
634 | (List.map (astfvs metavars bound).V.rebuilder_top_level | |
635 | minirules), | |
636 | isexp, ruletype)):: | |
637 | (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in | |
638 | loop [] rules | |
639 | ||
640 | (* ---------------------------------------------------------------- *) | |
641 | (* position variables that appear as a constraint on another position variable. | |
642 | a position variable also cannot appear both positively and negatively in a | |
643 | single rule. *) | |
644 | ||
645 | let get_neg_pos_list (_,rule) used_after_list = | |
646 | let donothing r k e = k e in | |
647 | let bind (p1,np1) (p2,np2) = | |
648 | (Common.union_set p1 p2, Common.union_set np1 np2) in | |
649 | let option_default = ([],[]) in | |
650 | let metaid (x,_,_,_) = x in | |
651 | let mcode r mc = | |
652 | match Ast.get_pos_var mc with | |
653 | Ast.MetaPos(name,constraints,Ast.PER,_,_) -> | |
654 | ([metaid name],constraints) | |
655 | | Ast.MetaPos(name,constraints,Ast.ALL,_,_) -> | |
656 | ([],(metaid name)::constraints) | |
657 | | _ -> option_default in | |
658 | let v = | |
659 | V.combiner bind option_default | |
660 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode | |
661 | donothing donothing donothing donothing | |
662 | donothing donothing donothing donothing donothing donothing | |
663 | donothing donothing donothing donothing donothing donothing in | |
664 | match rule with | |
665 | Ast.CocciRule(_,_,minirules,_,_) -> | |
666 | List.map | |
667 | (function toplevel -> | |
668 | let (positions,neg_positions) = v.V.combiner_top_level toplevel in | |
669 | (if List.exists (function p -> List.mem p neg_positions) positions | |
670 | then | |
671 | failwith | |
672 | "a variable cannot be used both as a position and a constraint"); | |
673 | neg_positions) | |
674 | minirules | |
675 | | Ast.ScriptRule _ -> [] (*no negated positions*) | |
676 | ||
677 | (* ---------------------------------------------------------------- *) | |
678 | ||
679 | (* collect used after lists, per minirule *) | |
680 | ||
681 | (* defined is a list of variables that were declared in a previous metavar | |
682 | declaration *) | |
683 | ||
684 | (* Top-level used after: For each rule collect the set of variables that | |
685 | are inherited, ie used but not defined. These are accumulated back to | |
686 | their point of definition. *) | |
687 | ||
688 | ||
689 | let collect_top_level_used_after metavar_rule_list = | |
690 | let (used_after,used_after_lists) = | |
691 | List.fold_right | |
692 | (function (metavar_list,r) -> | |
693 | function (used_after,used_after_lists) -> | |
694 | let locally_defined = List.map Ast.get_meta_name metavar_list in | |
695 | let continue_propagation = | |
696 | List.filter (function x -> not(List.mem x locally_defined)) | |
697 | used_after in | |
698 | let free_vars = | |
699 | match r with | |
700 | Ast.ScriptRule (_,_,mv,_) -> | |
701 | List.map (function (_,(r,v)) -> (r,v)) mv | |
702 | | Ast.CocciRule (_,_,rule,_,_) -> | |
703 | Common.union_set (nub (collect_all_rule_refs rule)) | |
704 | (collect_in_plus rule) in | |
705 | let inherited = | |
706 | List.filter (function x -> not (List.mem x locally_defined)) | |
707 | free_vars in | |
708 | (Common.union_set inherited continue_propagation, | |
709 | used_after::used_after_lists)) | |
710 | metavar_rule_list ([],[]) in | |
711 | match used_after with | |
712 | [] -> used_after_lists | |
713 | | _ -> | |
714 | failwith | |
715 | (Printf.sprintf "collect_top_level_used_after: unbound variables %s" | |
716 | (String.concat " " (List.map (function (_,x) -> x) used_after))) | |
717 | ||
718 | let collect_local_used_after metavars minirules used_after = | |
719 | let locally_defined = List.map Ast.get_meta_name metavars in | |
720 | let rec loop defined = function | |
721 | [] -> (used_after,[],[]) | |
722 | | minirule::rest -> | |
723 | let free_vars = | |
724 | Common.union_set | |
725 | (nub (collect_all_minirule_refs minirule)) | |
726 | (collect_in_plus_term.V.combiner_top_level minirule) in | |
727 | let local_free_vars = | |
728 | List.filter (function x -> List.mem x locally_defined) free_vars in | |
729 | let new_defined = Common.union_set local_free_vars defined in | |
730 | let (mini_used_after,fvs_lists,mini_used_after_lists) = | |
731 | loop new_defined rest in | |
732 | let local_used = Common.union_set local_free_vars mini_used_after in | |
733 | let (new_used_after,new_list) = | |
734 | List.partition (function x -> List.mem x defined) mini_used_after in | |
735 | let new_used_after = Common.union_set local_used new_used_after in | |
736 | (new_used_after,free_vars::fvs_lists, | |
737 | new_list::mini_used_after_lists) in | |
738 | let (_,fvs_lists,used_after_lists) = loop [] minirules in | |
739 | (fvs_lists,used_after_lists) | |
740 | ||
741 | ||
742 | let collect_used_after metavar_rule_list = | |
743 | let used_after_lists = collect_top_level_used_after metavar_rule_list in | |
744 | List.map2 | |
745 | (function (metavars,r) -> | |
746 | function used_after -> | |
747 | match r with | |
748 | Ast.ScriptRule (_,_,mv,_) -> ([], [used_after]) | |
749 | | Ast.CocciRule (name, rule_info, minirules, _,_) -> | |
750 | collect_local_used_after metavars minirules used_after | |
751 | ) | |
752 | metavar_rule_list used_after_lists | |
753 | ||
754 | (* ---------------------------------------------------------------- *) | |
755 | (* entry point *) | |
756 | ||
757 | let free_vars rules = | |
758 | let metavars = List.map (function (mv,rule) -> mv) rules in | |
759 | let (fvs_lists,used_after_lists) = List.split (collect_used_after rules) in | |
760 | let neg_pos_lists = List.map2 get_neg_pos_list rules used_after_lists in | |
761 | let positions_list = (* for all rules, assume all positions are used after *) | |
762 | List.map | |
763 | (function (mv, r) -> | |
764 | match r with | |
765 | Ast.ScriptRule _ -> [] | |
766 | | Ast.CocciRule (_,_,rule,_,_) -> | |
767 | let positions = | |
768 | List.fold_left | |
769 | (function prev -> | |
770 | function Ast.MetaPosDecl(_,nm) -> nm::prev | _ -> prev) | |
771 | [] mv in | |
772 | List.map (function _ -> positions) rule) | |
773 | rules in | |
774 | let new_rules = | |
775 | List.map2 | |
776 | (function (mv,r) -> | |
777 | function ua -> | |
778 | match r with | |
779 | Ast.ScriptRule _ -> r | |
780 | | Ast.CocciRule (nm, rule_info, r, is_exp,ruletype) -> | |
781 | Ast.CocciRule | |
782 | (nm, rule_info, classify_variables mv r (List.concat ua), | |
783 | is_exp,ruletype)) | |
784 | rules used_after_lists in | |
785 | let new_rules = collect_astfvs (List.combine metavars new_rules) in | |
786 | (metavars,new_rules, | |
787 | fvs_lists,neg_pos_lists,used_after_lists,positions_list) |