1 (* Copyright (C) 2006, 2007 Yoann Padioleau
3 * This program is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU General Public License (GPL)
5 * version 2 as published by the Free Software Foundation.
7 * This program is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
10 * file license.txt for more details.
12 * This file was part of Coccinelle.
16 module F
= Control_flow_c
18 module Flag
= Flag_matcher
19 (*****************************************************************************)
20 (* The functor argument *)
21 (*****************************************************************************)
23 (* info passed recursively in monad in addition to binding *)
25 optional_storage_iso
: bool;
26 optional_qualifier_iso
: bool;
27 value_format_iso
: bool;
28 current_rule_name
: string; (* used for errors *)
31 module XTRANS
= struct
33 (* ------------------------------------------------------------------------*)
34 (* Combinators history *)
35 (* ------------------------------------------------------------------------*)
38 * type ('a, 'b) transformer =
39 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b
43 * type ('a, 'b) transformer =
44 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b option
45 * use an exception monad
48 * type tin = Lib_engine.metavars_binding
51 (* ------------------------------------------------------------------------*)
52 (* Standard type and operators *)
53 (* ------------------------------------------------------------------------*)
57 binding
: Lib_engine.metavars_binding
;
58 binding0
: Lib_engine.metavars_binding
; (* inherited variable *)
60 type 'x tout
= 'x
option
62 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
64 let (>>=) m f
= fun tin
->
67 | Some
(a
,b
) -> f a b tin
69 let return = fun x
-> fun tin
->
72 (* can have fail in transform now that the process is deterministic ? *)
76 let (>||>) m1 m2
= fun tin
->
79 | Some x
-> Some x
(* stop as soon as have found something *)
81 let (>|+|>) m1 m2
= m1
>||> m2
83 let (>&&>) f m
= fun tin
->
84 if f tin
then m tin
else fail tin
86 let optional_storage_flag f
= fun tin
->
87 f
(tin
.extra
.optional_storage_iso
) tin
89 let optional_qualifier_flag f
= fun tin
->
90 f
(tin
.extra
.optional_qualifier_iso
) tin
92 let value_format_flag f
= fun tin
->
93 f
(tin
.extra
.value_format_iso
) tin
95 let mode = Cocci_vs_c.TransformMode
97 (* ------------------------------------------------------------------------*)
99 (* ------------------------------------------------------------------------*)
100 let cocciExp = fun expf expa node
-> fun tin
->
103 Visitor_c.default_visitor_c_s
with
104 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
105 match expf expa expb tin
with
106 | None
-> (* failed *) k expb
107 | Some
(x
, expb
) -> expb
);
110 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
113 (* same as cocciExp, but for expressions in an expression, not expressions
115 let cocciExpExp = fun expf expa expb
-> fun tin
->
118 Visitor_c.default_visitor_c_s
with
119 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
120 match expf expa expb tin
with
121 | None
-> (* failed *) k expb
122 | Some
(x
, expb
) -> expb
);
125 Some
(expa
, Visitor_c.vk_expr_s
bigf expb
)
128 let cocciTy = fun expf expa node
-> fun tin
->
131 Visitor_c.default_visitor_c_s
with
132 Visitor_c.ktype_s
= (fun (k
, bigf) expb
->
133 match expf expa expb tin
with
134 | None
-> (* failed *) k expb
135 | Some
(x
, expb
) -> expb
);
138 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
140 let cocciInit = fun expf expa node
-> fun tin
->
143 Visitor_c.default_visitor_c_s
with
144 Visitor_c.kini_s
= (fun (k
, bigf) expb
->
145 match expf expa expb tin
with
146 | None
-> (* failed *) k expb
147 | Some
(x
, expb
) -> expb
);
150 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
153 (* ------------------------------------------------------------------------*)
155 (* ------------------------------------------------------------------------*)
156 let check_pos info mck pos
=
158 | Ast_cocci.PLUS
-> raise Impossible
159 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
160 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
) ->
161 pos
<= i2
&& pos
>= i1
162 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
163 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
) ->
170 "wierd: dont have position info for the mcodekind in line %d column %d"
171 info
.Ast_cocci.line info
.Ast_cocci.column
)
173 failwith
"wierd: dont have position info for the mcodekind"
176 let tag_with_mck mck ib
= fun tin
->
178 let cocciinforef = ib
.Ast_c.cocci_tag
in
179 let (oldmcode
, oldenv
) = !cocciinforef in
183 if !Flag_parsing_cocci.sgrep_mode
184 then Sgrep.process_sgrep ib mck
189 (match mck, Ast_c.pinfo_of_info ib
with
190 | _
, Ast_c.AbstractLineTok _
-> raise Impossible
191 | Ast_cocci.MINUS
(_
), Ast_c.ExpandedTok _
->
192 failwith
("try to delete an expanded token: " ^
(Ast_c.str_of_info ib
))
196 match (oldmcode
,mck) with
197 | (Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
), _
)
198 | (_
, Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
))
200 cocciinforef := (mck, tin
.binding
);
204 if (oldmcode
, oldenv
) = (mck, tin
.binding
)
207 then pr2
"already tagged but with same mcode, so safe";
218 Format.set_formatter_out_channel stderr;
219 Common.pr2 "SP mcode ";
220 Pretty_print_cocci.print_mcodekind oldmcode;
221 Format.print_newline();
222 Common.pr2 "C code mcode ";
223 Pretty_print_cocci.print_mcodekind mck;
224 Format.print_newline();
225 Format.print_flush();
228 (Common.sprintf
"%s: already tagged token:\n%s"
229 tin
.extra
.current_rule_name
230 (Common.error_message
(Ast_c.file_of_info ib
)
231 (Ast_c.str_of_info ib
, Ast_c.opos_of_info ib
)))
234 let tokenf ia ib
= fun tin
->
235 let (_
,i
,mck,_
) = ia
in
236 let pos = Ast_c.info_to_fixpos ib
in
237 if check_pos (Some i
) mck pos
238 then return (ia
, tag_with_mck mck ib tin
) tin
241 let tokenf_mck mck ib
= fun tin
->
242 let pos = Ast_c.info_to_fixpos ib
in
243 if check_pos None
mck pos
244 then return (mck, tag_with_mck mck ib tin
) tin
248 (* ------------------------------------------------------------------------*)
249 (* Distribute mcode *)
250 (* ------------------------------------------------------------------------*)
252 (* When in the SP we attach something to a metavariable, or delete it, as in
255 * we have to minusize all the token that compose S in the C code, and
256 * attach the 'foo();' to the right token, the one at the very right.
259 type 'a distributer
=
260 (Ast_c.info
-> Ast_c.info
) * (* what to do on left *)
261 (Ast_c.info
-> Ast_c.info
) * (* what to do on middle *)
262 (Ast_c.info
-> Ast_c.info
) * (* what to do on right *)
263 (Ast_c.info
-> Ast_c.info
) -> (* what to do on both *)
266 let distribute_mck mcodekind distributef expr tin
=
268 | Ast_cocci.MINUS
(pos,any_xxs
) ->
270 (fun ib
-> tag_with_mck (Ast_cocci.MINUS
(pos,any_xxs
)) ib tin
),
271 (fun ib
-> tag_with_mck (Ast_cocci.MINUS
(pos,[])) ib tin
),
272 (fun ib
-> tag_with_mck (Ast_cocci.MINUS
(pos,[])) ib tin
),
273 (fun ib
-> tag_with_mck (Ast_cocci.MINUS
(pos,any_xxs
)) ib tin
)
275 | Ast_cocci.CONTEXT
(pos,any_befaft
) ->
276 (match any_befaft
with
277 | Ast_cocci.NOTHING
-> expr
279 | Ast_cocci.BEFORE xxs
->
281 (fun ib
-> tag_with_mck
282 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
),
285 (fun ib
-> tag_with_mck
286 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
)
288 | Ast_cocci.AFTER xxs
->
292 (fun ib
-> tag_with_mck
293 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER xxs
)) ib tin
),
294 (fun ib
-> tag_with_mck
295 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER xxs
)) ib tin
)
298 | Ast_cocci.BEFOREAFTER
(xxs
, yys
) ->
300 (fun ib
-> tag_with_mck
301 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE xxs
)) ib tin
),
303 (fun ib
-> tag_with_mck
304 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER yys
)) ib tin
),
305 (fun ib
-> tag_with_mck
306 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFOREAFTER
(xxs
,yys
)))
311 | Ast_cocci.PLUS
-> raise Impossible
314 (* use new strategy, collect ii, sort, recollect and tag *)
316 let mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
) =
318 Visitor_c.default_visitor_c_s
with
319 Visitor_c.kinfo_s
= (fun (k
,bigf) i
->
320 let pos = Ast_c.info_to_fixpos i
in
322 | _
when Ast_cocci.equal_pos
pos maxpos
&&
323 Ast_cocci.equal_pos
pos minpos
-> bop i
324 | _
when Ast_cocci.equal_pos
pos maxpos
-> rop i
325 | _
when Ast_cocci.equal_pos
pos minpos
-> lop i
331 let distribute_mck_expr (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
332 Visitor_c.vk_expr_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
334 let distribute_mck_args (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
335 Visitor_c.vk_args_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
337 let distribute_mck_type (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
338 Visitor_c.vk_type_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
340 let distribute_mck_ini (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
341 Visitor_c.vk_ini_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
343 let distribute_mck_param (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
344 Visitor_c.vk_param_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
346 let distribute_mck_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
347 Visitor_c.vk_params_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
350 let distribute_mck_node (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
351 Visitor_c.vk_node_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
354 let distribute_mck_struct_fields (maxpos
, minpos
) =
355 fun (lop
,mop
,rop
,bop
) ->fun x
->
356 Visitor_c.vk_struct_fields_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
359 let distribute_mck_cst (maxpos
, minpos
) =
360 fun (lop
,mop
,rop
,bop
) ->fun x
->
361 Visitor_c.vk_cst_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
365 let distribute_mck_define_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->
367 Visitor_c.vk_define_params_splitted_s
368 (mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
373 | Ast_cocci.PLUS
-> raise Impossible
374 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
375 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
) ->
376 Ast_cocci.FixPos
(i1
,i2
)
377 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
378 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
) ->
379 Ast_cocci.DontCarePos
380 | _
-> failwith
"wierd: dont have position info for the mcodekind"
382 let distrf (ii_of_x_f
, distribute_mck_x_f
) =
383 fun ia x
-> fun tin
->
384 let mck = Ast_cocci.get_mcodekind ia
in
385 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
388 (* bug: check_pos mck max && check_pos mck min
390 * if do that then if have - f(...); and in C f(1,2); then we
391 * would get a "already tagged" because the '...' would sucess in
392 * transformaing both '1' and '1,2'. So being in the range is not
393 * enough. We must be equal exactly to the range!
395 (match get_pos mck with
396 | Ast_cocci.DontCarePos
-> true
397 | Ast_cocci.FixPos
(i1
, i2
) ->
399 | _
-> raise Impossible
405 distribute_mck mck (distribute_mck_x_f
(max
,min
)) x tin
410 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
, distribute_mck_expr)
411 let distrf_args = distrf (Lib_parsing_c.ii_of_args
, distribute_mck_args)
412 let distrf_type = distrf (Lib_parsing_c.ii_of_type
, distribute_mck_type)
413 let distrf_param = distrf (Lib_parsing_c.ii_of_param
, distribute_mck_param)
414 let distrf_params = distrf (Lib_parsing_c.ii_of_params
,distribute_mck_params)
415 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
,distribute_mck_ini)
416 let distrf_node = distrf (Lib_parsing_c.ii_of_node
,distribute_mck_node)
417 let distrf_struct_fields =
418 distrf (Lib_parsing_c.ii_of_struct_fields
, distribute_mck_struct_fields)
420 distrf (Lib_parsing_c.ii_of_cst
, distribute_mck_cst)
421 let distrf_define_params =
422 distrf (Lib_parsing_c.ii_of_define_params
,distribute_mck_define_params)
425 (* ------------------------------------------------------------------------*)
427 (* ------------------------------------------------------------------------*)
428 let meta_name_to_str (s1
, s2
) =
431 let envf keep _inherited
= fun (s
, value, _
) f tin
->
432 let s = Ast_cocci.unwrap_mcode
s in
434 if keep
= Type_cocci.Saved
436 try Some
(List.assoc
s tin
.binding
)
439 "Don't find value for metavariable %s in the environment"
440 (meta_name_to_str s));
443 (* not raise Impossible! *)
450 (* Ex: in cocci_vs_c someone wants to add a binding. Here in
451 * transformation3 the value for this var may be already in the
452 * env, because for instance its value were fixed in a previous
453 * SmPL rule. So here we want to check that this is the same value.
454 * If forget to do the check, what can happen ? Because of Exp
455 * and other disjunctive feature of cocci_vs_c (>||>), we
456 * may accept a match at a wrong position. Maybe later this
457 * will be detected via the pos system on tokens, but maybe
458 * not. So safer to keep the check.
462 if Cocci_vs_c.equal_metavarval
value value'
467 let check_constraints matcher constraints exp
= fun f tin
-> f
() tin
469 (* ------------------------------------------------------------------------*)
470 (* Environment, allbounds *)
471 (* ------------------------------------------------------------------------*)
472 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
473 true (* in transform we don't care ? *)
477 (*****************************************************************************)
479 (*****************************************************************************)
480 module TRANS
= Cocci_vs_c.COCCI_VS_C
(XTRANS
)
483 let transform_re_node a b tin
=
484 match TRANS.rule_elem_node a b tin
with
485 | None
-> raise Impossible
486 | Some
(_sp
, b'
) -> b'
488 let (transform2
: string (* rule name *) -> string list
(* dropped_isos *) ->
489 Lib_engine.metavars_binding
(* inherited bindings *) ->
490 Lib_engine.transformation_info
-> F.cflow
-> F.cflow
) =
491 fun rule_name dropped_isos binding0 xs cflow
->
494 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
495 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
496 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
497 current_rule_name
= rule_name
;
500 (* find the node, transform, update the node, and iter for all elements *)
502 xs
+> List.fold_left
(fun acc
(nodei
, binding
, rule_elem
) ->
503 (* subtil: not cflow#nodes but acc#nodes *)
504 let node = acc#nodes#assoc nodei
in
507 then pr2
"transform one node";
510 XTRANS.extra = extra;
511 XTRANS.binding
= binding0
@binding
;
512 XTRANS.binding0
= []; (* not used - everything constant for trans *)
515 let node'
= transform_re_node rule_elem
node tin in
517 (* assert that have done something. But with metaruleElem sometimes
518 dont modify fake nodes. So special case before on Fake nodes. *)
519 (match F.unwrap
node with
520 | F.Enter
| F.Exit
| F.ErrorExit
521 | F.EndStatement _
| F.CaseNode _
523 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
525 | _
-> () (* assert (not (node =*= node')); *)
528 (* useless, we dont go back from flow to ast now *)
529 (* let node' = lastfix_comma_struct node' in *)
531 acc#replace_node
(nodei
, node'
);
537 let transform a b c d e
=
538 Common.profile_code
"Transformation3.transform"
539 (fun () -> transform2 a b c d e
)