2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
28 (* For each rule return the list of variables that are used after it.
29 Also augment various parts of each rule with unitary, inherited, and freshness
32 (* metavar decls should be better integrated into computations of free
33 variables in plus code *)
35 module Ast
= Ast_cocci
36 module V
= Visitor_ast
37 module TC
= Type_cocci
39 let rec nub = function
41 | (x
::xs
) when (List.mem x xs
) -> nub xs
42 | (x
::xs
) -> x
::(nub xs
)
44 (* Collect all variable references in a minirule. For a disj, we collect
45 the maximum number (2 is enough) of references in any branch. *)
47 let collect_unitary_nonunitary free_usage
=
48 let free_usage = List.sort compare
free_usage in
49 let rec loop1 todrop
= function (* skips multiple occurrences *)
51 | (x
::xs
) as all
-> if x
= todrop
then loop1 todrop xs
else all
in
52 let rec loop2 = function
56 if x
= y
(* occurs more than once in free_usage *)
58 let (unitary
,non_unitary
) = loop2(loop1 x xs
) in
59 (unitary
,x
::non_unitary
)
60 else (* occurs only once in free_usage *)
61 let (unitary
,non_unitary
) = loop2 (y
::xs
) in
62 (x
::unitary
,non_unitary
) in
65 let collect_refs include_constraints
=
66 let bind x y
= x
@ y
in
67 let option_default = [] in
69 let donothing recursor k e
= k e
in (* just combine in the normal way *)
71 let donothing_a recursor k e
= (* anything is not wrapped *)
72 k e
in (* just combine in the normal way *)
74 (* the following considers that anything that occurs non-unitarily in one
75 branch occurs nonunitarily in all branches. This is not optimal, but
76 doing better seems to require a breadth-first traversal, which is
77 perhaps better to avoid. Also, unitarily is represented as occuring once,
78 while nonunitarily is represented as twice - more is irrelevant *)
79 (* cases for disjs and metavars *)
80 let bind_disj refs_branches
=
81 let (unitary
,nonunitary
) =
82 List.split
(List.map
collect_unitary_nonunitary refs_branches
) in
83 let unitary = nub (List.concat
unitary) in
84 let nonunitary = nub (List.concat
nonunitary) in
86 List.filter
(function x
-> not
(List.mem x
nonunitary)) unitary in
87 unitary@nonunitary@nonunitary in
89 let metaid (x
,_
,_
,_
) = x
in
91 let astfvident recursor k i
=
93 (match Ast.unwrap i
with
94 Ast.MetaId
(name
,idconstraint
,_
,_
) | Ast.MetaFunc
(name
,idconstraint
,_
,_
)
95 | Ast.MetaLocalFunc
(name
,idconstraint
,_
,_
) ->
97 if include_constraints
99 match idconstraint
with
100 Ast.IdNegIdSet
(_
,metas) -> metas
103 bind (List.rev
metas) [metaid name
]
104 | Ast.DisjId
(ids
) -> bind_disj (List.map k ids
)
105 | _
-> option_default) in
107 let rec type_collect res
= function
108 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
109 | TC.Array
(ty
) -> type_collect res ty
110 | TC.EnumName
(TC.MV
(tyname
,_
,_
)) ->
112 | TC.StructUnionName
(_
,TC.MV
(tyname
,_
,_
)) ->
114 | TC.MetaType
(tyname
,_
,_
) ->
116 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
119 let astfvexpr recursor k e
=
121 (match Ast.unwrap e
with
122 Ast.MetaExpr
(name
,constraints
,_
,Some type_list
,_
,_
) ->
123 let types = List.fold_left
type_collect option_default type_list
in
125 if include_constraints
127 match constraints
with
128 Ast.SubExpCstrt l
-> l
131 bind extra (bind [metaid name
] types)
132 | Ast.MetaErr
(name
,constraints
,_
,_
)
133 | Ast.MetaExpr
(name
,constraints
,_
,_
,_
,_
) ->
135 if include_constraints
137 match constraints
with
138 Ast.SubExpCstrt l
-> l
141 bind extra [metaid name
]
142 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
143 [metaid name
;metaid lenname
]
144 | Ast.MetaExprList
(name
,_
,_
,_
) -> [metaid name
]
145 | Ast.DisjExpr
(exps
) -> bind_disj (List.map k exps
)
146 | _
-> option_default) in
148 let astfvdecls recursor k d
=
150 (match Ast.unwrap d
with
151 Ast.MetaDecl
(name
,_
,_
) | Ast.MetaField
(name
,_
,_
) -> [metaid name
]
152 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
153 [metaid name
;metaid lenname
]
154 | Ast.MetaFieldList
(name
,_
,_
,_
) ->
156 | Ast.DisjDecl
(decls
) -> bind_disj (List.map k decls
)
157 | _
-> option_default) in
159 let astfvfullType recursor k ty
=
161 (match Ast.unwrap ty
with
162 Ast.DisjType
(types) -> bind_disj (List.map k
types)
163 | _
-> option_default) in
165 let astfvtypeC recursor k ty
=
167 (match Ast.unwrap ty
with
168 Ast.MetaType
(name
,_
,_
) -> [metaid name
]
169 | _
-> option_default) in
171 let astfvinit recursor k ty
=
173 (match Ast.unwrap ty
with
174 Ast.MetaInit
(name
,_
,_
) -> [metaid name
]
175 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
176 [metaid name
;metaid lenname
]
177 | Ast.MetaInitList
(name
,_
,_
,_
) -> [metaid name
]
178 | _
-> option_default) in
180 let astfvparam recursor k p
=
182 (match Ast.unwrap p
with
183 Ast.MetaParam
(name
,_
,_
) -> [metaid name
]
184 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
185 [metaid name
;metaid lenname
]
186 | Ast.MetaParamList
(name
,_
,_
,_
) -> [metaid name
]
187 | _
-> option_default) in
189 let astfvrule_elem recursor k re
=
190 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
193 (match Ast.unwrap re
with
194 Ast.MetaRuleElem
(name
,_
,_
) | Ast.MetaStmt
(name
,_
,_
,_
)
195 | Ast.MetaStmtList
(name
,_
,_
) -> [metaid name
]
196 | _
-> option_default)) in
198 let astfvstatement recursor k s
=
200 (match Ast.unwrap s
with
202 bind_disj (List.map recursor
.V.combiner_statement_dots stms
)
203 | _
-> option_default) in
206 if include_constraints
210 (function Ast.MetaPos
(name
,constraints
,_
,_
,_
) ->
211 (metaid name
)::constraints
)
212 (Ast.get_pos_var mc
))
213 else option_default in
215 V.combiner
bind option_default
216 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
217 donothing donothing donothing donothing donothing
218 astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
219 astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
221 let collect_all_refs = collect_refs true
222 let collect_non_constraint_refs = collect_refs false
224 let collect_all_rule_refs minirules
=
225 List.fold_left
(@) []
226 (List.map
collect_all_refs.V.combiner_top_level minirules
)
228 let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
230 (* ---------------------------------------------------------------- *)
233 let bind = Common.union_set
in
234 let option_default = [] in
236 let donothing recursor k e
= k e
in (* just combine in the normal way *)
238 let metaid (x
,_
,_
,_
) = x
in
240 (* cases for metavariables *)
241 let astfvident recursor k i
=
243 (match Ast.unwrap i
with
244 Ast.MetaId
(name
,_
,TC.Saved
,_
)
245 | Ast.MetaFunc
(name
,_
,TC.Saved
,_
)
246 | Ast.MetaLocalFunc
(name
,_
,TC.Saved
,_
) -> [metaid name
]
247 | _
-> option_default) in
249 let rec type_collect res
= function
250 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
251 | TC.Array
(ty
) -> type_collect res ty
252 | TC.EnumName
(TC.MV
(tyname
,TC.Saved
,_
)) ->
254 | TC.StructUnionName
(_
,TC.MV
(tyname
,TC.Saved
,_
)) ->
256 | TC.MetaType
(tyname
,TC.Saved
,_
) ->
258 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
261 let astfvexpr recursor k e
=
263 match Ast.unwrap e
with
264 Ast.MetaExpr
(name
,_
,_
,Some type_list
,_
,_
) ->
265 List.fold_left
type_collect option_default type_list
269 (match Ast.unwrap e
with
270 Ast.MetaErr
(name
,_
,TC.Saved
,_
) | Ast.MetaExpr
(name
,_
,TC.Saved
,_
,_
,_
)
272 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
274 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
276 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
278 | Ast.MetaExprList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
279 | _
-> option_default) in
282 let astfvtypeC recursor k ty
=
284 (match Ast.unwrap ty
with
285 Ast.MetaType
(name
,TC.Saved
,_
) -> [metaid name
]
286 | _
-> option_default) in
288 let astfvinit recursor k ty
=
290 (match Ast.unwrap ty
with
291 Ast.MetaInit
(name
,TC.Saved
,_
) -> [metaid name
]
292 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
294 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
296 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
298 | _
-> option_default) in
300 let astfvparam recursor k p
=
302 (match Ast.unwrap p
with
303 Ast.MetaParam
(name
,TC.Saved
,_
) -> [metaid name
]
304 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
306 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
308 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
310 | Ast.MetaParamList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
311 | _
-> option_default) in
313 let astfvdecls recursor k d
=
315 (match Ast.unwrap d
with
316 Ast.MetaDecl
(name
,TC.Saved
,_
) | Ast.MetaField
(name
,TC.Saved
,_
) ->
318 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
320 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
322 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
324 | Ast.MetaFieldList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
325 | _
-> option_default) in
327 let astfvrule_elem recursor k re
=
328 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
331 (match Ast.unwrap re
with
332 Ast.MetaRuleElem
(name
,TC.Saved
,_
) | Ast.MetaStmt
(name
,TC.Saved
,_
,_
)
333 | Ast.MetaStmtList
(name
,TC.Saved
,_
) -> [metaid name
]
334 | _
-> option_default)) in
340 Ast.MetaPos
(name
,_
,_
,TC.Saved
,_
) -> (metaid name
) :: acc
342 option_default (Ast.get_pos_var e
) in
344 V.combiner
bind option_default
345 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
346 donothing donothing donothing donothing donothing
347 astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
348 astfvdecls astfvrule_elem donothing donothing donothing donothing
350 (* ---------------------------------------------------------------- *)
352 (* For the rules under a given metavariable declaration, collect all of the
353 variables that occur in the plus code *)
355 let cip_mcodekind r mck
=
356 let process_anything_list_list anythings
=
357 let astfvs = collect_all_refs.V.combiner_anything
in
358 List.fold_left
(@) []
359 (List.map
(function l
-> List.fold_left
(@) [] (List.map
astfvs l
))
362 Ast.MINUS
(_
,_
,_
,replacement
) ->
363 (match replacement
with
364 Ast.REPLACEMENT
(anythings
,_
) -> process_anything_list_list anythings
365 | Ast.NOREPLACEMENT
-> [])
366 | Ast.CONTEXT
(_
,befaft
) ->
368 Ast.BEFORE
(ll
,_
) -> process_anything_list_list ll
369 | Ast.AFTER
(ll
,_
) -> process_anything_list_list ll
370 | Ast.BEFOREAFTER
(llb
,lla
,_
) ->
371 (process_anything_list_list lla
) @
372 (process_anything_list_list llb
)
377 let collect_fresh_seed_env metavars l
=
382 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
383 ((Ast.get_meta_name x
),seed
)::prev
386 let (seed_env
,seeds
) =
388 (function (seed_env
,seeds
) as prev
->
391 (let v = List.assoc x
fresh in
398 Ast.SeedId
(id
) -> id
::prev
401 ((x
,ids)::seed_env
,Common.union_set
ids seeds
)
402 | _
-> ((x
,[])::seed_env
,seeds
))
403 with Not_found
-> prev
)
405 (List.rev seed_env
,List.rev seeds
)
407 let collect_fresh_seed metavars l
=
408 let (_
,seeds
) = collect_fresh_seed_env metavars l
in seeds
410 let collect_in_plus_term =
412 let bind x y
= x
@ y
in
413 let option_default = [] in
414 let donothing r k e
= k e
in
416 (* no positions in the + code *)
417 let mcode r
(_
,_
,mck
,_
) = cip_mcodekind r mck
in
419 (* case for things with bef/aft mcode *)
421 let astfvrule_elem recursor k re
=
422 match Ast.unwrap re
with
423 Ast.FunHeader
(bef
,_
,fi
,nm
,_
,params
,_
) ->
428 Ast.FType
(ty
) -> collect_all_refs.V.combiner_fullType ty
431 let nm_metas = collect_all_refs.V.combiner_ident nm
in
433 match Ast.unwrap params
with
434 Ast.DOTS
(params
) | Ast.CIRCLES
(params
) ->
438 match Ast.unwrap p
with
439 Ast.VoidParam
(t
) | Ast.Param
(t
,_
) ->
440 collect_all_refs.V.combiner_fullType t
443 | _
-> failwith
"not allowed for params" in
447 (bind (cip_mcodekind recursor bef
) (k re
))))
448 | Ast.Decl
(bef
,_
,_
) ->
449 bind (cip_mcodekind recursor bef
) (k re
)
452 let astfvstatement recursor k s
=
453 match Ast.unwrap s
with
454 Ast.IfThen
(_
,_
,(_
,_
,_
,aft
)) | Ast.IfThenElse
(_
,_
,_
,_
,(_
,_
,_
,aft
))
455 | Ast.While
(_
,_
,(_
,_
,_
,aft
)) | Ast.For
(_
,_
,(_
,_
,_
,aft
))
456 | Ast.Iterator
(_
,_
,(_
,_
,_
,aft
)) ->
457 bind (k s
) (cip_mcodekind recursor aft
)
460 V.combiner
bind option_default
461 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
462 donothing donothing donothing donothing donothing
463 donothing donothing donothing donothing donothing donothing
464 donothing astfvrule_elem astfvstatement donothing donothing donothing
466 let collect_in_plus metavars minirules
=
468 (collect_fresh_seed metavars
470 (List.map
collect_in_plus_term.V.combiner_top_level minirules
)))
472 (* ---------------------------------------------------------------- *)
474 (* For the rules under a given metavariable declaration, collect all of the
475 variables that occur only once and more than once in the minus code *)
477 let collect_all_multirefs minirules
=
478 let refs = List.map
collect_all_refs.V.combiner_top_level minirules
in
479 collect_unitary_nonunitary (List.concat
refs)
481 (* ---------------------------------------------------------------- *)
483 (* classify as unitary (no binding) or nonunitary (env binding) or saved
486 let classify_variables metavar_decls minirules used_after
=
487 let metavars = List.map
Ast.get_meta_name metavar_decls
in
488 let (unitary,nonunitary) = collect_all_multirefs minirules
in
489 let inplus = collect_in_plus metavar_decls minirules
in
491 let donothing r k e
= k e
in
492 let check_unitary name inherited
=
493 if List.mem name
inplus or List.mem name used_after
495 else if not inherited
&& List.mem name
unitary
497 else TC.Nonunitary
in
499 let get_option f
= function Some x
-> Some
(f x
) | None
-> None
in
501 let classify (name
,_
,_
,_
) =
502 let inherited = not
(List.mem name
metavars) in
503 (check_unitary name
inherited,inherited) in
508 (function Ast.MetaPos
(name
,constraints
,per
,unitary,inherited) ->
509 let (unitary,inherited) = classify name
in
510 Ast.MetaPos
(name
,constraints
,per
,unitary,inherited))
511 (Ast.get_pos_var mc
) in
512 Ast.set_pos_var
p mc
in
516 match Ast.unwrap
e with
517 Ast.MetaId
(name
,constraints
,_
,_
) ->
518 let (unitary,inherited) = classify name
in
520 (Ast.MetaId
(name
,constraints
,unitary,inherited))
521 | Ast.MetaFunc
(name
,constraints
,_
,_
) ->
522 let (unitary,inherited) = classify name
in
523 Ast.rewrap
e (Ast.MetaFunc
(name
,constraints
,unitary,inherited))
524 | Ast.MetaLocalFunc
(name
,constraints
,_
,_
) ->
525 let (unitary,inherited) = classify name
in
526 Ast.rewrap
e (Ast.MetaLocalFunc
(name
,constraints
,unitary,inherited))
529 let rec type_infos = function
530 TC.ConstVol
(cv
,ty
) -> TC.ConstVol
(cv
,type_infos ty
)
531 | TC.Pointer
(ty
) -> TC.Pointer
(type_infos ty
)
532 | TC.FunctionPointer
(ty
) -> TC.FunctionPointer
(type_infos ty
)
533 | TC.Array
(ty
) -> TC.Array
(type_infos ty
)
534 | TC.EnumName
(TC.MV
(name
,_
,_
)) ->
535 let (unitary,inherited) = classify (name
,(),(),[]) in
536 TC.EnumName
(TC.MV
(name
,unitary,inherited))
537 | TC.StructUnionName
(su
,TC.MV
(name
,_
,_
)) ->
538 let (unitary,inherited) = classify (name
,(),(),[]) in
539 TC.StructUnionName
(su
,TC.MV
(name
,unitary,inherited))
540 | TC.MetaType
(name
,_
,_
) ->
541 let (unitary,inherited) = classify (name
,(),(),[]) in
542 Type_cocci.MetaType
(name
,unitary,inherited)
543 | TC.SignedT
(sgn
,Some ty
) -> TC.SignedT
(sgn
,Some
(type_infos ty
))
546 let expression r k
e =
548 match Ast.unwrap
e with
549 Ast.MetaErr
(name
,constraints
,_
,_
) ->
550 let (unitary,inherited) = classify name
in
551 Ast.rewrap
e (Ast.MetaErr
(name
,constraints
,unitary,inherited))
552 | Ast.MetaExpr
(name
,constraints
,_
,ty
,form
,_
) ->
553 let (unitary,inherited) = classify name
in
554 let ty = get_option (List.map
type_infos) ty in
555 Ast.rewrap
e (Ast.MetaExpr
(name
,constraints
,unitary,ty,form
,inherited))
556 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
557 (* lenname should have the same properties of being unitary or
559 let (unitary,inherited) = classify name
in
560 let (lenunitary
,leninherited
) = classify lenname
in
564 Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
566 | Ast.MetaExprList
(name
,lenname
,_
,_
) ->
567 (* lenname should have the same properties of being unitary or
569 let (unitary,inherited) = classify name
in
570 Ast.rewrap
e (Ast.MetaExprList
(name
,lenname
,unitary,inherited))
575 match Ast.unwrap
e with
576 Ast.MetaType
(name
,_
,_
) ->
577 let (unitary,inherited) = classify name
in
578 Ast.rewrap
e (Ast.MetaType
(name
,unitary,inherited))
583 match Ast.unwrap
e with
584 Ast.MetaInit
(name
,_
,_
) ->
585 let (unitary,inherited) = classify name
in
586 Ast.rewrap
e (Ast.MetaInit
(name
,unitary,inherited))
587 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
588 let (unitary,inherited) = classify name
in
589 let (lenunitary
,leninherited
) = classify lenname
in
592 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
594 | Ast.MetaInitList
(name
,lenname
,_
,_
) ->
595 let (unitary,inherited) = classify name
in
596 Ast.rewrap
e (Ast.MetaInitList
(name
,lenname
,unitary,inherited))
601 match Ast.unwrap
e with
602 Ast.MetaParam
(name
,_
,_
) ->
603 let (unitary,inherited) = classify name
in
604 Ast.rewrap
e (Ast.MetaParam
(name
,unitary,inherited))
605 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
606 let (unitary,inherited) = classify name
in
607 let (lenunitary
,leninherited
) = classify lenname
in
610 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
612 | Ast.MetaParamList
(name
,lenname
,_
,_
) ->
613 let (unitary,inherited) = classify name
in
614 Ast.rewrap
e (Ast.MetaParamList
(name
,lenname
,unitary,inherited))
619 match Ast.unwrap
e with
620 Ast.MetaDecl
(name
,_
,_
) ->
621 let (unitary,inherited) = classify name
in
622 Ast.rewrap
e (Ast.MetaDecl
(name
,unitary,inherited))
623 | Ast.MetaField
(name
,_
,_
) ->
624 let (unitary,inherited) = classify name
in
625 Ast.rewrap
e (Ast.MetaField
(name
,unitary,inherited))
626 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
627 let (unitary,inherited) = classify name
in
628 let (lenunitary
,leninherited
) = classify lenname
in
631 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
633 | Ast.MetaFieldList
(name
,lenname
,_
,_
) ->
634 let (unitary,inherited) = classify name
in
635 Ast.rewrap
e (Ast.MetaFieldList
(name
,lenname
,unitary,inherited))
638 let rule_elem r k
e =
640 match Ast.unwrap
e with
641 Ast.MetaStmt
(name
,_
,msi
,_
) ->
642 let (unitary,inherited) = classify name
in
643 Ast.rewrap
e (Ast.MetaStmt
(name
,unitary,msi
,inherited))
644 | Ast.MetaStmtList
(name
,_
,_
) ->
645 let (unitary,inherited) = classify name
in
646 Ast.rewrap
e (Ast.MetaStmtList
(name
,unitary,inherited))
650 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
651 donothing donothing donothing donothing donothing
652 ident expression donothing typeC init param decl rule_elem
653 donothing donothing donothing donothing in
655 List.map
fn.V.rebuilder_top_level minirules
657 (* ---------------------------------------------------------------- *)
659 (* For a minirule, collect the set of non-local (not in "bound") variables that
660 are referenced. Store them in a hash table. *)
662 (* bound means the metavariable was declared previously, not locally *)
664 (* Highly inefficient, because we call collect_all_refs on nested code
665 multiple times. But we get the advantage of not having too many variants
666 of the same functions. *)
668 (* Inherited doesn't include position constraints. If they are not bound
669 then there is no constraint. *)
671 let astfvs metavars bound
=
676 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
677 ((Ast.get_meta_name x
),seed
)::prev
681 let collect_fresh l
=
682 let (matched
,freshvars
) =
684 (function (matched
,freshvars
) ->
686 try let v = List.assoc x
fresh in (matched
,(x
,v)::freshvars
)
687 with Not_found
-> (x
::matched
,freshvars
))
689 (List.rev matched
, List.rev freshvars
) in
691 (* cases for the elements of anything *)
692 let simple_setup getter k re
=
693 let minus_free = nub (getter
collect_all_refs re
) in
695 nub (getter
collect_non_constraint_refs re
) in
697 collect_fresh_seed metavars (getter
collect_in_plus_term re
) in
698 let free = Common.union_set
minus_free plus_free in
699 let nc_free = Common.union_set
minus_nc_free plus_free in
701 List.filter
(function x
-> not
(List.mem x bound
)) free in
703 List.filter
(function x
-> List.mem x bound
) nc_free in
705 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
706 let (matched
,fresh) = collect_fresh unbound in
708 Ast.free_vars
= matched
;
709 Ast.minus_free_vars
= munbound;
710 Ast.fresh_vars
= fresh;
711 Ast.inherited = inherited;
712 Ast.saved_witness
= []} in
714 let astfvrule_elem recursor k re
=
715 simple_setup (function x
-> x
.V.combiner_rule_elem
) k re
in
717 let astfvstatement recursor k s
=
718 let minus_free = nub (collect_all_refs.V.combiner_statement s
) in
720 nub (collect_non_constraint_refs.V.combiner_statement s
) in
722 collect_fresh_seed metavars
723 (collect_in_plus_term.V.combiner_statement s
) in
724 let free = Common.union_set
minus_free plus_free in
725 let nc_free = Common.union_set
minus_nc_free plus_free in
726 let classify free minus_free =
727 let (unbound,inherited) =
728 List.partition
(function x
-> not
(List.mem x bound
)) free in
730 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
731 let (matched
,fresh) = collect_fresh unbound in
732 (matched
,munbound,fresh,inherited) in
736 collect_fresh_seed metavars
737 (cip_mcodekind collect_in_plus_term aft
) in
738 match Ast.unwrap
res with
739 Ast.IfThen
(header
,branch
,(_
,_
,_
,aft
)) ->
740 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
741 Ast.IfThen
(header
,branch
,(unbound,fresh,inherited,aft
))
742 | Ast.IfThenElse
(header
,branch1
,els
,branch2
,(_
,_
,_
,aft
)) ->
743 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
744 Ast.IfThenElse
(header
,branch1
,els
,branch2
,
745 (unbound,fresh,inherited,aft
))
746 | Ast.While
(header
,body
,(_
,_
,_
,aft
)) ->
747 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
748 Ast.While
(header
,body
,(unbound,fresh,inherited,aft
))
749 | Ast.For
(header
,body
,(_
,_
,_
,aft
)) ->
750 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
751 Ast.For
(header
,body
,(unbound,fresh,inherited,aft
))
752 | Ast.Iterator
(header
,body
,(_
,_
,_
,aft
)) ->
753 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
754 Ast.Iterator
(header
,body
,(unbound,fresh,inherited,aft
))
757 let (matched
,munbound,fresh,_
) = classify free minus_free in
759 List.filter
(function x
-> List.mem x bound
) nc_free in
762 Ast.free_vars
= matched
;
763 Ast.minus_free_vars
= munbound;
764 Ast.fresh_vars
= fresh;
765 Ast.inherited = inherited;
766 Ast.saved_witness
= []} in
768 let astfvstatement_dots recursor k sd
=
769 simple_setup (function x
-> x
.V.combiner_statement_dots
) k sd
in
771 let astfvcase_line recursor k cl
=
772 simple_setup (function x
-> x
.V.combiner_case_line
) k cl
in
774 let astfvtoplevel recursor k tl
=
775 let saved = collect_saved.V.combiner_top_level tl
in
776 {(k tl
) with Ast.saved_witness
= saved} in
779 let donothing r k
e = k
e in
782 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
783 donothing donothing astfvstatement_dots donothing donothing
784 donothing donothing donothing donothing donothing donothing donothing
785 astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
788 let collect_astfvs rules =
789 let rec loop bound = function
791 | (metavars,(nm,rule_info,minirules))::rules ->
793 Common.minus_set bound (List.map Ast.get_meta_name metavars) in
795 (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
796 (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
800 let collect_astfvs rules
=
801 let rec loop bound = function
803 | (metavars, rule
)::rules
->
805 Ast.ScriptRule
(_
,_
,_
,_
,script_vars
,_
) ->
806 (* why are metavars in rule, but outside for cocci rule??? *)
807 let bound = script_vars
@ bound in
808 rule
::(loop bound rules
)
809 | Ast.InitialScriptRule
(_
,_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
,_
) ->
810 (* bound stays as is because script rules have no names, so no
811 inheritance is possible *)
812 rule
::(loop bound rules
)
813 | Ast.CocciRule
(nm
, rule_info
, minirules
, isexp
, ruletype
) ->
815 Common.minus_set
bound (List.map
Ast.get_meta_name
metavars) in
818 (List.map
(astfvs metavars bound).V.rebuilder_top_level
821 (loop ((List.map
Ast.get_meta_name
metavars)@bound) rules
) in
824 (* ---------------------------------------------------------------- *)
825 (* position variables that appear as a constraint on another position variable.
826 a position variable also cannot appear both positively and negatively in a
829 let get_neg_pos_list (_
,rule
) used_after_list
=
830 let donothing r k
e = k
e in
831 let bind (p1
,np1
) (p2
,np2
) =
832 (Common.union_set p1 p2
, Common.union_set np1 np2
) in
833 let option_default = ([],[]) in
834 let metaid (x
,_
,_
,_
) = x
in
839 Ast.MetaPos
(name
,constraints
,Ast.PER
,_
,_
) ->
840 ((metaid name
)::a
,constraints
@b
)
841 | Ast.MetaPos
(name
,constraints
,Ast.ALL
,_
,_
) ->
842 (a
,(metaid name
)::constraints
@b
)))
843 option_default (Ast.get_pos_var mc
) in
845 V.combiner
bind option_default
846 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
847 donothing donothing donothing donothing donothing
848 donothing donothing donothing donothing donothing donothing
849 donothing donothing donothing donothing donothing donothing in
851 Ast.CocciRule
(_
,_
,minirules
,_
,_
) ->
853 (function toplevel
->
854 let (positions
,neg_positions
) = v.V.combiner_top_level toplevel
in
855 (if List.exists
(function p -> List.mem
p neg_positions
) positions
858 "a variable cannot be used both as a position and a constraint");
861 | Ast.ScriptRule _
| Ast.InitialScriptRule _
| Ast.FinalScriptRule _
->
862 (*no negated positions*) []
864 (* ---------------------------------------------------------------- *)
866 (* collect used after lists, per minirule *)
868 (* defined is a list of variables that were declared in a previous metavar
871 (* Top-level used after: For each rule collect the set of variables that
872 are inherited, ie used but not defined. These are accumulated back to
873 their point of definition. *)
876 let collect_top_level_used_after metavar_rule_list
=
877 let drop_virt = List.filter
(function ("virtual",_
) -> false | _
-> true) in
878 let (used_after
,used_after_lists
) =
880 (function (metavar_list
,r
) ->
881 function (used_after
,used_after_lists
) ->
882 let locally_defined =
884 Ast.ScriptRule
(_
,_
,_
,_
,free_vars
,_
) -> free_vars
885 | _
-> List.map
Ast.get_meta_name metavar_list
in
886 let continue_propagation =
887 List.filter
(function x
-> not
(List.mem x
locally_defined))
891 Ast.ScriptRule
(_
,_
,_
,mv
,_
,_
) ->
892 drop_virt(List.map
(function (_
,(r
,v),_
) -> (r
,v)) mv
)
893 | Ast.InitialScriptRule
(_
,_
,_
,_
)
894 | Ast.FinalScriptRule
(_
,_
,_
,_
) -> []
895 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
897 (Common.union_set
(nub (collect_all_rule_refs rule
))
898 (collect_in_plus metavar_list rule
)) in
900 List.filter
(function x
-> not
(List.mem x
locally_defined))
902 (Common.union_set
inherited continue_propagation,
903 used_after
::used_after_lists
))
904 metavar_rule_list
([],[]) in
905 match used_after
with
906 [] -> used_after_lists
909 (Printf.sprintf
"collect_top_level_used_after: unbound variables %s"
910 (String.concat
" " (List.map
(function (_
,x
) -> x
) used_after
)))
912 let collect_local_used_after metavars minirules used_after
=
913 let locally_defined = List.map
Ast.get_meta_name
metavars in
914 let rec loop = function
915 [] -> (used_after
,[],[],[],[])
917 (* In a rule there are three kinds of local variables:
918 1. Variables referenced in the minus or context code.
919 These get a value by matching. This value can be used in
921 2. Fresh variables referenced in the plus code.
922 3. Variables referenced in the seeds of the fresh variables.
923 There are also non-local variables. These may either be variables
924 referenced in the minus, context, or plus code, or they may be
925 variables referenced in the seeds of the fresh variables. *)
926 (* Step 1: collect all references in minus/context, plus, seed
928 let variables_referenced_in_minus_context_code =
929 nub (collect_all_minirule_refs minirule
) in
930 let variables_referenced_in_plus_code =
931 collect_in_plus_term.V.combiner_top_level minirule
in
932 let (env_of_fresh_seeds
,seeds_and_plus
) =
933 collect_fresh_seed_env
934 metavars variables_referenced_in_plus_code in
936 Common.union_set
variables_referenced_in_minus_context_code
938 (* Step 2: identify locally defined ones *)
939 let local_fresh = List.map fst env_of_fresh_seeds
in
941 List.partition
(function x
-> List.mem x
locally_defined) in
942 let local_env_of_fresh_seeds =
943 (* these have to be restricted to only one value if the associated
944 fresh variable is used after *)
945 List.map
(function (f
,ss
) -> (f
,is_local ss
)) env_of_fresh_seeds
in
946 let (local_all_free_vars
,nonlocal_all_free_vars
) =
947 is_local all_free_vars in
948 (* Step 3, recurse on the rest of the rules, making available whatever
949 has been defined in this one *)
950 let (mini_used_after
,fvs_lists
,mini_used_after_lists
,
951 mini_fresh_used_after_lists
,mini_fresh_used_after_seeds
) =
953 (* Step 4: collect the results. These are:
954 1. All of the variables used non-locally in the rules starting
956 2. All of the free variables to the end of the semantic patch
957 3. The variables that are used afterwards and defined here by
958 matching (minus or context code)
959 4. The variables that are used afterwards and are defined here as
961 5. The variables that are used as seeds in computing the bindings
962 of the variables collected in part 4. *)
963 let (local_used_after
, nonlocal_used_after
) =
964 is_local mini_used_after
in
965 let (fresh_local_used_after
(*4*),matched_local_used_after
) =
966 List.partition
(function x
-> List.mem x
local_fresh)
968 let matched_local_used_after(*3*) =
969 Common.union_set
matched_local_used_after nonlocal_used_after
in
970 let new_used_after = (*1*)
971 Common.union_set nonlocal_all_free_vars nonlocal_used_after
in
972 let fresh_local_used_after_seeds =
974 (* no point to keep variables that already are gtd to have only
976 (function x
-> not
(List.mem x
matched_local_used_after))
977 (List.fold_left
(function p -> function c
-> Common.union_set c
p)
981 fst
(List.assoc fua
local_env_of_fresh_seeds))
982 fresh_local_used_after
)) in
983 (new_used_after,all_free_vars::fvs_lists
(*2*),
984 matched_local_used_after::mini_used_after_lists
,
985 fresh_local_used_after
::mini_fresh_used_after_lists
,
986 fresh_local_used_after_seeds::mini_fresh_used_after_seeds
) in
987 let (_
,fvs_lists
,used_after_lists
(*ua*),
988 fresh_used_after_lists
(*fua*),fresh_used_after_lists_seeds
(*fuas*)) =
990 (fvs_lists
,used_after_lists
,
991 fresh_used_after_lists
,fresh_used_after_lists_seeds
)
995 let collect_used_after metavar_rule_list
=
996 let used_after_lists = collect_top_level_used_after metavar_rule_list
in
998 (function (metavars,r
) ->
999 function used_after
->
1001 Ast.ScriptRule
(_
,_
,_
,_
,_
,_
) (* no minirules, so nothing to do? *)
1002 | Ast.InitialScriptRule
(_
,_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
,_
) ->
1003 ([], [used_after
], [[]], [])
1004 | Ast.CocciRule
(name
, rule_info
, minirules
, _
,_
) ->
1005 collect_local_used_after metavars minirules used_after
1007 metavar_rule_list
used_after_lists
1009 let rec split4 = function
1011 | (a
,b
,c
,d
)::l
-> let (a1
,b1
,c1
,d1
) = split4 l
in (a
::a1
,b
::b1
,c
::c1
,d
::d1
)
1013 (* ---------------------------------------------------------------- *)
1016 let free_vars rules
=
1017 let metavars = List.map
(function (mv
,rule
) -> mv
) rules
in
1018 let (fvs_lists
,used_after_matched_lists
,
1019 fresh_used_after_lists
,fresh_used_after_lists_seeds
) =
1020 split4 (collect_used_after rules
) in
1022 List.map2
get_neg_pos_list rules used_after_matched_lists
in
1023 let positions_list = (* for all rules, assume all positions are used after *)
1025 (function (mv
, r
) ->
1027 Ast.ScriptRule _
(* doesn't declare position variables *)
1028 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> []
1029 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
1033 function Ast.MetaPosDecl
(_
,nm
) -> nm
::prev
| _
-> prev
)
1035 List.map
(function _
-> positions) rule
)
1040 function (ua
,fua
) ->
1043 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> r
1044 | Ast.CocciRule
(nm
, rule_info
, r
, is_exp
,ruletype
) ->
1047 classify_variables mv r
1048 ((List.concat ua
) @ (List.concat fua
)),
1050 rules
(List.combine used_after_matched_lists fresh_used_after_lists
) in
1051 let new_rules = collect_astfvs (List.combine
metavars new_rules) in
1052 (metavars,new_rules,
1053 fvs_lists
,neg_pos_lists,
1054 (used_after_matched_lists
,
1055 fresh_used_after_lists
,fresh_used_after_lists_seeds
),