3 * Copyright (C) 2006, 2007 Ecole des Mines de Nantes
5 * This program is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU General Public License (GPL)
7 * version 2 as published by the Free Software Foundation.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * file license.txt for more details.
14 * This file was part of Coccinelle.
18 module F
= Control_flow_c
20 (*****************************************************************************)
21 (* The functor argument *)
22 (*****************************************************************************)
24 (* info passed recursively in monad in addition to binding *)
26 optional_storage_iso
: bool;
27 optional_qualifier_iso
: bool;
28 value_format_iso
: bool;
29 current_rule_name
: string; (* used for errors *)
30 index
: int list
(* witness tree indices *)
33 module XTRANS
= struct
35 (* ------------------------------------------------------------------------*)
36 (* Combinators history *)
37 (* ------------------------------------------------------------------------*)
40 * type ('a, 'b) transformer =
41 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b
45 * type ('a, 'b) transformer =
46 * 'a -> 'b -> Lib_engine.metavars_binding -> 'b option
47 * use an exception monad
50 * type tin = Lib_engine.metavars_binding
53 (* ------------------------------------------------------------------------*)
54 (* Standard type and operators *)
55 (* ------------------------------------------------------------------------*)
59 binding
: Lib_engine.metavars_binding
;
60 binding0
: Lib_engine.metavars_binding
; (* inherited variable *)
62 type 'x tout
= 'x
option
64 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
66 let (>>=) m f
= fun tin
->
69 | Some
(a
,b
) -> f a b tin
71 let return = fun x
-> fun tin
->
74 (* can have fail in transform now that the process is deterministic ? *)
78 let (>||>) m1 m2
= fun tin
->
81 | Some x
-> Some x
(* stop as soon as have found something *)
83 let (>|+|>) m1 m2
= m1
>||> m2
85 let (>&&>) f m
= fun tin
->
86 if f tin
then m tin
else fail tin
88 let optional_storage_flag f
= fun tin
->
89 f
(tin
.extra
.optional_storage_iso
) tin
91 let optional_qualifier_flag f
= fun tin
->
92 f
(tin
.extra
.optional_qualifier_iso
) tin
94 let value_format_flag f
= fun tin
->
95 f
(tin
.extra
.value_format_iso
) tin
97 let mode = Cocci_vs_c.TransformMode
99 (* ------------------------------------------------------------------------*)
101 (* ------------------------------------------------------------------------*)
102 let cocciExp = fun expf expa node
-> fun tin
->
105 Visitor_c.default_visitor_c_s
with
106 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
107 match expf expa expb tin
with
108 | None
-> (* failed *) k expb
109 | Some
(x
, expb
) -> expb
);
112 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
115 (* same as cocciExp, but for expressions in an expression, not expressions
117 let cocciExpExp = fun expf expa expb
-> fun tin
->
120 Visitor_c.default_visitor_c_s
with
121 Visitor_c.kexpr_s
= (fun (k
, bigf) expb
->
122 match expf expa expb tin
with
123 | None
-> (* failed *) k expb
124 | Some
(x
, expb
) -> expb
);
127 Some
(expa
, Visitor_c.vk_expr_s
bigf expb
)
130 let cocciTy = fun expf expa node
-> fun tin
->
133 Visitor_c.default_visitor_c_s
with
134 Visitor_c.ktype_s
= (fun (k
, bigf) expb
->
135 match expf expa expb tin
with
136 | None
-> (* failed *) k expb
137 | Some
(x
, expb
) -> expb
);
140 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
142 let cocciInit = fun expf expa node
-> fun tin
->
145 Visitor_c.default_visitor_c_s
with
146 Visitor_c.kini_s
= (fun (k
, bigf) expb
->
147 match expf expa expb tin
with
148 | None
-> (* failed *) k expb
149 | Some
(x
, expb
) -> expb
);
152 Some
(expa
, Visitor_c.vk_node_s
bigf node
)
155 (* ------------------------------------------------------------------------*)
157 (* ------------------------------------------------------------------------*)
158 let check_pos info mck pos
=
160 | Ast_cocci.PLUS _
-> raise Impossible
161 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
162 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
,_
,_
) ->
163 pos
<= i2
&& pos
>= i1
164 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
165 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
,_
,_
) ->
172 "weird: dont have position info for the mcodekind in line %d column %d"
173 info
.Ast_cocci.line info
.Ast_cocci.column
)
175 failwith
"weird: dont have position info for the mcodekind"
178 let tag_with_mck mck ib
= fun tin
->
180 let cocciinforef = ib
.Ast_c.cocci_tag
in
181 let (oldmcode
, oldenvs
) = Ast_c.mcode_and_env_of_cocciref
cocciinforef in
185 if !Flag_parsing_cocci.sgrep_mode
186 then Sgrep.process_sgrep ib mck
191 (match mck, Ast_c.pinfo_of_info ib
with
192 | _
, Ast_c.AbstractLineTok _
-> raise Impossible
193 | Ast_cocci.MINUS
(_
), Ast_c.ExpandedTok _
->
194 failwith
("try to delete an expanded token: " ^
(Ast_c.str_of_info ib
))
198 let many_count = function
199 Ast_cocci.BEFORE
(_
,Ast_cocci.MANY
) | Ast_cocci.AFTER
(_
,Ast_cocci.MANY
)
200 | Ast_cocci.BEFOREAFTER
(_
,_
,Ast_cocci.MANY
) -> true
203 (match (oldmcode
,mck) with
204 | (Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
), _
) ->
205 (* nothing there, so take the new stuff *)
206 let update_inst inst
= function
207 Ast_cocci.MINUS
(pos
,_
,adj
,any_xxs
) ->
208 Ast_cocci.MINUS
(pos
,inst
,adj
,any_xxs
)
210 cocciinforef := Some
(update_inst tin
.extra
.index
mck, [tin
.binding
])
211 | (_
, Ast_cocci.CONTEXT
(_
,Ast_cocci.NOTHING
)) ->
212 (* can this case occur? stay with the old stuff *)
214 | (Ast_cocci.MINUS
(old_pos
,old_inst
,old_adj
,[]),
215 Ast_cocci.MINUS
(new_pos
,new_inst
,new_adj
,[]))
216 when old_pos
= new_pos
&&
217 (List.mem tin
.binding oldenvs
or !Flag.sgrep_mode2
)
218 (* no way to combine adjacency information, just drop one *)
222 (old_pos
,Common.union_set old_inst new_inst
,old_adj
,[]),
224 (if !Flag_matcher.show_misc
225 then pr2
"already tagged but only removed, so safe")
227 | (Ast_cocci.CONTEXT
(old_pos
,old_modif
),
228 Ast_cocci.CONTEXT
(new_pos
,new_modif
))
229 when old_pos
= new_pos
&&
230 old_modif
= new_modif
&& many_count old_modif
->
231 (* iteration only allowed on context; no way to replace something
232 more than once; now no need for iterable; just check a flag *)
235 Some
(Ast_cocci.CONTEXT
(old_pos
,old_modif
),tin
.binding
::oldenvs
)
245 pad: if dont want cocci write:
247 (match Ast_c.pinfo_of_info ib with
248 Ast_c.FakeTok _ -> "already tagged fake token"
250 let pm str mcode env
=
252 "%s modification:\n%s\nAccording to environment %d:\n%s\n"
254 (Common.format_to_string
256 Pretty_print_cocci.print_mcodekind mcode
))
260 (function ((r
,vr
),vl
) ->
261 Printf.sprintf
" %s.%s -> %s" r vr
262 (Common.format_to_string
264 Pretty_print_engine.pp_binding_kind vl
)))
266 flush stdout
; flush stderr
;
268 ("\n"^
(String.concat
"\n"
269 (List.map
(pm "previous" oldmcode
) oldenvs
)) ^
"\n"
270 ^
(pm "current" mck tin
.binding
));
272 (match Ast_c.pinfo_of_info ib
with
274 Common.sprintf
"%s: already tagged fake token\n"
275 tin
.extra
.current_rule_name
278 "%s: already tagged token:\nC code context\n%s"
279 tin
.extra
.current_rule_name
280 (Common.error_message
(Ast_c.file_of_info ib
)
281 (Ast_c.str_of_info ib
, Ast_c.opos_of_info ib
)))
285 let tokenf ia ib
= fun tin
->
286 let (_
,i
,mck,_
) = ia
in
287 let pos = Ast_c.info_to_fixpos ib
in
288 if check_pos (Some i
) mck pos
289 then return (ia
, tag_with_mck mck ib tin
) tin
292 let tokenf_mck mck ib
= fun tin
->
293 let pos = Ast_c.info_to_fixpos ib
in
294 if check_pos None
mck pos
295 then return (mck, tag_with_mck mck ib tin
) tin
299 (* ------------------------------------------------------------------------*)
300 (* Distribute mcode *)
301 (* ------------------------------------------------------------------------*)
303 (* When in the SP we attach something to a metavariable, or delete it, as in
306 * we have to minusize all the token that compose S in the C code, and
307 * attach the 'foo();' to the right token, the one at the very right.
310 type 'a distributer
=
311 (Ast_c.info
-> Ast_c.info
) * (* what to do on left *)
312 (Ast_c.info
-> Ast_c.info
) * (* what to do on middle *)
313 (Ast_c.info
-> Ast_c.info
) * (* what to do on right *)
314 (Ast_c.info
-> Ast_c.info
) -> (* what to do on both *)
317 let distribute_mck mcodekind distributef expr tin
=
319 | Ast_cocci.MINUS
(pos,_
,adj
,any_xxs
) ->
320 let inst = tin
.extra
.index
in
323 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,any_xxs
)) ib tin
),
325 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,[])) ib tin
),
327 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,[])) ib tin
),
329 tag_with_mck (Ast_cocci.MINUS
(pos,inst,adj
,any_xxs
)) ib tin
)
331 | Ast_cocci.CONTEXT
(pos,any_befaft
) ->
332 (match any_befaft
with
333 | Ast_cocci.NOTHING
-> expr
335 | Ast_cocci.BEFORE
(xxs
,c
) ->
337 (fun ib
-> tag_with_mck
338 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE
(xxs
,c
))) ib tin
),
341 (fun ib
-> tag_with_mck
342 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE
(xxs
,c
))) ib tin
)
344 | Ast_cocci.AFTER
(xxs
,c
) ->
348 (fun ib
-> tag_with_mck
349 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER
(xxs
,c
))) ib tin
),
350 (fun ib
-> tag_with_mck
351 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER
(xxs
,c
))) ib tin
)
354 | Ast_cocci.BEFOREAFTER
(xxs
, yys
, c
) ->
356 (fun ib
-> tag_with_mck
357 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFORE
(xxs
,c
))) ib tin
),
359 (fun ib
-> tag_with_mck
360 (Ast_cocci.CONTEXT
(pos,Ast_cocci.AFTER
(yys
,c
))) ib tin
),
361 (fun ib
-> tag_with_mck
362 (Ast_cocci.CONTEXT
(pos,Ast_cocci.BEFOREAFTER
(xxs
,yys
,c
)))
367 | Ast_cocci.PLUS _
-> raise Impossible
370 (* use new strategy, collect ii, sort, recollect and tag *)
372 let mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
) =
374 Visitor_c.default_visitor_c_s
with
375 Visitor_c.kinfo_s
= (fun (k
,bigf) i
->
376 let pos = Ast_c.info_to_fixpos i
in
378 | _
when Ast_cocci.equal_pos
pos maxpos
&&
379 Ast_cocci.equal_pos
pos minpos
-> bop i
380 | _
when Ast_cocci.equal_pos
pos maxpos
-> rop i
381 | _
when Ast_cocci.equal_pos
pos minpos
-> lop i
387 let distribute_mck_expr (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
388 Visitor_c.vk_expr_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
390 let distribute_mck_args (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
391 Visitor_c.vk_args_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
393 let distribute_mck_type (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
394 Visitor_c.vk_type_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
396 let distribute_mck_ini (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
397 Visitor_c.vk_ini_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
399 let distribute_mck_param (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) -> fun x
->
400 Visitor_c.vk_param_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
)) x
402 let distribute_mck_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
403 Visitor_c.vk_params_splitted_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
406 let distribute_mck_node (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->fun x
->
407 Visitor_c.vk_node_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
410 let distribute_mck_struct_fields (maxpos
, minpos
) =
411 fun (lop
,mop
,rop
,bop
) ->fun x
->
412 Visitor_c.vk_struct_fields_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
415 let distribute_mck_cst (maxpos
, minpos
) =
416 fun (lop
,mop
,rop
,bop
) ->fun x
->
417 Visitor_c.vk_cst_s
(mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
421 let distribute_mck_define_params (maxpos
, minpos
) = fun (lop
,mop
,rop
,bop
) ->
423 Visitor_c.vk_define_params_splitted_s
424 (mk_bigf (maxpos
, minpos
) (lop
,mop
,rop
,bop
))
429 | Ast_cocci.PLUS _
-> raise Impossible
430 | Ast_cocci.CONTEXT
(Ast_cocci.FixPos
(i1
,i2
),_
)
431 | Ast_cocci.MINUS
(Ast_cocci.FixPos
(i1
,i2
),_
,_
,_
) ->
432 Ast_cocci.FixPos
(i1
,i2
)
433 | Ast_cocci.CONTEXT
(Ast_cocci.DontCarePos
,_
)
434 | Ast_cocci.MINUS
(Ast_cocci.DontCarePos
,_
,_
,_
) ->
435 Ast_cocci.DontCarePos
436 | _
-> failwith
"weird: dont have position info for the mcodekind"
438 let distrf (ii_of_x_f
, distribute_mck_x_f
) =
439 fun ia x
-> fun tin
->
440 let mck = Ast_cocci.get_mcodekind ia
in
441 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
444 (* bug: check_pos mck max && check_pos mck min
446 * if do that then if have - f(...); and in C f(1,2); then we
447 * would get a "already tagged" because the '...' would sucess in
448 * transformaing both '1' and '1,2'. So being in the range is not
449 * enough. We must be equal exactly to the range!
451 (match get_pos mck with
452 | Ast_cocci.DontCarePos
-> true
453 | Ast_cocci.FixPos
(i1
, i2
) ->
454 i1
=*= min
&& i2
=*= max
455 | _
-> raise Impossible
461 distribute_mck mck (distribute_mck_x_f
(max
,min
)) x tin
466 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
, distribute_mck_expr)
467 let distrf_args = distrf (Lib_parsing_c.ii_of_args
, distribute_mck_args)
468 let distrf_type = distrf (Lib_parsing_c.ii_of_type
, distribute_mck_type)
469 let distrf_param = distrf (Lib_parsing_c.ii_of_param
, distribute_mck_param)
470 let distrf_params = distrf (Lib_parsing_c.ii_of_params
,distribute_mck_params)
471 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
,distribute_mck_ini)
472 let distrf_node = distrf (Lib_parsing_c.ii_of_node
,distribute_mck_node)
473 let distrf_struct_fields =
474 distrf (Lib_parsing_c.ii_of_struct_fields
, distribute_mck_struct_fields)
476 distrf (Lib_parsing_c.ii_of_cst
, distribute_mck_cst)
477 let distrf_define_params =
478 distrf (Lib_parsing_c.ii_of_define_params
,distribute_mck_define_params)
481 (* ------------------------------------------------------------------------*)
483 (* ------------------------------------------------------------------------*)
484 let meta_name_to_str (s1
, s2
) =
487 let envf keep inherited
= fun (s
, value, _
) f tin
->
488 let s = Ast_cocci.unwrap_mcode
s in
490 if keep
=*= Type_cocci.Saved
492 try Some
(List.assoc
s tin
.binding
)
495 "Don't find value for metavariable %s in the environment"
496 (meta_name_to_str s));
499 (* not raise Impossible! *)
506 (* Ex: in cocci_vs_c someone wants to add a binding. Here in
507 * transformation3 the value for this var may be already in the
508 * env, because for instance its value were fixed in a previous
509 * SmPL rule. So here we want to check that this is the same value.
510 * If forget to do the check, what can happen ? Because of Exp
511 * and other disjunctive feature of cocci_vs_c (>||>), we
512 * may accept a match at a wrong position. Maybe later this
513 * will be detected via the pos system on tokens, but maybe
514 * not. So safer to keep the check.
520 then Cocci_vs_c.equal_inh_metavarval
521 else Cocci_vs_c.equal_metavarval
in
522 if equal value value'
527 let check_idconstraint matcher c id
= fun f tin
-> f
() tin
528 let check_constraints_ne matcher constraints exp
= fun f tin
-> f
() tin
530 (* ------------------------------------------------------------------------*)
531 (* Environment, allbounds *)
532 (* ------------------------------------------------------------------------*)
533 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
534 true (* in transform we don't care ? *)
538 (*****************************************************************************)
540 (*****************************************************************************)
541 module TRANS
= Cocci_vs_c.COCCI_VS_C
(XTRANS
)
544 let transform_re_node a b tin
=
545 match TRANS.rule_elem_node a b tin
with
546 | None
-> raise Impossible
547 | Some
(_sp
, b'
) -> b'
549 let (transform2
: string (* rule name *) -> string list
(* dropped_isos *) ->
550 Lib_engine.metavars_binding
(* inherited bindings *) ->
551 Lib_engine.numbered_transformation_info
-> F.cflow
-> F.cflow
) =
552 fun rule_name dropped_isos binding0 xs cflow
->
555 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
556 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
557 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
558 current_rule_name
= rule_name
;
562 (* find the node, transform, update the node, and iter for all elements *)
564 xs
+> List.fold_left
(fun acc
(index
, (nodei
, binding
, rule_elem
)) ->
565 (* subtil: not cflow#nodes but acc#nodes *)
566 let node = acc#nodes#assoc nodei
in
568 if !Flag.show_transinfo
569 then pr2
"transform one node";
572 XTRANS.extra = {extra with index
= index
};
573 XTRANS.binding
= binding0
@binding
;
574 XTRANS.binding0
= []; (* not used - everything constant for trans *)
577 let node'
= transform_re_node rule_elem
node tin in
579 (* assert that have done something. But with metaruleElem sometimes
580 dont modify fake nodes. So special case before on Fake nodes. *)
581 (match F.unwrap
node with
582 | F.Enter
| F.Exit
| F.ErrorExit
583 | F.EndStatement _
| F.CaseNode _
585 | F.TrueNode
| F.FalseNode
| F.AfterNode
| F.FallThroughNode
587 | _
-> () (* assert (not (node =*= node')); *)
590 (* useless, we dont go back from flow to ast now *)
591 (* let node' = lastfix_comma_struct node' in *)
593 acc#replace_node
(nodei
, node'
);
599 let transform a b c d e
=
600 Common.profile_code
"Transformation3.transform"
601 (fun () -> transform2 a b c d e
)