2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
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.
25 module F
= Control_flow_c
27 (*****************************************************************************)
28 (* The functor argument *)
29 (*****************************************************************************)
31 (* info passed recursively in monad in addition to binding *)
33 optional_storage_iso
: bool;
34 optional_qualifier_iso
: bool;
35 value_format_iso
: bool;
36 current_rule_name
: string; (* used for errors *)
37 index
: int list
(* witness tree indices *)
40 module XTRANS
= struct
42 (* ------------------------------------------------------------------------*)
43 (* Combinators history *)
44 (* ------------------------------------------------------------------------*)
47 * type ('a, 'b) transformer =
48 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b
52 * type ('a, 'b) transformer =
53 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b option
54 * use an exception monad
57 * type tin = Lib_engine.metavars_binding
60 (* ------------------------------------------------------------------------*)
61 (* Standard type and operators *)
62 (* ------------------------------------------------------------------------*)
66 binding
: Lib_engine.metavars_binding
;
67 binding0
: Lib_engine.metavars_binding
; (* inherited variable *)
69 type 'x tout
= 'x
option
71 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
73 let (>>=) m f
= fun tin
->
76 | Some
(a
,b
) -> f a b tin
78 let return = fun x
-> fun tin
->
81 (* can have fail in transform now that the process is deterministic ? *)
85 let (>||>) m1 m2
= fun tin
->
88 | Some x
-> Some x
(* stop as soon as have found something *)
90 let (>|+|>) m1 m2
= m1
>||> m2
92 let (>&&>) f m
= fun tin
->
93 if f tin
then m tin
else fail tin
95 let optional_storage_flag f
= fun tin
->
96 f
(tin
.extra
.optional_storage_iso
) tin
98 let optional_qualifier_flag f
= fun tin
->
99 f
(tin
.extra
.optional_qualifier_iso
) tin
101 let value_format_flag f
= fun tin
->
102 f
(tin
.extra
.value_format_iso
) tin
104 let mode = Cocci_vs_c.TransformMode
106 (* ------------------------------------------------------------------------*)
108 (* ------------------------------------------------------------------------*)
109 let cocciExp = fun expf expa node
-> fun tin
->
112 Visitor_c.default_visitor_c_s
with
113 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
114 match expf expa expb tin
with
115 | None
-> (* failed *) k expb
116 | Some
(x
, expb
) -> expb
);
119 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
122 (* same as cocciExp, but for expressions in an expression, not expressions
124 let cocciExpExp = fun expf expa expb
-> fun tin
->
127 Visitor_c.default_visitor_c_s
with
128 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
129 match expf expa expb tin
with
130 | None
-> (* failed *) k expb
131 | Some
(x
, expb
) -> expb
);
134 Some
(expa
, Visitor_c.vk_expr_s
bigf expb
)
137 let cocciTy = fun expf expa node
-> fun tin
->
140 Visitor_c.default_visitor_c_s
with
141 Visitor_c.ktype_s
= (fun (k
, bigf) expb
->
142 match expf expa expb tin
with
143 | None
-> (* failed *) k expb
144 | Some
(x
, expb
) -> expb
);
147 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
149 let cocciInit = fun expf expa node
-> fun tin
->
152 Visitor_c.default_visitor_c_s
with
153 Visitor_c.kini_s
= (fun (k
, bigf) expb
->
154 match expf expa expb tin
with
155 | None
-> (* failed *) k expb
156 | Some
(x
, expb
) -> expb
);
159 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
162 (* ------------------------------------------------------------------------*)
164 (* ------------------------------------------------------------------------*)
165 let check_pos info mck pos
=
167 | Ast_cocci.PLUS
-> raise Impossible
168 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
169 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
,_
,_
) ->
170 pos
<= i2
&& pos
>= i1
171 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
172 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
,_
,_
) ->
179 "weird: dont have position info for the mcodekind in line %d column %d"
180 info
.Ast_cocci.line info
.Ast_cocci.column
)
182 failwith
"weird: dont have position info for the mcodekind"
185 let tag_with_mck mck ib
= fun tin
->
187 let cocciinforef = ib
.Ast_c.cocci_tag
in
188 let (oldmcode
, oldenv
) = Ast_c.mcode_and_env_of_cocciref
cocciinforef in
192 if !Flag_parsing_cocci.sgrep_mode
193 then Sgrep.process_sgrep ib mck
198 (match mck, Ast_c.pinfo_of_info ib
with
199 | _
, Ast_c.AbstractLineTok _
-> raise Impossible
200 | Ast_cocci.MINUS
(_
), Ast_c.ExpandedTok _
->
201 failwith
("try to delete an expanded token: " ^
(Ast_c.str_of_info ib
))
205 match (oldmcode
,mck) with
206 | (Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
), _
)
207 | (_
, Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
))
209 let update_inst inst
= function
210 Ast_cocci.MINUS
(pos
,_
,adj
,any_xxs
) ->
211 Ast_cocci.MINUS
(pos
,inst
,adj
,any_xxs
)
213 cocciinforef := Some
(update_inst tin
.extra
.index
mck, tin
.binding
);
216 | (Ast_cocci.MINUS
(old_pos
,old_inst
,old_adj
,[]),
217 Ast_cocci.MINUS
(new_pos
,new_inst
,new_adj
,[]))
218 when old_pos
= new_pos
&& oldenv
=*= tin
.binding
219 (* no way to combine adjacency information, just drop one *)
223 (old_pos
,Common.union_set old_inst new_inst
,old_adj
,[]),
225 (if !Flag_matcher.show_misc
226 then pr2
"already tagged but only removed, so safe");
237 pad: if dont want cocci write:
239 (match Ast_c.pinfo_of_info ib with
240 Ast_c.FakeTok _ -> "already tagged fake token"
242 let pm str mcode env
=
244 "%s modification:\n%s\nAccording to environment:\n%s\n"
246 (Common.format_to_string
248 Pretty_print_cocci.print_mcodekind mcode
))
251 (function ((r
,vr
),vl
) ->
252 Printf.sprintf
" %s.%s -> %s" r vr
253 (Common.format_to_string
255 Pretty_print_engine.pp_binding_kind vl
)))
257 flush stdout
; flush stderr
;
259 ("\n"^
(pm "previous" oldmcode oldenv
) ^
"\n" ^
260 (pm "current" mck tin
.binding
));
262 (match Ast_c.pinfo_of_info ib
with
264 Common.sprintf
"%s: already tagged fake token\n"
265 tin
.extra
.current_rule_name
268 "%s: already tagged token:\nC code context\n%s"
269 tin
.extra
.current_rule_name
270 (Common.error_message
(Ast_c.file_of_info ib
)
271 (Ast_c.str_of_info ib
, Ast_c.opos_of_info ib
)))
274 let tokenf ia ib
= fun tin
->
275 let (_
,i
,mck,_
) = ia
in
276 let pos = Ast_c.info_to_fixpos ib
in
277 if check_pos (Some i
) mck pos
278 then return (ia
, tag_with_mck mck ib tin
) tin
281 let tokenf_mck mck ib
= fun tin
->
282 let pos = Ast_c.info_to_fixpos ib
in
283 if check_pos None
mck pos
284 then return (mck, tag_with_mck mck ib tin
) tin
288 (* ------------------------------------------------------------------------*)
289 (* Distribute mcode *)
290 (* ------------------------------------------------------------------------*)
292 (* When in the SP we attach something to a metavariable, or delete it, as in
295 * we have to minusize all the token that compose S in the C code, and
296 * attach the 'foo();' to the right token, the one at the very right.
299 type 'a distributer
=
300 (Ast_c.info
-> Ast_c.info
) * (* what to do on left *)
301 (Ast_c.info
-> Ast_c.info
) * (* what to do on middle *)
302 (Ast_c.info
-> Ast_c.info
) * (* what to do on right *)
303 (Ast_c.info
-> Ast_c.info
) -> (* what to do on both *)
306 let distribute_mck mcodekind distributef expr tin
=
308 | Ast_cocci.MINUS
(pos,_
,adj
,any_xxs
) ->
309 let inst = tin
.extra
.index
in
312 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,any_xxs
)) ib tin
),
314 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,[])) ib tin
),
316 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,[])) ib tin
),
318 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,any_xxs
)) ib tin
)
320 | Ast_cocci.CONTEXT
(pos,any_befaft
) ->
321 (match any_befaft
with
322 | Ast_cocci.NOTHING
-> expr
324 | Ast_cocci.BEFORE xxs
->
326 (fun ib
-> tag_with_mck
327 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
),
330 (fun ib
-> tag_with_mck
331 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
)
333 | Ast_cocci.AFTER xxs
->
337 (fun ib
-> tag_with_mck
338 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER xxs
)) ib tin
),
339 (fun ib
-> tag_with_mck
340 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER xxs
)) ib tin
)
343 | Ast_cocci.BEFOREAFTER
(xxs
, yys
) ->
345 (fun ib
-> tag_with_mck
346 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
),
348 (fun ib
-> tag_with_mck
349 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER yys
)) ib tin
),
350 (fun ib
-> tag_with_mck
351 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFOREAFTER
(xxs
,yys
)))
356 | Ast_cocci.PLUS
-> raise Impossible
359 (* use new strategy, collect ii, sort, recollect and tag *)
361 let mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
) =
363 Visitor_c.default_visitor_c_s
with
364 Visitor_c.kinfo_s
= (fun (k
,bigf) i
->
365 let pos = Ast_c.info_to_fixpos i
in
367 | _
when Ast_cocci.equal_pos
pos maxpos
&&
368 Ast_cocci.equal_pos
pos minpos
-> bop i
369 | _
when Ast_cocci.equal_pos
pos maxpos
-> rop i
370 | _
when Ast_cocci.equal_pos
pos minpos
-> lop i
376 let distribute_mck_expr (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
377 Visitor_c.vk_expr_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
379 let distribute_mck_args (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
380 Visitor_c.vk_args_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
382 let distribute_mck_type (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
383 Visitor_c.vk_type_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
385 let distribute_mck_ini (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
386 Visitor_c.vk_ini_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
388 let distribute_mck_param (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
389 Visitor_c.vk_param_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
391 let distribute_mck_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
392 Visitor_c.vk_params_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
395 let distribute_mck_node (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
396 Visitor_c.vk_node_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
399 let distribute_mck_struct_fields (maxpos
, minpos
) =
400 fun (lop
,mop
,rop
,bop
) ->fun x
->
401 Visitor_c.vk_struct_fields_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
404 let distribute_mck_cst (maxpos
, minpos
) =
405 fun (lop
,mop
,rop
,bop
) ->fun x
->
406 Visitor_c.vk_cst_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
410 let distribute_mck_define_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->
412 Visitor_c.vk_define_params_splitted_s
413 (mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
418 | Ast_cocci.PLUS
-> raise Impossible
419 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
420 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
,_
,_
) ->
421 Ast_cocci.FixPos
(i1
,i2
)
422 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
423 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
,_
,_
) ->
424 Ast_cocci.DontCarePos
425 | _
-> failwith
"weird: dont have position info for the mcodekind"
427 let distrf (ii_of_x_f
, distribute_mck_x_f
) =
428 fun ia x
-> fun tin
->
429 let mck = Ast_cocci.get_mcodekind ia
in
430 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
433 (* bug: check_pos mck max && check_pos mck min
435 * if do that then if have - f(...); and in C f(1,2); then we
436 * would get a "already tagged" because the '...' would sucess in
437 * transformaing both '1' and '1,2'. So being in the range is not
438 * enough. We must be equal exactly to the range!
440 (match get_pos mck with
441 | Ast_cocci.DontCarePos
-> true
442 | Ast_cocci.FixPos
(i1
, i2
) ->
443 i1
=*= min
&& i2
=*= max
444 | _
-> raise Impossible
450 distribute_mck mck (distribute_mck_x_f
(max
,min
)) x tin
455 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
, distribute_mck_expr)
456 let distrf_args = distrf (Lib_parsing_c.ii_of_args
, distribute_mck_args)
457 let distrf_type = distrf (Lib_parsing_c.ii_of_type
, distribute_mck_type)
458 let distrf_param = distrf (Lib_parsing_c.ii_of_param
, distribute_mck_param)
459 let distrf_params = distrf (Lib_parsing_c.ii_of_params
,distribute_mck_params)
460 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
,distribute_mck_ini)
461 let distrf_node = distrf (Lib_parsing_c.ii_of_node
,distribute_mck_node)
462 let distrf_struct_fields =
463 distrf (Lib_parsing_c.ii_of_struct_fields
, distribute_mck_struct_fields)
465 distrf (Lib_parsing_c.ii_of_cst
, distribute_mck_cst)
466 let distrf_define_params =
467 distrf (Lib_parsing_c.ii_of_define_params
,distribute_mck_define_params)
470 (* ------------------------------------------------------------------------*)
472 (* ------------------------------------------------------------------------*)
473 let meta_name_to_str (s1
, s2
) =
476 let envf keep _inherited
= fun (s
, value, _
) f tin
->
477 let s = Ast_cocci.unwrap_mcode
s in
479 if keep
=*= Type_cocci.Saved
481 try Some
(List.assoc
s tin
.binding
)
484 "Don't find value for metavariable %s in the environment"
485 (meta_name_to_str s));
488 (* not raise Impossible! *)
495 (* Ex: in cocci_vs_c someone wants to add a binding. Here in
496 * transformation3 the value for this var may be already in the
497 * env, because for instance its value were fixed in a previous
498 * SmPL rule. So here we want to check that this is the same value.
499 * If forget to do the check, what can happen ? Because of Exp
500 * and other disjunctive feature of cocci_vs_c (>||>), we
501 * may accept a match at a wrong position. Maybe later this
502 * will be detected via the pos system on tokens, but maybe
503 * not. So safer to keep the check.
507 if Cocci_vs_c.equal_metavarval
value value'
512 let check_constraints matcher constraints exp
= fun f tin
-> f
() tin
514 (* ------------------------------------------------------------------------*)
515 (* Environment, allbounds *)
516 (* ------------------------------------------------------------------------*)
517 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
518 true (* in transform we don't care ? *)
522 (*****************************************************************************)
524 (*****************************************************************************)
525 module TRANS
= Cocci_vs_c.COCCI_VS_C
(XTRANS
)
528 let transform_re_node a b tin
=
529 match TRANS.rule_elem_node a b tin
with
530 | None
-> raise Impossible
531 | Some
(_sp
, b'
) -> b'
533 let (transform2
: string (* rule name *) -> string list
(* dropped_isos *) ->
534 Lib_engine.metavars_binding
(* inherited bindings *) ->
535 Lib_engine.numbered_transformation_info
-> F.cflow
-> F.cflow
) =
536 fun rule_name dropped_isos binding0 xs cflow
->
539 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
540 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
541 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
542 current_rule_name
= rule_name
;
546 (* find the node, transform, update the node, and iter for all elements *)
548 xs
+> List.fold_left
(fun acc
(index
, (nodei
, binding
, rule_elem
)) ->
549 (* subtil: not cflow#nodes but acc#nodes *)
550 let node = acc#nodes#assoc nodei
in
552 if !Flag.show_transinfo
553 then pr2
"transform one node";
556 XTRANS.extra = {extra with index
= index
};
557 XTRANS.binding
= binding0
@binding
;
558 XTRANS.binding0
= []; (* not used - everything constant for trans *)
561 let node'
= transform_re_node rule_elem
node tin in
563 (* assert that have done something. But with metaruleElem sometimes
564 dont modify fake nodes. So special case before on Fake nodes. *)
565 (match F.unwrap
node with
566 | F.Enter
| F.Exit
| F.ErrorExit
567 | F.EndStatement _
| F.CaseNode _
569 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
571 | _
-> () (* assert (not (node =*= node')); *)
574 (* useless, we dont go back from flow to ast now *)
575 (* let node' = lastfix_comma_struct node' in *)
577 acc#replace_node
(nodei
, node'
);
583 let transform a b c d e
=
584 Common.profile_code
"Transformation3.transform"
585 (fun () -> transform2 a b c d e
)