2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
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.
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.
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/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
24 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
25 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
26 * This file is part of Coccinelle.
28 * Coccinelle is free software: you can redistribute it and/or modify
29 * it under the terms of the GNU General Public License as published by
30 * the Free Software Foundation, according to version 2 of the License.
32 * Coccinelle is distributed in the hope that it will be useful,
33 * but WITHOUT ANY WARRANTY; without even the implied warranty of
34 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 * GNU General Public License for more details.
37 * You should have received a copy of the GNU General Public License
38 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
40 * The authors reserve the right to distribute this or future versions of
41 * Coccinelle under other licenses.
45 (* For each rule return the list of variables that are used after it.
46 Also augment various parts of each rule with unitary, inherited, and freshness
49 (* metavar decls should be better integrated into computations of free
50 variables in plus code *)
52 module Ast
= Ast_cocci
53 module V
= Visitor_ast
54 module TC
= Type_cocci
56 let rec nub = function
58 | (x
::xs
) when (List.mem x xs
) -> nub xs
59 | (x
::xs
) -> x
::(nub xs
)
61 (* Collect all variable references in a minirule. For a disj, we collect
62 the maximum number (2 is enough) of references in any branch. *)
64 let collect_unitary_nonunitary free_usage
=
65 let free_usage = List.sort compare
free_usage in
66 let rec loop1 todrop
= function (* skips multiple occurrences *)
68 | (x
::xs
) as all
-> if x
= todrop
then loop1 todrop xs
else all
in
69 let rec loop2 = function
73 if x
= y
(* occurs more than once in free_usage *)
75 let (unitary
,non_unitary
) = loop2(loop1 x xs
) in
76 (unitary
,x
::non_unitary
)
77 else (* occurs only once in free_usage *)
78 let (unitary
,non_unitary
) = loop2 (y
::xs
) in
79 (x
::unitary
,non_unitary
) in
82 let collect_refs include_constraints
=
83 let bind x y
= x
@ y
in
84 let option_default = [] in
86 let donothing recursor k e
= k e
in (* just combine in the normal way *)
88 let donothing_a recursor k e
= (* anything is not wrapped *)
89 k e
in (* just combine in the normal way *)
91 (* the following considers that anything that occurs non-unitarily in one
92 branch occurs nonunitarily in all branches. This is not optimal, but
93 doing better seems to require a breadth-first traversal, which is
94 perhaps better to avoid. Also, unitarily is represented as occuring once,
95 while nonunitarily is represented as twice - more is irrelevant *)
96 (* cases for disjs and metavars *)
97 let bind_disj refs_branches
=
98 let (unitary
,nonunitary
) =
99 List.split
(List.map
collect_unitary_nonunitary refs_branches
) in
100 let unitary = nub (List.concat
unitary) in
101 let nonunitary = nub (List.concat
nonunitary) in
103 List.filter
(function x
-> not
(List.mem x
nonunitary)) unitary in
104 unitary@nonunitary@nonunitary in
106 let metaid (x
,_
,_
,_
) = x
in
108 let astfvident recursor k i
=
110 (match Ast.unwrap i
with
111 Ast.MetaId
(name
,idconstraint
,_
,_
) | Ast.MetaFunc
(name
,idconstraint
,_
,_
)
112 | Ast.MetaLocalFunc
(name
,idconstraint
,_
,_
) ->
114 if include_constraints
116 match idconstraint
with
117 Ast.IdNegIdSet
(_
,metas) -> metas
120 bind (List.rev
metas) [metaid name
]
121 | _
-> option_default) in
123 let rec type_collect res
= function
124 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
125 | TC.Array
(ty
) -> type_collect res ty
126 | TC.MetaType
(tyname
,_
,_
) ->
128 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
131 let astfvexpr recursor k e
=
133 (match Ast.unwrap e
with
134 Ast.MetaExpr
(name
,constraints
,_
,Some type_list
,_
,_
) ->
135 let types = List.fold_left
type_collect option_default type_list
in
137 if include_constraints
139 match constraints
with
140 Ast.SubExpCstrt l
-> l
143 bind extra (bind [metaid name
] types)
144 | Ast.MetaErr
(name
,constraints
,_
,_
)
145 | Ast.MetaExpr
(name
,constraints
,_
,_
,_
,_
) ->
147 if include_constraints
149 match constraints
with
150 Ast.SubExpCstrt l
-> l
153 bind extra [metaid name
]
154 | Ast.MetaExprList
(name
,None
,_
,_
) -> [metaid name
]
155 | Ast.MetaExprList
(name
,Some
(lenname
,_
,_
),_
,_
) ->
156 [metaid name
;metaid lenname
]
157 | Ast.DisjExpr
(exps
) -> bind_disj (List.map k exps
)
158 | _
-> option_default) in
160 let astfvdecls recursor k d
=
162 (match Ast.unwrap d
with
163 Ast.DisjDecl
(decls
) -> bind_disj (List.map k decls
)
164 | _
-> option_default) in
166 let astfvfullType recursor k ty
=
168 (match Ast.unwrap ty
with
169 Ast.DisjType
(types) -> bind_disj (List.map k
types)
170 | _
-> option_default) in
172 let astfvtypeC recursor k ty
=
174 (match Ast.unwrap ty
with
175 Ast.MetaType
(name
,_
,_
) -> [metaid name
]
176 | _
-> option_default) in
178 let astfvinit recursor k ty
=
180 (match Ast.unwrap ty
with
181 Ast.MetaInit
(name
,_
,_
) -> [metaid name
]
182 | _
-> option_default) in
184 let astfvparam recursor k p
=
186 (match Ast.unwrap p
with
187 Ast.MetaParam
(name
,_
,_
) -> [metaid name
]
188 | Ast.MetaParamList
(name
,None
,_
,_
) -> [metaid name
]
189 | Ast.MetaParamList
(name
,Some
(lenname
,_
,_
),_
,_
) ->
190 [metaid name
;metaid lenname
]
191 | _
-> option_default) in
193 let astfvrule_elem recursor k re
=
194 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
197 (match Ast.unwrap re
with
198 Ast.MetaRuleElem
(name
,_
,_
) | Ast.MetaStmt
(name
,_
,_
,_
)
199 | Ast.MetaStmtList
(name
,_
,_
) -> [metaid name
]
200 | _
-> option_default)) in
202 let astfvstatement recursor k s
=
204 (match Ast.unwrap s
with
206 bind_disj (List.map recursor
.V.combiner_statement_dots stms
)
207 | _
-> option_default) in
210 if include_constraints
212 match Ast.get_pos_var mc
with
213 Ast.MetaPos
(name
,constraints
,_
,_
,_
) -> (metaid name
)::constraints
214 | _
-> option_default
215 else option_default in
217 V.combiner
bind option_default
218 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
219 donothing donothing donothing donothing
220 astfvident astfvexpr astfvfullType astfvtypeC astfvinit astfvparam
221 astfvdecls astfvrule_elem astfvstatement donothing donothing donothing_a
223 let collect_all_refs = collect_refs true
224 let collect_non_constraint_refs = collect_refs false
226 let collect_all_rule_refs minirules
=
227 List.fold_left
(@) []
228 (List.map
collect_all_refs.V.combiner_top_level minirules
)
230 let collect_all_minirule_refs = collect_all_refs.V.combiner_top_level
232 (* ---------------------------------------------------------------- *)
235 let bind = Common.union_set
in
236 let option_default = [] in
238 let donothing recursor k e
= k e
in (* just combine in the normal way *)
240 let metaid (x
,_
,_
,_
) = x
in
242 (* cases for metavariables *)
243 let astfvident recursor k i
=
245 (match Ast.unwrap i
with
246 Ast.MetaId
(name
,_
,TC.Saved
,_
)
247 | Ast.MetaFunc
(name
,_
,TC.Saved
,_
)
248 | Ast.MetaLocalFunc
(name
,_
,TC.Saved
,_
) ->
250 | _
-> option_default) in
252 let rec type_collect res
= function
253 TC.ConstVol
(_
,ty
) | TC.Pointer
(ty
) | TC.FunctionPointer
(ty
)
254 | TC.Array
(ty
) -> type_collect res ty
255 | TC.MetaType
(tyname
,TC.Saved
,_
) ->
257 | TC.SignedT
(_
,Some ty
) -> type_collect res ty
260 let astfvexpr recursor k e
=
262 match Ast.unwrap e
with
263 Ast.MetaExpr
(name
,_
,_
,Some type_list
,_
,_
) ->
264 List.fold_left
type_collect option_default type_list
268 (match Ast.unwrap e
with
269 Ast.MetaErr
(name
,_
,TC.Saved
,_
) | Ast.MetaExpr
(name
,_
,TC.Saved
,_
,_
,_
)
270 | Ast.MetaExprList
(name
,None
,TC.Saved
,_
) -> [metaid name
]
271 | Ast.MetaExprList
(name
,Some
(lenname
,ls
,_
),ns
,_
) ->
273 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
275 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
277 | _
-> option_default) in
280 let astfvtypeC recursor k ty
=
282 (match Ast.unwrap ty
with
283 Ast.MetaType
(name
,TC.Saved
,_
) -> [metaid name
]
284 | _
-> option_default) in
286 let astfvinit recursor k ty
=
288 (match Ast.unwrap ty
with
289 Ast.MetaInit
(name
,TC.Saved
,_
) -> [metaid name
]
290 | _
-> option_default) in
292 let astfvparam recursor k p
=
294 (match Ast.unwrap p
with
295 Ast.MetaParam
(name
,TC.Saved
,_
)
296 | Ast.MetaParamList
(name
,None
,_
,_
) -> [metaid name
]
297 | Ast.MetaParamList
(name
,Some
(lenname
,ls
,_
),ns
,_
) ->
299 match ns
with TC.Saved
-> [metaid name
] | _
-> [] in
301 match ls
with TC.Saved
-> [metaid lenname
] | _
-> [] in
303 | _
-> option_default) in
305 let astfvrule_elem recursor k re
=
306 (*within a rule_elem, pattern3 manages the coherence of the bindings*)
309 (match Ast.unwrap re
with
310 Ast.MetaRuleElem
(name
,TC.Saved
,_
) | Ast.MetaStmt
(name
,TC.Saved
,_
,_
)
311 | Ast.MetaStmtList
(name
,TC.Saved
,_
) -> [metaid name
]
312 | _
-> option_default)) in
315 match Ast.get_pos_var e
with
316 Ast.MetaPos
(name
,_
,_
,TC.Saved
,_
) -> [metaid name
]
317 | _
-> option_default in
319 V.combiner
bind option_default
320 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
321 donothing donothing donothing donothing
322 astfvident astfvexpr donothing astfvtypeC astfvinit astfvparam
323 donothing astfvrule_elem donothing donothing donothing donothing
325 (* ---------------------------------------------------------------- *)
327 (* For the rules under a given metavariable declaration, collect all of the
328 variables that occur in the plus code *)
330 let cip_mcodekind r mck
=
331 let process_anything_list_list anythings
=
332 let astfvs = collect_all_refs.V.combiner_anything
in
333 List.fold_left
(@) []
334 (List.map
(function l
-> List.fold_left
(@) [] (List.map
astfvs l
))
337 Ast.MINUS
(_
,_
,_
,anythings
) -> process_anything_list_list anythings
338 | Ast.CONTEXT
(_
,befaft
) ->
340 Ast.BEFORE
(ll
,_
) -> process_anything_list_list ll
341 | Ast.AFTER
(ll
,_
) -> process_anything_list_list ll
342 | Ast.BEFOREAFTER
(llb
,lla
,_
) ->
343 (process_anything_list_list lla
) @
344 (process_anything_list_list llb
)
349 let collect_fresh_seed_env metavars l
=
354 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
355 ((Ast.get_meta_name x
),seed
)::prev
358 let (seed_env
,seeds
) =
360 (function (seed_env
,seeds
) as prev
->
363 (let v = List.assoc x
fresh in
370 Ast.SeedId
(id
) -> id
::prev
373 ((x
,ids)::seed_env
,Common.union_set
ids seeds
)
374 | _
-> ((x
,[])::seed_env
,seeds
))
375 with Not_found
-> prev
)
377 (List.rev seed_env
,List.rev seeds
)
379 let collect_fresh_seed metavars l
=
380 let (_
,seeds
) = collect_fresh_seed_env metavars l
in seeds
382 let collect_in_plus_term =
384 let bind x y
= x
@ y
in
385 let option_default = [] in
386 let donothing r k e
= k e
in
388 (* no positions in the + code *)
389 let mcode r
(_
,_
,mck
,_
) = cip_mcodekind r mck
in
391 (* case for things with bef/aft mcode *)
393 let astfvrule_elem recursor k re
=
394 match Ast.unwrap re
with
395 Ast.FunHeader
(bef
,_
,fi
,nm
,_
,params
,_
) ->
400 Ast.FType
(ty
) -> collect_all_refs.V.combiner_fullType ty
403 let nm_metas = collect_all_refs.V.combiner_ident nm
in
405 match Ast.unwrap params
with
406 Ast.DOTS
(params
) | Ast.CIRCLES
(params
) ->
410 match Ast.unwrap p
with
411 Ast.VoidParam
(t
) | Ast.Param
(t
,_
) ->
412 collect_all_refs.V.combiner_fullType t
415 | _
-> failwith
"not allowed for params" in
419 (bind (cip_mcodekind recursor bef
) (k re
))))
420 | Ast.Decl
(bef
,_
,_
) ->
421 bind (cip_mcodekind recursor bef
) (k re
)
424 let astfvstatement recursor k s
=
425 match Ast.unwrap s
with
426 Ast.IfThen
(_
,_
,(_
,_
,_
,aft
)) | Ast.IfThenElse
(_
,_
,_
,_
,(_
,_
,_
,aft
))
427 | Ast.While
(_
,_
,(_
,_
,_
,aft
)) | Ast.For
(_
,_
,(_
,_
,_
,aft
))
428 | Ast.Iterator
(_
,_
,(_
,_
,_
,aft
)) ->
429 bind (k s
) (cip_mcodekind recursor aft
)
432 V.combiner
bind option_default
433 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
434 donothing donothing donothing donothing
435 donothing donothing donothing donothing donothing donothing
436 donothing astfvrule_elem astfvstatement donothing donothing donothing
438 let collect_in_plus metavars minirules
=
440 (collect_fresh_seed metavars
442 (List.map
collect_in_plus_term.V.combiner_top_level minirules
)))
444 (* ---------------------------------------------------------------- *)
446 (* For the rules under a given metavariable declaration, collect all of the
447 variables that occur only once and more than once in the minus code *)
449 let collect_all_multirefs minirules
=
450 let refs = List.map
collect_all_refs.V.combiner_top_level minirules
in
451 collect_unitary_nonunitary (List.concat
refs)
453 (* ---------------------------------------------------------------- *)
455 (* classify as unitary (no binding) or nonunitary (env binding) or saved
458 let classify_variables metavar_decls minirules used_after
=
459 let metavars = List.map
Ast.get_meta_name metavar_decls
in
460 let (unitary,nonunitary) = collect_all_multirefs minirules
in
461 let inplus = collect_in_plus metavar_decls minirules
in
463 let donothing r k e
= k e
in
464 let check_unitary name inherited
=
465 if List.mem name
inplus or List.mem name used_after
467 else if not inherited
&& List.mem name
unitary
469 else TC.Nonunitary
in
471 let get_option f
= function Some x
-> Some
(f x
) | None
-> None
in
473 let classify (name
,_
,_
,_
) =
474 let inherited = not
(List.mem name
metavars) in
475 (check_unitary name
inherited,inherited) in
478 match Ast.get_pos_var mc
with
479 Ast.MetaPos
(name
,constraints
,per
,unitary,inherited) ->
480 let (unitary,inherited) = classify name
in
481 Ast.set_pos_var
(Ast.MetaPos
(name
,constraints
,per
,unitary,inherited))
487 match Ast.unwrap
e with
488 Ast.MetaId
(name
,constraints
,_
,_
) ->
489 let (unitary,inherited) = classify name
in
491 (Ast.MetaId
(name
,constraints
,unitary,inherited))
492 | Ast.MetaFunc
(name
,constraints
,_
,_
) ->
493 let (unitary,inherited) = classify name
in
494 Ast.rewrap
e (Ast.MetaFunc
(name
,constraints
,unitary,inherited))
495 | Ast.MetaLocalFunc
(name
,constraints
,_
,_
) ->
496 let (unitary,inherited) = classify name
in
497 Ast.rewrap
e (Ast.MetaLocalFunc
(name
,constraints
,unitary,inherited))
500 let rec type_infos = function
501 TC.ConstVol
(cv
,ty
) -> TC.ConstVol
(cv
,type_infos ty
)
502 | TC.Pointer
(ty
) -> TC.Pointer
(type_infos ty
)
503 | TC.FunctionPointer
(ty
) -> TC.FunctionPointer
(type_infos ty
)
504 | TC.Array
(ty
) -> TC.Array
(type_infos ty
)
505 | TC.MetaType
(name
,_
,_
) ->
506 let (unitary,inherited) = classify (name
,(),(),Ast.NoMetaPos
) in
507 Type_cocci.MetaType
(name
,unitary,inherited)
508 | TC.SignedT
(sgn
,Some ty
) -> TC.SignedT
(sgn
,Some
(type_infos ty
))
511 let expression r k
e =
513 match Ast.unwrap
e with
514 Ast.MetaErr
(name
,constraints
,_
,_
) ->
515 let (unitary,inherited) = classify name
in
516 Ast.rewrap
e (Ast.MetaErr
(name
,constraints
,unitary,inherited))
517 | Ast.MetaExpr
(name
,constraints
,_
,ty
,form
,_
) ->
518 let (unitary,inherited) = classify name
in
519 let ty = get_option (List.map
type_infos) ty in
520 Ast.rewrap
e (Ast.MetaExpr
(name
,constraints
,unitary,ty,form
,inherited))
521 | Ast.MetaExprList
(name
,None
,_
,_
) ->
522 (* lenname should have the same properties of being unitary or
524 let (unitary,inherited) = classify name
in
525 Ast.rewrap
e (Ast.MetaExprList
(name
,None
,unitary,inherited))
526 | Ast.MetaExprList
(name
,Some
(lenname
,_
,_
),_
,_
) ->
527 (* lenname should have the same properties of being unitary or
529 let (unitary,inherited) = classify name
in
530 let (lenunitary
,leninherited
) = classify lenname
in
533 (name
,Some
(lenname
,lenunitary
,leninherited
),unitary,inherited))
538 match Ast.unwrap
e with
539 Ast.MetaType
(name
,_
,_
) ->
540 let (unitary,inherited) = classify name
in
541 Ast.rewrap
e (Ast.MetaType
(name
,unitary,inherited))
546 match Ast.unwrap
e with
547 Ast.MetaInit
(name
,_
,_
) ->
548 let (unitary,inherited) = classify name
in
549 Ast.rewrap
e (Ast.MetaInit
(name
,unitary,inherited))
554 match Ast.unwrap
e with
555 Ast.MetaParam
(name
,_
,_
) ->
556 let (unitary,inherited) = classify name
in
557 Ast.rewrap
e (Ast.MetaParam
(name
,unitary,inherited))
558 | Ast.MetaParamList
(name
,None
,_
,_
) ->
559 let (unitary,inherited) = classify name
in
560 Ast.rewrap
e (Ast.MetaParamList
(name
,None
,unitary,inherited))
561 | Ast.MetaParamList
(name
,Some
(lenname
,_
,_
),_
,_
) ->
562 let (unitary,inherited) = classify name
in
563 let (lenunitary
,leninherited
) = classify lenname
in
566 (name
,Some
(lenname
,lenunitary
,leninherited
),unitary,inherited))
569 let rule_elem r k
e =
571 match Ast.unwrap
e with
572 Ast.MetaStmt
(name
,_
,msi
,_
) ->
573 let (unitary,inherited) = classify name
in
574 Ast.rewrap
e (Ast.MetaStmt
(name
,unitary,msi
,inherited))
575 | Ast.MetaStmtList
(name
,_
,_
) ->
576 let (unitary,inherited) = classify name
in
577 Ast.rewrap
e (Ast.MetaStmtList
(name
,unitary,inherited))
581 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
582 donothing donothing donothing donothing
583 ident expression donothing typeC init param donothing rule_elem
584 donothing donothing donothing donothing in
586 List.map
fn.V.rebuilder_top_level minirules
588 (* ---------------------------------------------------------------- *)
590 (* For a minirule, collect the set of non-local (not in "bound") variables that
591 are referenced. Store them in a hash table. *)
593 (* bound means the metavariable was declared previously, not locally *)
595 (* Highly inefficient, because we call collect_all_refs on nested code
596 multiple times. But we get the advantage of not having too many variants
597 of the same functions. *)
599 (* Inherited doesn't include position constraints. If they are not bound
600 then there is no constraint. *)
602 let astfvs metavars bound
=
607 Ast.MetaFreshIdDecl
(_
,seed
) as x
->
608 ((Ast.get_meta_name x
),seed
)::prev
612 let collect_fresh l
=
613 let (matched
,freshvars
) =
615 (function (matched
,freshvars
) ->
617 try let v = List.assoc x
fresh in (matched
,(x
,v)::freshvars
)
618 with Not_found
-> (x
::matched
,freshvars
))
620 (List.rev matched
, List.rev freshvars
) in
622 (* cases for the elements of anything *)
623 let simple_setup getter k re
=
624 let minus_free = nub (getter
collect_all_refs re
) in
626 nub (getter
collect_non_constraint_refs re
) in
628 collect_fresh_seed metavars (getter
collect_in_plus_term re
) in
629 let free = Common.union_set
minus_free plus_free in
630 let nc_free = Common.union_set
minus_nc_free plus_free in
632 List.filter
(function x
-> not
(List.mem x bound
)) free in
634 List.filter
(function x
-> List.mem x bound
) nc_free in
636 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
637 let (matched
,fresh) = collect_fresh unbound in
639 Ast.free_vars
= matched
;
640 Ast.minus_free_vars
= munbound;
641 Ast.fresh_vars
= fresh;
642 Ast.inherited = inherited;
643 Ast.saved_witness
= []} in
645 let astfvrule_elem recursor k re
=
646 simple_setup (function x
-> x
.V.combiner_rule_elem
) k re
in
648 let astfvstatement recursor k s
=
649 let minus_free = nub (collect_all_refs.V.combiner_statement s
) in
651 nub (collect_non_constraint_refs.V.combiner_statement s
) in
653 collect_fresh_seed metavars
654 (collect_in_plus_term.V.combiner_statement s
) in
655 let free = Common.union_set
minus_free plus_free in
656 let nc_free = Common.union_set
minus_nc_free plus_free in
657 let classify free minus_free =
658 let (unbound,inherited) =
659 List.partition
(function x
-> not
(List.mem x bound
)) free in
661 List.filter
(function x
-> not
(List.mem x bound
)) minus_free in
662 let (matched
,fresh) = collect_fresh unbound in
663 (matched
,munbound,fresh,inherited) in
667 collect_fresh_seed metavars
668 (cip_mcodekind collect_in_plus_term aft
) in
669 match Ast.unwrap
res with
670 Ast.IfThen
(header
,branch
,(_
,_
,_
,aft
)) ->
671 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
672 Ast.IfThen
(header
,branch
,(unbound,fresh,inherited,aft
))
673 | Ast.IfThenElse
(header
,branch1
,els
,branch2
,(_
,_
,_
,aft
)) ->
674 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
675 Ast.IfThenElse
(header
,branch1
,els
,branch2
,
676 (unbound,fresh,inherited,aft
))
677 | Ast.While
(header
,body
,(_
,_
,_
,aft
)) ->
678 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
679 Ast.While
(header
,body
,(unbound,fresh,inherited,aft
))
680 | Ast.For
(header
,body
,(_
,_
,_
,aft
)) ->
681 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
682 Ast.For
(header
,body
,(unbound,fresh,inherited,aft
))
683 | Ast.Iterator
(header
,body
,(_
,_
,_
,aft
)) ->
684 let (unbound,_
,fresh,inherited) = classify (cip_plus aft
) [] in
685 Ast.Iterator
(header
,body
,(unbound,fresh,inherited,aft
))
688 let (matched
,munbound,fresh,_
) = classify free minus_free in
690 List.filter
(function x
-> List.mem x bound
) nc_free in
693 Ast.free_vars
= matched
;
694 Ast.minus_free_vars
= munbound;
695 Ast.fresh_vars
= fresh;
696 Ast.inherited = inherited;
697 Ast.saved_witness
= []} in
699 let astfvstatement_dots recursor k sd
=
700 simple_setup (function x
-> x
.V.combiner_statement_dots
) k sd
in
702 let astfvcase_line recursor k cl
=
703 simple_setup (function x
-> x
.V.combiner_case_line
) k cl
in
705 let astfvtoplevel recursor k tl
=
706 let saved = collect_saved.V.combiner_top_level tl
in
707 {(k tl
) with Ast.saved_witness
= saved} in
710 let donothing r k
e = k
e in
713 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
714 donothing donothing astfvstatement_dots donothing
715 donothing donothing donothing donothing donothing donothing donothing
716 astfvrule_elem astfvstatement astfvcase_line astfvtoplevel donothing
719 let collect_astfvs rules =
720 let rec loop bound = function
722 | (metavars,(nm,rule_info,minirules))::rules ->
724 Common.minus_set bound (List.map Ast.get_meta_name metavars) in
726 (List.map (astfvs metavars bound).V.rebuilder_top_level minirules))::
727 (loop ((List.map Ast.get_meta_name metavars)@bound) rules) in
731 let collect_astfvs rules
=
732 let rec loop bound = function
734 | (metavars, rule
)::rules
->
736 Ast.ScriptRule
(_
,_
,_
,_
)
737 | Ast.InitialScriptRule
(_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
) ->
738 (* bound stays as is because script rules have no names, so no
739 inheritance is possible *)
740 rule
::(loop bound rules
)
741 | Ast.CocciRule
(nm
, rule_info
, minirules
, isexp
, ruletype
) ->
743 Common.minus_set
bound (List.map
Ast.get_meta_name
metavars) in
746 (List.map
(astfvs metavars bound).V.rebuilder_top_level
749 (loop ((List.map
Ast.get_meta_name
metavars)@bound) rules
) in
752 (* ---------------------------------------------------------------- *)
753 (* position variables that appear as a constraint on another position variable.
754 a position variable also cannot appear both positively and negatively in a
757 let get_neg_pos_list (_
,rule
) used_after_list
=
758 let donothing r k
e = k
e in
759 let bind (p1
,np1
) (p2
,np2
) =
760 (Common.union_set p1 p2
, Common.union_set np1 np2
) in
761 let option_default = ([],[]) in
762 let metaid (x
,_
,_
,_
) = x
in
764 match Ast.get_pos_var mc
with
765 Ast.MetaPos
(name
,constraints
,Ast.PER
,_
,_
) ->
766 ([metaid name
],constraints
)
767 | Ast.MetaPos
(name
,constraints
,Ast.ALL
,_
,_
) ->
768 ([],(metaid name
)::constraints
)
769 | _
-> option_default in
771 V.combiner
bind option_default
772 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
773 donothing donothing donothing donothing
774 donothing donothing donothing donothing donothing donothing
775 donothing donothing donothing donothing donothing donothing in
777 Ast.CocciRule
(_
,_
,minirules
,_
,_
) ->
779 (function toplevel
->
780 let (positions
,neg_positions
) = v.V.combiner_top_level toplevel
in
781 (if List.exists
(function p
-> List.mem p neg_positions
) positions
784 "a variable cannot be used both as a position and a constraint");
787 | Ast.ScriptRule _
| Ast.InitialScriptRule _
| Ast.FinalScriptRule _
->
788 (*no negated positions*) []
790 (* ---------------------------------------------------------------- *)
792 (* collect used after lists, per minirule *)
794 (* defined is a list of variables that were declared in a previous metavar
797 (* Top-level used after: For each rule collect the set of variables that
798 are inherited, ie used but not defined. These are accumulated back to
799 their point of definition. *)
802 let collect_top_level_used_after metavar_rule_list
=
803 let drop_virt = List.filter
(function ("virtual",_
) -> false | _
-> true) in
804 let (used_after
,used_after_lists
) =
806 (function (metavar_list
,r
) ->
807 function (used_after
,used_after_lists
) ->
808 let locally_defined = List.map
Ast.get_meta_name metavar_list
in
809 let continue_propagation =
810 List.filter
(function x
-> not
(List.mem x
locally_defined))
814 Ast.ScriptRule
(_
,_
,mv
,_
) ->
815 drop_virt(List.map
(function (_
,(r
,v)) -> (r
,v)) mv
)
816 | Ast.InitialScriptRule
(_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
) -> []
817 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
819 (Common.union_set
(nub (collect_all_rule_refs rule
))
820 (collect_in_plus metavar_list rule
)) in
822 List.filter
(function x
-> not
(List.mem x
locally_defined))
824 (Common.union_set
inherited continue_propagation,
825 used_after
::used_after_lists
))
826 metavar_rule_list
([],[]) in
827 match used_after
with
828 [] -> used_after_lists
831 (Printf.sprintf
"collect_top_level_used_after: unbound variables %s"
832 (String.concat
" " (List.map
(function (_
,x
) -> x
) used_after
)))
834 let collect_local_used_after metavars minirules used_after
=
835 let locally_defined = List.map
Ast.get_meta_name
metavars in
836 let rec loop = function
837 [] -> (used_after
,[],[],[],[])
839 (* In a rule there are three kinds of local variables:
840 1. Variables referenced in the minus or context code.
841 These get a value by matching. This value can be used in
843 2. Fresh variables referenced in the plus code.
844 3. Variables referenced in the seeds of the fresh variables.
845 There are also non-local variables. These may either be variables
846 referenced in the minus, context, or plus code, or they may be
847 variables referenced in the seeds of the fresh variables. *)
848 (* Step 1: collect all references in minus/context, plus, seed
850 let variables_referenced_in_minus_context_code =
851 nub (collect_all_minirule_refs minirule
) in
852 let variables_referenced_in_plus_code =
853 collect_in_plus_term.V.combiner_top_level minirule
in
854 let (env_of_fresh_seeds
,seeds_and_plus
) =
855 collect_fresh_seed_env
856 metavars variables_referenced_in_plus_code in
858 Common.union_set
variables_referenced_in_minus_context_code
860 (* Step 2: identify locally defined ones *)
861 let local_fresh = List.map fst env_of_fresh_seeds
in
863 List.partition
(function x
-> List.mem x
locally_defined) in
864 let local_env_of_fresh_seeds =
865 (* these have to be restricted to only one value if the associated
866 fresh variable is used after *)
867 List.map
(function (f
,ss
) -> (f
,is_local ss
)) env_of_fresh_seeds
in
868 let (local_all_free_vars
,nonlocal_all_free_vars
) =
869 is_local all_free_vars in
870 (* Step 3, recurse on the rest of the rules, making available whatever
871 has been defined in this one *)
872 let (mini_used_after
,fvs_lists
,mini_used_after_lists
,
873 mini_fresh_used_after_lists
,mini_fresh_used_after_seeds
) =
875 (* Step 4: collect the results. These are:
876 1. All of the variables used non-locally in the rules starting
878 2. All of the free variables to the end of the semantic patch
879 3. The variables that are used afterwards and defined here by
880 matching (minus or context code)
881 4. The variables that are used afterwards and are defined here as
883 5. The variables that are used as seeds in computing the bindings
884 of the variables collected in part 4. *)
885 let (local_used_after
, nonlocal_used_after
) =
886 is_local mini_used_after
in
887 let (fresh_local_used_after
(*4*),matched_local_used_after
) =
888 List.partition
(function x
-> List.mem x
local_fresh)
890 let matched_local_used_after(*3*) =
891 Common.union_set
matched_local_used_after nonlocal_used_after
in
892 let new_used_after = (*1*)
893 Common.union_set nonlocal_all_free_vars nonlocal_used_after
in
894 let fresh_local_used_after_seeds =
896 (* no point to keep variables that already are gtd to have only
898 (function x
-> not
(List.mem x
matched_local_used_after))
899 (List.fold_left
(function p
-> function c
-> Common.union_set c p
)
903 fst
(List.assoc fua
local_env_of_fresh_seeds))
904 fresh_local_used_after
)) in
905 (new_used_after,all_free_vars::fvs_lists
(*2*),
906 matched_local_used_after::mini_used_after_lists
,
907 fresh_local_used_after
::mini_fresh_used_after_lists
,
908 fresh_local_used_after_seeds::mini_fresh_used_after_seeds
) in
909 let (_
,fvs_lists
,used_after_lists
(*ua*),
910 fresh_used_after_lists
(*fua*),fresh_used_after_lists_seeds
(*fuas*)) =
912 (fvs_lists
,used_after_lists
,
913 fresh_used_after_lists
,fresh_used_after_lists_seeds
)
917 let collect_used_after metavar_rule_list
=
918 let used_after_lists = collect_top_level_used_after metavar_rule_list
in
920 (function (metavars,r
) ->
921 function used_after
->
923 Ast.ScriptRule
(_
,_
,_
,_
)
924 | Ast.InitialScriptRule
(_
,_
,_
) | Ast.FinalScriptRule
(_
,_
,_
) ->
925 ([], [used_after
], [], [])
926 | Ast.CocciRule
(name
, rule_info
, minirules
, _
,_
) ->
927 collect_local_used_after metavars minirules used_after
929 metavar_rule_list
used_after_lists
931 let rec split4 = function
933 | (a
,b
,c
,d
)::l
-> let (a1
,b1
,c1
,d1
) = split4 l
in (a
::a1
,b
::b1
,c
::c1
,d
::d1
)
935 (* ---------------------------------------------------------------- *)
938 let free_vars rules
=
939 let metavars = List.map
(function (mv
,rule
) -> mv
) rules
in
940 let (fvs_lists
,used_after_matched_lists
,
941 fresh_used_after_lists
,fresh_used_after_lists_seeds
) =
942 split4 (collect_used_after rules
) in
944 List.map2
get_neg_pos_list rules used_after_matched_lists
in
945 let positions_list = (* for all rules, assume all positions are used after *)
950 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> []
951 | Ast.CocciRule
(_
,_
,rule
,_
,_
) ->
955 function Ast.MetaPosDecl
(_
,nm
) -> nm
::prev
| _
-> prev
)
957 List.map
(function _
-> positions) rule
)
965 | Ast.InitialScriptRule _
| Ast.FinalScriptRule _
-> r
966 | Ast.CocciRule
(nm
, rule_info
, r
, is_exp
,ruletype
) ->
969 classify_variables mv r
970 ((List.concat ua
) @ (List.concat fua
)),
972 rules
(List.combine used_after_matched_lists fresh_used_after_lists
) in
973 let new_rules = collect_astfvs (List.combine
metavars new_rules) in
975 fvs_lists
,neg_pos_lists,
976 (used_after_matched_lists
,
977 fresh_used_after_lists
,fresh_used_after_lists_seeds
),