2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* For each rule return the list of variables that are used after it.
26 Also augment various parts of each rule with unitary, inherited, and freshness
29 (* metavar decls should be better integrated into computations of free
30 variables in plus code *)
32 module Ast
= Ast_cocci
33 module V
= Visitor_ast
34 module TC
= Type_cocci
36 let rec nub = function
38 | (x
::xs
) when (List.mem x xs
) -> nub xs
39 | (x
::xs
) -> x
::(nub xs
)
41 (* Collect all variable references in a minirule. For a disj, we collect
42 the maximum number (2 is enough) of references in any branch. *)
44 let collect_unitary_nonunitary free_usage
=
45 let free_usage = List.sort compare
free_usage in
46 let rec loop1 todrop
= function (* skips multiple occurrences *)
48 | (x
::xs
) as all
-> if x
= todrop
then loop1 todrop xs
else all
in
49 let rec loop2 = function
53 if x
= y
(* occurs more than once in free_usage *)
55 let (unitary
,non_unitary
) = loop2(loop1 x xs
) in
56 (unitary
,x
::non_unitary
)
57 else (* occurs only once in free_usage *)
58 let (unitary
,non_unitary
) = loop2 (y
::xs
) in
59 (x
::unitary
,non_unitary
) in
62 let collect_refs include_constraints
=
63 let bind x y
= x
@ y
in
64 let option_default = [] in
66 let donothing recursor k e
= k e
in (* just combine in the normal way *)
68 let donothing_a recursor k e
= (* anything is not wrapped *)
69 k e
in (* just combine in the normal way *)
71 (* the following considers that anything that occurs non-unitarily in one
72 branch occurs nonunitarily in all branches. This is not optimal, but
73 doing better seems to require a breadth-first traversal, which is
74 perhaps better to avoid. Also, unitarily is represented as occuring once,
75 while nonunitarily is represented as twice - more is irrelevant *)
76 (* cases for disjs and metavars *)
77 let bind_disj refs_branches
=
78 let (unitary
,nonunitary
) =
79 List.split
(List.map
collect_unitary_nonunitary refs_branches
) in
80 let unitary = nub (List.concat
unitary) in
81 let nonunitary = nub (List.concat
nonunitary) in
83 List.filter
(function x
-> not
(List.mem x
nonunitary)) unitary in
84 unitary@nonunitary@nonunitary in
86 let metaid (x
,_
,_
,_
) = x
in
88 let astfvident recursor k i
=
90 (match Ast.unwrap i
with
91 Ast.MetaId
(name
,idconstraint
,_
,_
) | Ast.MetaFunc
(name
,idconstraint
,_
,_
)
92 | Ast.MetaLocalFunc
(name
,idconstraint
,_
,_
) ->
94 if include_constraints
96 match idconstraint
with
97 Ast.IdNegIdSet
(_
,metas) -> metas
100 bind (List.rev
metas) [metaid name
]
101 | Ast.DisjId
(ids
) -> bind_disj (List.map k ids
)
102 | _
-> option_default) in
104 let rec type_collect res
= function
105 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
106 | TC.Array
(ty
) -> type_collect res ty
107 | TC.EnumName
(TC.MV
(tyname
,_
,_
)) ->
109 | TC.StructUnionName
(_
,TC.MV
(tyname
,_
,_
)) ->
111 | TC.MetaType
(tyname
,_
,_
) ->
113 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
116 let astfvexpr recursor k e
=
118 (match Ast.unwrap e
with
119 Ast.MetaExpr
(name
,constraints
,_
,Some type_list
,_
,_
) ->
120 let types = List.fold_left
type_collect option_default type_list
in
122 if include_constraints
124 match constraints
with
125 Ast.SubExpCstrt l
-> l
128 bind extra (bind [metaid name
] types)
129 | Ast.MetaErr
(name
,constraints
,_
,_
)
130 | Ast.MetaExpr
(name
,constraints
,_
,_
,_
,_
) ->
132 if include_constraints
134 match constraints
with
135 Ast.SubExpCstrt l
-> l
138 bind extra [metaid name
]
139 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
140 [metaid name
;metaid lenname
]
141 | Ast.MetaExprList
(name
,_
,_
,_
) -> [metaid name
]
142 | Ast.DisjExpr
(exps
) -> bind_disj (List.map k exps
)
143 | _
-> option_default) in
145 let astfvdecls recursor k d
=
147 (match Ast.unwrap d
with
148 Ast.MetaDecl
(name
,_
,_
) | Ast.MetaField
(name
,_
,_
) -> [metaid name
]
149 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
150 [metaid name
;metaid lenname
]
151 | Ast.MetaFieldList
(name
,_
,_
,_
) ->
153 | Ast.DisjDecl
(decls
) -> bind_disj (List.map k decls
)
154 | _
-> option_default) in
156 let astfvfullType recursor k ty
=
158 (match Ast.unwrap ty
with
159 Ast.DisjType
(types) -> bind_disj (List.map k
types)
160 | _
-> option_default) in
162 let astfvtypeC recursor k ty
=
164 (match Ast.unwrap ty
with
165 Ast.MetaType
(name
,_
,_
) -> [metaid name
]
166 | _
-> option_default) in
168 let astfvinit recursor k ty
=
170 (match Ast.unwrap ty
with
171 Ast.MetaInit
(name
,_
,_
) -> [metaid name
]
172 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
173 [metaid name
;metaid lenname
]
174 | Ast.MetaInitList
(name
,_
,_
,_
) -> [metaid name
]
175 | _
-> option_default) in
177 let astfvparam recursor k p
=
179 (match Ast.unwrap p
with
180 Ast.MetaParam
(name
,_
,_
) -> [metaid name
]
181 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
182 [metaid name
;metaid lenname
]
183 | Ast.MetaParamList
(name
,_
,_
,_
) -> [metaid name
]
184 | _
-> option_default) in
186 let astfvrule_elem recursor k re
=
187 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
190 (match Ast.unwrap re
with
191 Ast.MetaRuleElem
(name
,_
,_
) | Ast.MetaStmt
(name
,_
,_
,_
)
192 | Ast.MetaStmtList
(name
,_
,_
) -> [metaid name
]
193 | _
-> option_default)) in
195 let astfvstatement recursor k s
=
197 (match Ast.unwrap s
with
199 bind_disj (List.map recursor
.V.combiner_statement_dots stms
)
200 | _
-> option_default) in
203 if include_constraints
207 (function Ast.MetaPos
(name
,constraints
,_
,_
,_
) ->
208 (metaid name
)::constraints
)
209 (Ast.get_pos_var mc
))
210 else option_default in
212 V.combiner
bind option_default
213 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
214 donothing donothing donothing donothing donothing
215 astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
216 astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
218 let collect_all_refs = collect_refs true
219 let collect_non_constraint_refs = collect_refs false
221 let collect_all_rule_refs minirules
=
222 List.fold_left
(@) []
223 (List.map
collect_all_refs.V.combiner_top_level minirules
)
225 let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
227 (* ---------------------------------------------------------------- *)
230 let bind = Common.union_set
in
231 let option_default = [] in
233 let donothing recursor k e
= k e
in (* just combine in the normal way *)
235 let metaid (x
,_
,_
,_
) = x
in
237 (* cases for metavariables *)
238 let astfvident recursor k i
=
240 (match Ast.unwrap i
with
241 Ast.MetaId
(name
,_
,TC.Saved
,_
)
242 | Ast.MetaFunc
(name
,_
,TC.Saved
,_
)
243 | Ast.MetaLocalFunc
(name
,_
,TC.Saved
,_
) -> [metaid name
]
244 | _
-> option_default) in
246 let rec type_collect res
= function
247 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
248 | TC.Array
(ty
) -> type_collect res ty
249 | TC.EnumName
(TC.MV
(tyname
,TC.Saved
,_
)) ->
251 | TC.StructUnionName
(_
,TC.MV
(tyname
,TC.Saved
,_
)) ->
253 | TC.MetaType
(tyname
,TC.Saved
,_
) ->
255 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
258 let astfvexpr recursor k e
=
260 match Ast.unwrap e
with
261 Ast.MetaExpr
(name
,_
,_
,Some type_list
,_
,_
) ->
262 List.fold_left
type_collect option_default type_list
266 (match Ast.unwrap e
with
267 Ast.MetaErr
(name
,_
,TC.Saved
,_
) | Ast.MetaExpr
(name
,_
,TC.Saved
,_
,_
,_
)
269 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
271 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
273 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
275 | Ast.MetaExprList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
276 | _
-> option_default) in
279 let astfvtypeC recursor k ty
=
281 (match Ast.unwrap ty
with
282 Ast.MetaType
(name
,TC.Saved
,_
) -> [metaid name
]
283 | _
-> option_default) in
285 let astfvinit recursor k ty
=
287 (match Ast.unwrap ty
with
288 Ast.MetaInit
(name
,TC.Saved
,_
) -> [metaid name
]
289 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
291 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
293 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
295 | _
-> option_default) in
297 let astfvparam recursor k p
=
299 (match Ast.unwrap p
with
300 Ast.MetaParam
(name
,TC.Saved
,_
) -> [metaid name
]
301 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
303 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
305 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
307 | Ast.MetaParamList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
308 | _
-> option_default) in
310 let astfvdecls recursor k d
=
312 (match Ast.unwrap d
with
313 Ast.MetaDecl
(name
,TC.Saved
,_
) | Ast.MetaField
(name
,TC.Saved
,_
) ->
315 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,ls
,_
),ns
,_
) ->
317 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
319 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
321 | Ast.MetaFieldList
(name
,_
,TC.Saved
,_
) -> [metaid name
]
322 | _
-> option_default) in
324 let astfvrule_elem recursor k re
=
325 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
328 (match Ast.unwrap re
with
329 Ast.MetaRuleElem
(name
,TC.Saved
,_
) | Ast.MetaStmt
(name
,TC.Saved
,_
,_
)
330 | Ast.MetaStmtList
(name
,TC.Saved
,_
) -> [metaid name
]
331 | _
-> option_default)) in
337 Ast.MetaPos
(name
,_
,_
,TC.Saved
,_
) -> (metaid name
) :: acc
339 option_default (Ast.get_pos_var e
) in
341 V.combiner
bind option_default
342 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
343 donothing donothing donothing donothing donothing
344 astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
345 astfvdecls astfvrule_elem donothing donothing donothing donothing
347 (* ---------------------------------------------------------------- *)
349 (* For the rules under a given metavariable declaration, collect all of the
350 variables that occur in the plus code *)
352 let cip_mcodekind r mck
=
353 let process_anything_list_list anythings
=
354 let astfvs = collect_all_refs.V.combiner_anything
in
355 List.fold_left
(@) []
356 (List.map
(function l
-> List.fold_left
(@) [] (List.map
astfvs l
))
359 Ast.MINUS
(_
,_
,_
,replacement
) ->
360 (match replacement
with
361 Ast.REPLACEMENT
(anythings
,_
) -> process_anything_list_list anythings
362 | Ast.NOREPLACEMENT
-> [])
363 | Ast.CONTEXT
(_
,befaft
) ->
365 Ast.BEFORE
(ll
,_
) -> process_anything_list_list ll
366 | Ast.AFTER
(ll
,_
) -> process_anything_list_list ll
367 | Ast.BEFOREAFTER
(llb
,lla
,_
) ->
368 (process_anything_list_list lla
) @
369 (process_anything_list_list llb
)
374 let collect_fresh_seed_env metavars l
=
379 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
380 ((Ast.get_meta_name x
),seed
)::prev
383 let (seed_env
,seeds
) =
385 (function (seed_env
,seeds
) as prev
->
388 (let v = List.assoc x
fresh in
395 Ast.SeedId
(id
) -> id
::prev
398 ((x
,ids)::seed_env
,Common.union_set
ids seeds
)
399 | _
-> ((x
,[])::seed_env
,seeds
))
400 with Not_found
-> prev
)
402 (List.rev seed_env
,List.rev seeds
)
404 let collect_fresh_seed metavars l
=
405 let (_
,seeds
) = collect_fresh_seed_env metavars l
in seeds
407 let collect_in_plus_term =
409 let bind x y
= x
@ y
in
410 let option_default = [] in
411 let donothing r k e
= k e
in
413 (* no positions in the + code *)
414 let mcode r
(_
,_
,mck
,_
) = cip_mcodekind r mck
in
416 (* case for things with bef/aft mcode *)
418 let astfvrule_elem recursor k re
=
419 match Ast.unwrap re
with
420 Ast.FunHeader
(bef
,_
,fi
,nm
,_
,params
,_
) ->
425 Ast.FType
(ty
) -> collect_all_refs.V.combiner_fullType ty
428 let nm_metas = collect_all_refs.V.combiner_ident nm
in
430 match Ast.unwrap params
with
431 Ast.DOTS
(params
) | Ast.CIRCLES
(params
) ->
435 match Ast.unwrap p
with
436 Ast.VoidParam
(t
) | Ast.Param
(t
,_
) ->
437 collect_all_refs.V.combiner_fullType t
440 | _
-> failwith
"not allowed for params" in
444 (bind (cip_mcodekind recursor bef
) (k re
))))
445 | Ast.Decl
(bef
,_
,_
) ->
446 bind (cip_mcodekind recursor bef
) (k re
)
449 let astfvstatement recursor k s
=
450 match Ast.unwrap s
with
451 Ast.IfThen
(_
,_
,(_
,_
,_
,aft
)) | Ast.IfThenElse
(_
,_
,_
,_
,(_
,_
,_
,aft
))
452 | Ast.While
(_
,_
,(_
,_
,_
,aft
)) | Ast.For
(_
,_
,(_
,_
,_
,aft
))
453 | Ast.Iterator
(_
,_
,(_
,_
,_
,aft
)) ->
454 bind (k s
) (cip_mcodekind recursor aft
)
457 V.combiner
bind option_default
458 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
459 donothing donothing donothing donothing donothing
460 donothing donothing donothing donothing donothing donothing
461 donothing astfvrule_elem astfvstatement donothing donothing donothing
463 let collect_in_plus metavars minirules
=
465 (collect_fresh_seed metavars
467 (List.map
collect_in_plus_term.V.combiner_top_level minirules
)))
469 (* ---------------------------------------------------------------- *)
471 (* For the rules under a given metavariable declaration, collect all of the
472 variables that occur only once and more than once in the minus code *)
474 let collect_all_multirefs minirules
=
475 let refs = List.map
collect_all_refs.V.combiner_top_level minirules
in
476 collect_unitary_nonunitary (List.concat
refs)
478 (* ---------------------------------------------------------------- *)
480 (* classify as unitary (no binding) or nonunitary (env binding) or saved
483 let classify_variables metavar_decls minirules used_after
=
484 let metavars = List.map
Ast.get_meta_name metavar_decls
in
485 let (unitary,nonunitary) = collect_all_multirefs minirules
in
486 let inplus = collect_in_plus metavar_decls minirules
in
488 let donothing r k e
= k e
in
489 let check_unitary name inherited
=
490 if List.mem name
inplus or List.mem name used_after
492 else if not inherited
&& List.mem name
unitary
494 else TC.Nonunitary
in
496 let get_option f
= function Some x
-> Some
(f x
) | None
-> None
in
498 let classify (name
,_
,_
,_
) =
499 let inherited = not
(List.mem name
metavars) in
500 (check_unitary name
inherited,inherited) in
505 (function Ast.MetaPos
(name
,constraints
,per
,unitary,inherited) ->
506 let (unitary,inherited) = classify name
in
507 Ast.MetaPos
(name
,constraints
,per
,unitary,inherited))
508 (Ast.get_pos_var mc
) in
509 Ast.set_pos_var
p mc
in
513 match Ast.unwrap
e with
514 Ast.MetaId
(name
,constraints
,_
,_
) ->
515 let (unitary,inherited) = classify name
in
517 (Ast.MetaId
(name
,constraints
,unitary,inherited))
518 | Ast.MetaFunc
(name
,constraints
,_
,_
) ->
519 let (unitary,inherited) = classify name
in
520 Ast.rewrap
e (Ast.MetaFunc
(name
,constraints
,unitary,inherited))
521 | Ast.MetaLocalFunc
(name
,constraints
,_
,_
) ->
522 let (unitary,inherited) = classify name
in
523 Ast.rewrap
e (Ast.MetaLocalFunc
(name
,constraints
,unitary,inherited))
526 let rec type_infos = function
527 TC.ConstVol
(cv
,ty
) -> TC.ConstVol
(cv
,type_infos ty
)
528 | TC.Pointer
(ty
) -> TC.Pointer
(type_infos ty
)
529 | TC.FunctionPointer
(ty
) -> TC.FunctionPointer
(type_infos ty
)
530 | TC.Array
(ty
) -> TC.Array
(type_infos ty
)
531 | TC.EnumName
(TC.MV
(name
,_
,_
)) ->
532 let (unitary,inherited) = classify (name
,(),(),[]) in
533 TC.EnumName
(TC.MV
(name
,unitary,inherited))
534 | TC.StructUnionName
(su
,TC.MV
(name
,_
,_
)) ->
535 let (unitary,inherited) = classify (name
,(),(),[]) in
536 TC.StructUnionName
(su
,TC.MV
(name
,unitary,inherited))
537 | TC.MetaType
(name
,_
,_
) ->
538 let (unitary,inherited) = classify (name
,(),(),[]) in
539 Type_cocci.MetaType
(name
,unitary,inherited)
540 | TC.SignedT
(sgn
,Some ty
) -> TC.SignedT
(sgn
,Some
(type_infos ty
))
543 let expression r k
e =
545 match Ast.unwrap
e with
546 Ast.MetaErr
(name
,constraints
,_
,_
) ->
547 let (unitary,inherited) = classify name
in
548 Ast.rewrap
e (Ast.MetaErr
(name
,constraints
,unitary,inherited))
549 | Ast.MetaExpr
(name
,constraints
,_
,ty
,form
,_
) ->
550 let (unitary,inherited) = classify name
in
551 let ty = get_option (List.map
type_infos) ty in
552 Ast.rewrap
e (Ast.MetaExpr
(name
,constraints
,unitary,ty,form
,inherited))
553 | Ast.MetaExprList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
554 (* lenname should have the same properties of being unitary or
556 let (unitary,inherited) = classify name
in
557 let (lenunitary
,leninherited
) = classify lenname
in
561 Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
563 | Ast.MetaExprList
(name
,lenname
,_
,_
) ->
564 (* lenname should have the same properties of being unitary or
566 let (unitary,inherited) = classify name
in
567 Ast.rewrap
e (Ast.MetaExprList
(name
,lenname
,unitary,inherited))
572 match Ast.unwrap
e with
573 Ast.MetaType
(name
,_
,_
) ->
574 let (unitary,inherited) = classify name
in
575 Ast.rewrap
e (Ast.MetaType
(name
,unitary,inherited))
580 match Ast.unwrap
e with
581 Ast.MetaInit
(name
,_
,_
) ->
582 let (unitary,inherited) = classify name
in
583 Ast.rewrap
e (Ast.MetaInit
(name
,unitary,inherited))
584 | Ast.MetaInitList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
585 let (unitary,inherited) = classify name
in
586 let (lenunitary
,leninherited
) = classify lenname
in
589 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
591 | Ast.MetaInitList
(name
,lenname
,_
,_
) ->
592 let (unitary,inherited) = classify name
in
593 Ast.rewrap
e (Ast.MetaInitList
(name
,lenname
,unitary,inherited))
598 match Ast.unwrap
e with
599 Ast.MetaParam
(name
,_
,_
) ->
600 let (unitary,inherited) = classify name
in
601 Ast.rewrap
e (Ast.MetaParam
(name
,unitary,inherited))
602 | Ast.MetaParamList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
603 let (unitary,inherited) = classify name
in
604 let (lenunitary
,leninherited
) = classify lenname
in
607 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
609 | Ast.MetaParamList
(name
,lenname
,_
,_
) ->
610 let (unitary,inherited) = classify name
in
611 Ast.rewrap
e (Ast.MetaParamList
(name
,lenname
,unitary,inherited))
616 match Ast.unwrap
e with
617 Ast.MetaDecl
(name
,_
,_
) ->
618 let (unitary,inherited) = classify name
in
619 Ast.rewrap
e (Ast.MetaDecl
(name
,unitary,inherited))
620 | Ast.MetaField
(name
,_
,_
) ->
621 let (unitary,inherited) = classify name
in
622 Ast.rewrap
e (Ast.MetaField
(name
,unitary,inherited))
623 | Ast.MetaFieldList
(name
,Ast.MetaListLen
(lenname
,_
,_
),_
,_
) ->
624 let (unitary,inherited) = classify name
in
625 let (lenunitary
,leninherited
) = classify lenname
in
628 (name
,Ast.MetaListLen
(lenname
,lenunitary
,leninherited
),
630 | Ast.MetaFieldList
(name
,lenname
,_
,_
) ->
631 let (unitary,inherited) = classify name
in
632 Ast.rewrap
e (Ast.MetaFieldList
(name
,lenname
,unitary,inherited))
635 let rule_elem r k
e =
637 match Ast.unwrap
e with
638 Ast.MetaStmt
(name
,_
,msi
,_
) ->
639 let (unitary,inherited) = classify name
in
640 Ast.rewrap
e (Ast.MetaStmt
(name
,unitary,msi
,inherited))
641 | Ast.MetaStmtList
(name
,_
,_
) ->
642 let (unitary,inherited) = classify name
in
643 Ast.rewrap
e (Ast.MetaStmtList
(name
,unitary,inherited))
647 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
648 donothing donothing donothing donothing donothing
649 ident expression donothing typeC init param decl rule_elem
650 donothing donothing donothing donothing in
652 List.map
fn.V.rebuilder_top_level minirules
654 (* ---------------------------------------------------------------- *)
656 (* For a minirule, collect the set of non-local (not in "bound") variables that
657 are referenced. Store them in a hash table. *)
659 (* bound means the metavariable was declared previously, not locally *)
661 (* Highly inefficient, because we call collect_all_refs on nested code
662 multiple times. But we get the advantage of not having too many variants
663 of the same functions. *)
665 (* Inherited doesn't include position constraints. If they are not bound
666 then there is no constraint. *)
668 let astfvs metavars bound
=
673 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
674 ((Ast.get_meta_name x
),seed
)::prev
678 let collect_fresh l
=
679 let (matched
,freshvars
) =
681 (function (matched
,freshvars
) ->
683 try let v = List.assoc x
fresh in (matched
,(x
,v)::freshvars
)
684 with Not_found
-> (x
::matched
,freshvars
))
686 (List.rev matched
, List.rev freshvars
) in
688 (* cases for the elements of anything *)
689 let simple_setup getter k re
=
690 let minus_free = nub (getter
collect_all_refs re
) in
692 nub (getter
collect_non_constraint_refs re
) in
694 collect_fresh_seed metavars (getter
collect_in_plus_term re
) in
695 let free = Common.union_set
minus_free plus_free in
696 let nc_free = Common.union_set
minus_nc_free plus_free in
698 List.filter
(function x
-> not
(List.mem x bound
)) free in
700 List.filter
(function x
-> List.mem x bound
) nc_free in
702 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
703 let (matched
,fresh) = collect_fresh unbound in
705 Ast.free_vars
= matched
;
706 Ast.minus_free_vars
= munbound;
707 Ast.fresh_vars
= fresh;
708 Ast.inherited = inherited;
709 Ast.saved_witness
= []} in
711 let astfvrule_elem recursor k re
=
712 simple_setup (function x
-> x
.V.combiner_rule_elem
) k re
in
714 let astfvstatement recursor k s
=
715 let minus_free = nub (collect_all_refs.V.combiner_statement s
) in
717 nub (collect_non_constraint_refs.V.combiner_statement s
) in
719 collect_fresh_seed metavars
720 (collect_in_plus_term.V.combiner_statement s
) in
721 let free = Common.union_set
minus_free plus_free in
722 let nc_free = Common.union_set
minus_nc_free plus_free in
723 let classify free minus_free =
724 let (unbound,inherited) =
725 List.partition
(function x
-> not
(List.mem x bound
)) free in
727 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
728 let (matched
,fresh) = collect_fresh unbound in
729 (matched
,munbound,fresh,inherited) in
733 collect_fresh_seed metavars
734 (cip_mcodekind collect_in_plus_term aft
) in
735 match Ast.unwrap
res with
736 Ast.IfThen
(header
,branch
,(_
,_
,_
,aft
)) ->
737 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
738 Ast.IfThen
(header
,branch
,(unbound,fresh,inherited,aft
))
739 | Ast.IfThenElse
(header
,branch1
,els
,branch2
,(_
,_
,_
,aft
)) ->
740 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
741 Ast.IfThenElse
(header
,branch1
,els
,branch2
,
742 (unbound,fresh,inherited,aft
))
743 | Ast.While
(header
,body
,(_
,_
,_
,aft
)) ->
744 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
745 Ast.While
(header
,body
,(unbound,fresh,inherited,aft
))
746 | Ast.For
(header
,body
,(_
,_
,_
,aft
)) ->
747 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
748 Ast.For
(header
,body
,(unbound,fresh,inherited,aft
))
749 | Ast.Iterator
(header
,body
,(_
,_
,_
,aft
)) ->
750 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
751 Ast.Iterator
(header
,body
,(unbound,fresh,inherited,aft
))
754 let (matched
,munbound,fresh,_
) = classify free minus_free in
756 List.filter
(function x
-> List.mem x bound
) nc_free in
759 Ast.free_vars
= matched
;
760 Ast.minus_free_vars
= munbound;
761 Ast.fresh_vars
= fresh;
762 Ast.inherited = inherited;
763 Ast.saved_witness
= []} in
765 let astfvstatement_dots recursor k sd
=
766 simple_setup (function x
-> x
.V.combiner_statement_dots
) k sd
in
768 let astfvcase_line recursor k cl
=
769 simple_setup (function x
-> x
.V.combiner_case_line
) k cl
in
771 let astfvtoplevel recursor k tl
=
772 let saved = collect_saved.V.combiner_top_level tl
in
773 {(k tl
) with Ast.saved_witness
= saved} in
776 let donothing r k
e = k
e in
779 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
780 donothing donothing astfvstatement_dots donothing donothing
781 donothing donothing donothing donothing donothing donothing donothing
782 astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
785 let collect_astfvs rules =
786 let rec loop bound = function
788 | (metavars,(nm,rule_info,minirules))::rules ->
790 Common.minus_set bound (List.map Ast.get_meta_name metavars) in
792 (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
793 (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
797 let collect_astfvs rules
=
798 let rec loop bound = function
800 | (metavars, rule
)::rules
->
802 Ast.ScriptRule
(_
,_
,_
,_
,script_vars
,_
) ->
803 (* why are metavars in rule, but outside for cocci rule??? *)
804 let bound = script_vars
@ bound in
805 rule
::(loop bound rules
)
806 | Ast.InitialScriptRule
(_
,_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
,_
) ->
807 (* bound stays as is because script rules have no names, so no
808 inheritance is possible *)
809 rule
::(loop bound rules
)
810 | Ast.CocciRule
(nm
, rule_info
, minirules
, isexp
, ruletype
) ->
812 Common.minus_set
bound (List.map
Ast.get_meta_name
metavars) in
815 (List.map
(astfvs metavars bound).V.rebuilder_top_level
818 (loop ((List.map
Ast.get_meta_name
metavars)@bound) rules
) in
821 (* ---------------------------------------------------------------- *)
822 (* position variables that appear as a constraint on another position variable.
823 a position variable also cannot appear both positively and negatively in a
826 let get_neg_pos_list (_
,rule
) used_after_list
=
827 let donothing r k
e = k
e in
828 let bind (p1
,np1
) (p2
,np2
) =
829 (Common.union_set p1 p2
, Common.union_set np1 np2
) in
830 let option_default = ([],[]) in
831 let metaid (x
,_
,_
,_
) = x
in
836 Ast.MetaPos
(name
,constraints
,Ast.PER
,_
,_
) ->
837 ((metaid name
)::a
,constraints
@b
)
838 | Ast.MetaPos
(name
,constraints
,Ast.ALL
,_
,_
) ->
839 (a
,(metaid name
)::constraints
@b
)))
840 option_default (Ast.get_pos_var mc
) in
842 V.combiner
bind option_default
843 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
844 donothing donothing donothing donothing donothing
845 donothing donothing donothing donothing donothing donothing
846 donothing donothing donothing donothing donothing donothing in
848 Ast.CocciRule
(_
,_
,minirules
,_
,_
) ->
850 (function toplevel
->
851 let (positions
,neg_positions
) = v.V.combiner_top_level toplevel
in
852 (if List.exists
(function p -> List.mem
p neg_positions
) positions
855 "a variable cannot be used both as a position and a constraint");
858 | Ast.ScriptRule _
| Ast.InitialScriptRule _
| Ast.FinalScriptRule _
->
859 (*no negated positions*) []
861 (* ---------------------------------------------------------------- *)
863 (* collect used after lists, per minirule *)
865 (* defined is a list of variables that were declared in a previous metavar
868 (* Top-level used after: For each rule collect the set of variables that
869 are inherited, ie used but not defined. These are accumulated back to
870 their point of definition. *)
873 let collect_top_level_used_after metavar_rule_list
=
874 let drop_virt = List.filter
(function ("virtual",_
) -> false | _
-> true) in
875 let (used_after
,used_after_lists
) =
877 (function (metavar_list
,r
) ->
878 function (used_after
,used_after_lists
) ->
879 let locally_defined =
881 Ast.ScriptRule
(_
,_
,_
,_
,free_vars
,_
) -> free_vars
882 | _
-> List.map
Ast.get_meta_name metavar_list
in
883 let continue_propagation =
884 List.filter
(function x
-> not
(List.mem x
locally_defined))
888 Ast.ScriptRule
(_
,_
,_
,mv
,_
,_
) ->
889 drop_virt(List.map
(function (_
,(r
,v),_
) -> (r
,v)) mv
)
890 | Ast.InitialScriptRule
(_
,_
,_
,_
)
891 | Ast.FinalScriptRule
(_
,_
,_
,_
) -> []
892 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
894 (Common.union_set
(nub (collect_all_rule_refs rule
))
895 (collect_in_plus metavar_list rule
)) in
897 List.filter
(function x
-> not
(List.mem x
locally_defined))
899 (Common.union_set
inherited continue_propagation,
900 used_after
::used_after_lists
))
901 metavar_rule_list
([],[]) in
902 match used_after
with
903 [] -> used_after_lists
906 (Printf.sprintf
"collect_top_level_used_after: unbound variables %s"
907 (String.concat
" " (List.map
(function (_
,x
) -> x
) used_after
)))
909 let collect_local_used_after metavars minirules used_after
=
910 let locally_defined = List.map
Ast.get_meta_name
metavars in
911 let rec loop = function
912 [] -> (used_after
,[],[],[],[])
914 (* In a rule there are three kinds of local variables:
915 1. Variables referenced in the minus or context code.
916 These get a value by matching. This value can be used in
918 2. Fresh variables referenced in the plus code.
919 3. Variables referenced in the seeds of the fresh variables.
920 There are also non-local variables. These may either be variables
921 referenced in the minus, context, or plus code, or they may be
922 variables referenced in the seeds of the fresh variables. *)
923 (* Step 1: collect all references in minus/context, plus, seed
925 let variables_referenced_in_minus_context_code =
926 nub (collect_all_minirule_refs minirule
) in
927 let variables_referenced_in_plus_code =
928 collect_in_plus_term.V.combiner_top_level minirule
in
929 let (env_of_fresh_seeds
,seeds_and_plus
) =
930 collect_fresh_seed_env
931 metavars variables_referenced_in_plus_code in
933 Common.union_set
variables_referenced_in_minus_context_code
935 (* Step 2: identify locally defined ones *)
936 let local_fresh = List.map fst env_of_fresh_seeds
in
938 List.partition
(function x
-> List.mem x
locally_defined) in
939 let local_env_of_fresh_seeds =
940 (* these have to be restricted to only one value if the associated
941 fresh variable is used after *)
942 List.map
(function (f
,ss
) -> (f
,is_local ss
)) env_of_fresh_seeds
in
943 let (local_all_free_vars
,nonlocal_all_free_vars
) =
944 is_local all_free_vars in
945 (* Step 3, recurse on the rest of the rules, making available whatever
946 has been defined in this one *)
947 let (mini_used_after
,fvs_lists
,mini_used_after_lists
,
948 mini_fresh_used_after_lists
,mini_fresh_used_after_seeds
) =
950 (* Step 4: collect the results. These are:
951 1. All of the variables used non-locally in the rules starting
953 2. All of the free variables to the end of the semantic patch
954 3. The variables that are used afterwards and defined here by
955 matching (minus or context code)
956 4. The variables that are used afterwards and are defined here as
958 5. The variables that are used as seeds in computing the bindings
959 of the variables collected in part 4. *)
960 let (local_used_after
, nonlocal_used_after
) =
961 is_local mini_used_after
in
962 let (fresh_local_used_after
(*4*),matched_local_used_after
) =
963 List.partition
(function x
-> List.mem x
local_fresh)
965 let matched_local_used_after(*3*) =
966 Common.union_set
matched_local_used_after nonlocal_used_after
in
967 let new_used_after = (*1*)
968 Common.union_set nonlocal_all_free_vars nonlocal_used_after
in
969 let fresh_local_used_after_seeds =
971 (* no point to keep variables that already are gtd to have only
973 (function x
-> not
(List.mem x
matched_local_used_after))
974 (List.fold_left
(function p -> function c
-> Common.union_set c
p)
978 fst
(List.assoc fua
local_env_of_fresh_seeds))
979 fresh_local_used_after
)) in
980 (new_used_after,all_free_vars::fvs_lists
(*2*),
981 matched_local_used_after::mini_used_after_lists
,
982 fresh_local_used_after
::mini_fresh_used_after_lists
,
983 fresh_local_used_after_seeds::mini_fresh_used_after_seeds
) in
984 let (_
,fvs_lists
,used_after_lists
(*ua*),
985 fresh_used_after_lists
(*fua*),fresh_used_after_lists_seeds
(*fuas*)) =
987 (fvs_lists
,used_after_lists
,
988 fresh_used_after_lists
,fresh_used_after_lists_seeds
)
992 let collect_used_after metavar_rule_list
=
993 let used_after_lists = collect_top_level_used_after metavar_rule_list
in
995 (function (metavars,r
) ->
996 function used_after
->
998 Ast.ScriptRule
(_
,_
,_
,_
,_
,_
) (* no minirules, so nothing to do? *)
999 | Ast.InitialScriptRule
(_
,_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
,_
) ->
1000 ([], [used_after
], [[]], [])
1001 | Ast.CocciRule
(name
, rule_info
, minirules
, _
,_
) ->
1002 collect_local_used_after metavars minirules used_after
1004 metavar_rule_list
used_after_lists
1006 let rec split4 = function
1008 | (a
,b
,c
,d
)::l
-> let (a1
,b1
,c1
,d1
) = split4 l
in (a
::a1
,b
::b1
,c
::c1
,d
::d1
)
1010 (* ---------------------------------------------------------------- *)
1013 let free_vars rules
=
1014 let metavars = List.map
(function (mv
,rule
) -> mv
) rules
in
1015 let (fvs_lists
,used_after_matched_lists
,
1016 fresh_used_after_lists
,fresh_used_after_lists_seeds
) =
1017 split4 (collect_used_after rules
) in
1019 List.map2
get_neg_pos_list rules used_after_matched_lists
in
1020 let positions_list = (* for all rules, assume all positions are used after *)
1022 (function (mv
, r
) ->
1024 Ast.ScriptRule _
(* doesn't declare position variables *)
1025 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> []
1026 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
1030 function Ast.MetaPosDecl
(_
,nm
) -> nm
::prev
| _
-> prev
)
1032 List.map
(function _
-> positions) rule
)
1037 function (ua
,fua
) ->
1040 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> r
1041 | Ast.CocciRule
(nm
, rule_info
, r
, is_exp
,ruletype
) ->
1044 classify_variables mv r
1045 ((List.concat ua
) @ (List.concat fua
)),
1047 rules
(List.combine used_after_matched_lists fresh_used_after_lists
) in
1048 let new_rules = collect_astfvs (List.combine
metavars new_rules) in
1049 (metavars,new_rules,
1050 fvs_lists
,neg_pos_lists,
1051 (used_after_matched_lists
,
1052 fresh_used_after_lists
,fresh_used_after_lists_seeds
),