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.
27 * Copyright (C) 2006, 2007 Ecole des Mines de Nantes
29 * This program is free software; you can redistribute it and/or
30 * modify it under the terms of the GNU General Public License (GPL)
31 * version 2 as published by the Free Software Foundation.
33 * This program is distributed in the hope that it will be useful,
34 * but WITHOUT ANY WARRANTY; without even the implied warranty of
35 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
36 * file license.txt for more details.
38 * This file was part of Coccinelle.
42 module Flag_engine
= Flag_matcher
43 (*****************************************************************************)
44 (* The functor argument *)
45 (*****************************************************************************)
47 (* info passed recursively in monad in addition to binding *)
49 optional_storage_iso
: bool;
50 optional_qualifier_iso
: bool;
51 value_format_iso
: bool;
54 module XMATCH
= struct
56 (* ------------------------------------------------------------------------*)
57 (* Combinators history *)
58 (* ------------------------------------------------------------------------*)
61 * type ('a, 'b) matcher = 'a -> 'b -> bool
63 * version1: same but with a global variable holding the current binding
65 * - can have multiple possibilities
67 * - sometimes have to undo, cos if start match, then it binds,
68 * and if later it does not match, then must undo the first binds.
69 * ex: when match parameters, can try to match, but then we found far
70 * later that the last argument of a function does not match
71 * => have to uando the binding !!!
72 * (can handle that too with a global, by saving the
73 * global, ... but sux)
74 * => better not use global
77 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
79 * Empty list mean failure (let matchfailure = []).
80 * To be able to have pretty code, have to use partial application
81 * powa, and so the type is in fact
84 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
86 * Then by defining the correct combinators, can have quite pretty code (that
87 * looks like the clean code of version0).
89 * opti: return a lazy list of possible matchs ?
91 * version4: type tin = Lib_engine.metavars_binding
94 (* ------------------------------------------------------------------------*)
95 (* Standard type and operators *)
96 (* ------------------------------------------------------------------------*)
100 binding
: Lib_engine.metavars_binding
;
101 binding0
: Lib_engine.metavars_binding
; (* inherited bindings *)
103 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
104 (* opti? use set instead of list *)
105 type 'x tout
= ('x
* Lib_engine.metavars_binding
) list
107 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
110 let (>>=) m1 m2
= fun tin
->
112 let xxs = xs +> List.map
(fun ((a
,b
), binding
) ->
113 m2 a b
{tin
with binding
= binding
}
117 (* Je compare les bindings retournés par les differentes branches.
118 * Si la deuxieme branche amene a des bindings qui sont deja presents
119 * dans la premiere branche, alors je ne les accepte pas.
121 * update: still useful now that julia better handle Exp directly via
122 * ctl tricks using positions ?
124 let (>|+|>) m1 m2
= fun tin
->
133 let list_bindings_already = List.map snd
res1 in
135 (res2 +> List.filter
(fun (x
, binding
) ->
137 (list_bindings_already +> List.exists
(fun already
->
138 Lib_engine.equal_binding binding already
))
144 let (>||>) m1 m2
= fun tin
->
151 (* opti? use set instead of list *)
154 if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
157 let return res
= fun tin
->
160 let fail = fun tin
->
163 let (>&&>) f m
= fun tin
->
169 let mode = Cocci_vs_c.PatternMode
171 (* ------------------------------------------------------------------------*)
173 (* ------------------------------------------------------------------------*)
174 let cocciExp = fun expf expa node
-> fun tin
->
176 let globals = ref [] in
179 Visitor_c.default_visitor_c
with
180 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
181 match expf expa expb tin
with
182 | [] -> (* failed *) k expb
184 globals := xs @ !globals;
185 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
188 * push2 expr globals; k expr
190 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
196 Visitor_c.vk_node
bigf node
;
197 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
201 (* same as cocciExp, but for expressions in an expression, not expressions
203 let cocciExpExp = fun expf expa expb
-> fun tin
->
205 let globals = ref [] in
208 Visitor_c.default_visitor_c
with
209 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
210 match expf expa expb tin
with
211 | [] -> (* failed *) k expb
213 globals := xs @ !globals;
214 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
217 * push2 expr globals; k expr
219 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
225 Visitor_c.vk_expr
bigf expb
;
226 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
230 let cocciTy = fun expf expa node
-> fun tin
->
232 let globals = ref [] in
234 Visitor_c.default_visitor_c
with
235 Visitor_c.ktype
= (fun (k
, bigf) expb
->
236 match expf expa expb tin
with
237 | [] -> (* failed *) k expb
238 | xs -> globals := xs @ !globals);
242 Visitor_c.vk_node
bigf node
;
243 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
247 let cocciInit = fun expf expa node
-> fun tin
->
249 let globals = ref [] in
251 Visitor_c.default_visitor_c
with
252 Visitor_c.kini
= (fun (k
, bigf) expb
->
253 match expf expa expb tin
with
254 | [] -> (* failed *) k expb
255 | xs -> globals := xs @ !globals);
259 Visitor_c.vk_node
bigf node
;
260 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
265 (* ------------------------------------------------------------------------*)
266 (* Distribute mcode *)
267 (* ------------------------------------------------------------------------*)
268 let tag_mck_pos mck posmck
=
270 | Ast_cocci.PLUS c
-> Ast_cocci.PLUS c
271 | Ast_cocci.CONTEXT
(pos
, xs) ->
272 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
273 Ast_cocci.CONTEXT
(posmck
, xs)
274 | Ast_cocci.MINUS
(pos
, inst
, adj
, xs) ->
275 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
276 Ast_cocci.MINUS
(posmck
, inst
, adj
, xs)
279 let tag_mck_pos_mcode (x
,info
,mck
,pos
) posmck stuff
= fun tin
->
280 [((x
, info
, tag_mck_pos mck posmck
, pos
),stuff
), tin
.binding
]
283 let distrf (ii_of_x_f
) =
284 fun mcode x
-> fun tin
->
285 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
287 let posmck = Ast_cocci.FixPos
(min
, max
) (* subtil: and not max, min !!*)
289 tag_mck_pos_mcode mcode
posmck x tin
291 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
)
292 let distrf_args = distrf (Lib_parsing_c.ii_of_args
)
293 let distrf_type = distrf (Lib_parsing_c.ii_of_type
)
294 let distrf_param = distrf (Lib_parsing_c.ii_of_param
)
295 let distrf_params = distrf (Lib_parsing_c.ii_of_params
)
296 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
)
297 let distrf_inis = distrf (Lib_parsing_c.ii_of_inis
)
298 let distrf_decl = distrf (Lib_parsing_c.ii_of_decl
)
299 let distrf_field = distrf (Lib_parsing_c.ii_of_field
)
300 let distrf_node = distrf (Lib_parsing_c.ii_of_node
)
301 let distrf_enum_fields = distrf (Lib_parsing_c.ii_of_enum_fields
)
302 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields
)
303 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst
)
304 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params
)
307 (* ------------------------------------------------------------------------*)
308 (* Constraints on metavariable values *)
309 (* ------------------------------------------------------------------------*)
310 let check_idconstraint matcher c id
= fun f tin
->
318 let check_constraints_ne matcher constraints exp
= fun f tin
->
319 let rec loop = function
320 [] -> f
() tin
(* success *)
322 match matcher c exp tin
with
323 [] (* failure *) -> loop cs
324 | _
(* success *) -> fail tin
in
327 let check_pos_constraints constraints pvalu f tin
=
330 let success = [[]] in
332 (* relies on the fact that constraints on pos variables must refer to
333 inherited variables *)
334 (match Common.optionise
(fun () -> tin
.binding0
+> List.assoc c
) with
336 if Cocci_vs_c.equal_inh_metavarval exp valu'
337 then success else failure
339 (* if the variable is not there, it puts no constraints *)
340 (* not sure this is still useful *)
342 constraints pvalu f tin
344 (* ------------------------------------------------------------------------*)
346 (* ------------------------------------------------------------------------*)
347 (* pre: if have declared a new metavar that hide another one, then
348 * must be passed with a binding that deleted this metavar
350 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
351 * besoin de garder le X en interne, meme si julia s'en fout elle du
352 * X et qu'elle a mis X a DontSaved.
354 let check_add_metavars_binding strip _keep inherited
= fun (k
, valu
) tin
->
357 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc k
) with
359 if Cocci_vs_c.equal_inh_metavarval valu valu'
360 then Some tin
.binding
364 match Common.optionise
(fun () -> tin
.binding
+> List.assoc k
) with
366 if Cocci_vs_c.equal_metavarval valu valu'
367 then Some tin
.binding
372 Some
(tin
.binding
+> Common.insert_assoc
(k
, valu'
)) in
374 Ast_c.MetaIdVal
(a
,c
) ->
375 (* c is a negated constraint *)
376 let rec loop = function
377 [] -> success(Ast_c.MetaIdVal
(a
,[]))
381 (fun () -> tin
.binding0
+> List.assoc c
) in
383 Some
(Ast_c.MetaIdVal
(v
,_
)) ->
385 then None
(* failure *)
386 else success(Ast_c.MetaIdVal
(a
,[]))
387 | Some _
-> failwith
"Not possible"
388 | None
-> success(Ast_c.MetaIdVal
(a
,[]))) in
390 | Ast_c.MetaFuncVal a
->
391 success(Ast_c.MetaFuncVal a
)
392 | Ast_c.MetaLocalFuncVal a
->
393 success(Ast_c.MetaLocalFuncVal a
) (*more?*)
394 | Ast_c.MetaExprVal
(a
,c
) ->
395 (* c in the value is only to prepare for the future in which
396 we figure out how to have subterm constraints on unbound
397 variables. Now an environment will only contain expression
398 values with empty constraints, as all constraints are
399 resolved at binding time *)
402 then Lib_parsing_c.al_expr a
403 else Lib_parsing_c.semi_al_expr a
in
404 let inh_stripped = Lib_parsing_c.al_inh_expr a
in
405 let rec loop = function
406 [] -> success(Ast_c.MetaExprVal
(stripped,[]))
410 (fun () -> tin
.binding0
+> List.assoc c
) in
412 Some
(Ast_c.MetaExprVal
(v
,_
)) ->
413 if C_vs_c.subexpression_of_expression
inh_stripped v
414 then loop cs
(* forget satisfied constraints *)
415 else None
(* failure *)
416 | Some _
-> failwith
"not possible"
417 (* fail if this should be a subterm of something that
421 | Ast_c.MetaExprListVal a
->
423 (Ast_c.MetaExprListVal
425 then Lib_parsing_c.al_arguments a
426 else Lib_parsing_c.semi_al_arguments a
))
428 | Ast_c.MetaDeclVal a
->
432 then Lib_parsing_c.al_declaration a
433 else Lib_parsing_c.semi_al_declaration a
))
434 | Ast_c.MetaFieldVal a
->
438 then Lib_parsing_c.al_field a
439 else Lib_parsing_c.semi_al_field a
))
440 | Ast_c.MetaStmtVal a
->
444 then Lib_parsing_c.al_statement a
445 else Lib_parsing_c.semi_al_statement a
))
446 | Ast_c.MetaTypeVal a
->
450 then Lib_parsing_c.al_type a
451 else Lib_parsing_c.semi_al_type a
))
453 | Ast_c.MetaInitVal a
->
457 then Lib_parsing_c.al_init a
458 else Lib_parsing_c.semi_al_init a
))
460 | Ast_c.MetaListlenVal a
-> success(Ast_c.MetaListlenVal a
)
462 | Ast_c.MetaParamVal a
->
466 then Lib_parsing_c.al_param a
467 else Lib_parsing_c.semi_al_param a
))
468 | Ast_c.MetaParamListVal a
->
470 (Ast_c.MetaParamListVal
472 then Lib_parsing_c.al_params a
473 else Lib_parsing_c.semi_al_params a
))
475 | Ast_c.MetaPosVal
(pos1
,pos2
) ->
476 success(Ast_c.MetaPosVal
(pos1
,pos2
))
477 | Ast_c.MetaPosValList l
-> success (Ast_c.MetaPosValList l
))
479 let envf keep inherited
= fun (k
, valu
, get_max_min
) f tin
->
480 let x = Ast_cocci.unwrap_mcode k
in
481 match check_add_metavars_binding true keep inherited
(x, valu
) tin
with
483 let new_tin = {tin
with binding
= binding
} in
484 (match Ast_cocci.get_pos_var k
with
485 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
487 let (file
,current_element
,min
,max
) = get_max_min
() in
488 Ast_c.MetaPosValList
[(file
,current_element
,min
,max
)] in
489 (* check constraints. success means that there is a match with
490 one of the constraints, which will ultimately result in
492 check_pos_constraints constraints
pvalu
494 (* constraints are satisfied, now see if we are compatible
495 with existing bindings *)
497 let x = Ast_cocci.unwrap_mcode name
in
499 check_add_metavars_binding false keep inherited
(x, pvalu)
502 f
() {new_tin with binding
= binding
}
505 | Ast_cocci.NoMetaPos
-> f
() new_tin)
508 (* ------------------------------------------------------------------------*)
509 (* Environment, allbounds *)
510 (* ------------------------------------------------------------------------*)
511 (* all referenced inherited variables have to be bound. This would
512 * be naturally checked for the minus or context ones in the
513 * matching process, but have to check the plus ones as well. The
514 * result of get_inherited contains all of these, but the potential
515 * redundant checking for the minus and context ones is probably not
516 * a big deal. If it's a problem, could fix free_vars to distinguish
517 * between + variables and the other ones. *)
519 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
520 l
+> List.for_all
(fun inhvar
->
521 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc inhvar
) with
526 let optional_storage_flag f
= fun tin
->
527 f
(tin
.extra
.optional_storage_iso
) tin
529 let optional_qualifier_flag f
= fun tin
->
530 f
(tin
.extra
.optional_qualifier_iso
) tin
532 let value_format_flag f
= fun tin
->
533 f
(tin
.extra
.value_format_iso
) tin
536 (* ------------------------------------------------------------------------*)
538 (* ------------------------------------------------------------------------*)
539 let tokenf ia ib
= fun tin
->
540 let pos = Ast_c.info_to_fixpos ib
in
541 let posmck = Ast_cocci.FixPos
(pos, pos) in
542 let finish tin
= tag_mck_pos_mcode ia
posmck ib tin
in
543 match Ast_cocci.get_pos_var ia
with
544 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
545 let mpos = Lib_parsing_c.lin_col_by_pos
[ib
] in
546 let pvalu = Ast_c.MetaPosValList
[mpos] in
547 check_pos_constraints constraints
pvalu
549 (* constraints are satisfied, now see if we are compatible
550 with existing bindings *)
552 let x = Ast_cocci.unwrap_mcode name
in
554 check_add_metavars_binding false keep inherited
(x, pvalu) tin
556 Some binding
-> finish {tin
with binding
= binding
}
561 let tokenf_mck mck ib
= fun tin
->
562 let pos = Ast_c.info_to_fixpos ib
in
563 let posmck = Ast_cocci.FixPos
(pos, pos) in
564 [(tag_mck_pos mck
posmck, ib
), tin
.binding
]
568 (*****************************************************************************)
570 (*****************************************************************************)
571 module MATCH
= Cocci_vs_c.COCCI_VS_C
(XMATCH
)
574 let match_re_node2 dropped_isos a b binding0
=
578 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
579 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
580 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
583 XMATCH.binding0
= binding0
;
586 MATCH.rule_elem_node a b
tin
587 (* take only the tagged-SP, the 'a' *)
588 +> List.map
(fun ((a
,_b
), binding
) -> a
, binding
)
591 let match_re_node a b c d
=
592 Common.profile_code
"Pattern3.match_re_node"
593 (fun () -> match_re_node2 a b c d
)