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 module Flag_engine
= Flag_matcher
28 (*****************************************************************************)
29 (* The functor argument *)
30 (*****************************************************************************)
32 (* info passed recursively in monad in addition to binding *)
34 optional_storage_iso
: bool;
35 optional_qualifier_iso
: bool;
36 value_format_iso
: bool;
39 module XMATCH
= struct
41 (* ------------------------------------------------------------------------*)
42 (* Combinators history *)
43 (* ------------------------------------------------------------------------*)
46 * type ('a, 'b) matcher = 'a -> 'b -> bool
48 * version1: same but with a global variable holding the current binding
50 * - can have multiple possibilities
52 * - sometimes have to undo, cos if start match, then it binds,
53 * and if later it does not match, then must undo the first binds.
54 * ex: when match parameters, can try to match, but then we found far
55 * later that the last argument of a function does not match
56 * => have to uando the binding !!!
57 * (can handle that too with a global, by saving the
58 * global, ... but sux)
59 * => better not use global
62 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
64 * Empty list mean failure (let matchfailure = []).
65 * To be able to have pretty code, have to use partial application
66 * powa, and so the type is in fact
69 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
71 * Then by defining the correct combinators, can have quite pretty code (that
72 * looks like the clean code of version0).
74 * opti: return a lazy list of possible matchs ?
76 * version4: type tin = Lib_engine.metavars_binding
79 (* ------------------------------------------------------------------------*)
80 (* Standard type and operators *)
81 (* ------------------------------------------------------------------------*)
85 binding
: Lib_engine.metavars_binding
;
86 binding0
: Lib_engine.metavars_binding
; (* inherited bindings *)
88 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
89 (* opti? use set instead of list *)
90 type 'x tout
= ('x
* Lib_engine.metavars_binding
) list
92 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
95 let (>>=) m1 m2
= fun tin
->
97 let xxs = xs +> List.map
(fun ((a
,b
), binding
) ->
98 m2 a b
{tin
with binding
= binding
}
102 (* Je compare les bindings retournés par les differentes branches.
103 * Si la deuxieme branche amene a des bindings qui sont deja presents
104 * dans la premiere branche, alors je ne les accepte pas.
106 * update: still useful now that julia better handle Exp directly via
107 * ctl tricks using positions ?
109 let (>|+|>) m1 m2
= fun tin
->
118 let list_bindings_already = List.map snd
res1 in
120 (res2 +> List.filter
(fun (x
, binding
) ->
122 (list_bindings_already +> List.exists
(fun already
->
123 Lib_engine.equal_binding binding already
))
129 let (>||>) m1 m2
= fun tin
->
136 (* opti? use set instead of list *)
139 if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
142 let return res
= fun tin
->
145 let fail = fun tin
->
148 let (>&&>) f m
= fun tin
->
154 let mode = Cocci_vs_c.PatternMode
156 (* ------------------------------------------------------------------------*)
158 (* ------------------------------------------------------------------------*)
159 let cocciExp = fun expf expa node
-> fun tin
->
161 let globals = ref [] in
164 Visitor_c.default_visitor_c
with
165 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
166 match expf expa expb tin
with
167 | [] -> (* failed *) k expb
169 globals := xs @ !globals;
170 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
173 * push2 expr globals; k expr
175 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
181 Visitor_c.vk_node
bigf node
;
182 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
186 (* same as cocciExp, but for expressions in an expression, not expressions
188 let cocciExpExp = fun expf expa expb
-> fun tin
->
190 let globals = ref [] in
193 Visitor_c.default_visitor_c
with
194 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
195 match expf expa expb tin
with
196 | [] -> (* failed *) k expb
198 globals := xs @ !globals;
199 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
202 * push2 expr globals; k expr
204 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
210 Visitor_c.vk_expr
bigf expb
;
211 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
215 let cocciTy = fun expf expa node
-> fun tin
->
217 let globals = ref [] in
219 Visitor_c.default_visitor_c
with
220 Visitor_c.ktype
= (fun (k
, bigf) expb
->
221 match expf expa expb tin
with
222 | [] -> (* failed *) k expb
223 | xs -> globals := xs @ !globals);
227 Visitor_c.vk_node
bigf node
;
228 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
232 let cocciInit = fun expf expa node
-> fun tin
->
234 let globals = ref [] in
236 Visitor_c.default_visitor_c
with
237 Visitor_c.kini
= (fun (k
, bigf) expb
->
238 match expf expa expb tin
with
239 | [] -> (* failed *) k expb
240 | xs -> globals := xs @ !globals);
244 Visitor_c.vk_node
bigf node
;
245 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
250 (* ------------------------------------------------------------------------*)
251 (* Distribute mcode *)
252 (* ------------------------------------------------------------------------*)
253 let tag_mck_pos mck posmck
=
255 | Ast_cocci.PLUS c
-> Ast_cocci.PLUS c
256 | Ast_cocci.CONTEXT
(pos
, xs) ->
257 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
258 Ast_cocci.CONTEXT
(posmck
, xs)
259 | Ast_cocci.MINUS
(pos
, inst
, adj
, xs) ->
260 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
261 Ast_cocci.MINUS
(posmck
, inst
, adj
, xs)
264 let tag_mck_pos_mcode (x
,info
,mck
,pos
) posmck stuff
= fun tin
->
265 [((x
, info
, tag_mck_pos mck posmck
, pos
),stuff
), tin
.binding
]
268 let distrf (ii_of_x_f
) =
269 fun mcode x
-> fun tin
->
270 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
272 let posmck = Ast_cocci.FixPos
(min
, max
) (* subtil: and not max, min !!*)
274 tag_mck_pos_mcode mcode
posmck x tin
276 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
)
277 let distrf_args = distrf (Lib_parsing_c.ii_of_args
)
278 let distrf_type = distrf (Lib_parsing_c.ii_of_type
)
279 let distrf_param = distrf (Lib_parsing_c.ii_of_param
)
280 let distrf_params = distrf (Lib_parsing_c.ii_of_params
)
281 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
)
282 let distrf_inis = distrf (Lib_parsing_c.ii_of_inis
)
283 let distrf_decl = distrf (Lib_parsing_c.ii_of_decl
)
284 let distrf_field = distrf (Lib_parsing_c.ii_of_field
)
285 let distrf_node = distrf (Lib_parsing_c.ii_of_node
)
286 let distrf_enum_fields = distrf (Lib_parsing_c.ii_of_enum_fields
)
287 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields
)
288 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst
)
289 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params
)
292 (* ------------------------------------------------------------------------*)
293 (* Constraints on metavariable values *)
294 (* ------------------------------------------------------------------------*)
295 let check_idconstraint matcher c id
= fun f tin
->
303 let check_constraints_ne matcher constraints exp
= fun f tin
->
304 let rec loop = function
305 [] -> f
() tin
(* success *)
307 match matcher c exp tin
with
308 [] (* failure *) -> loop cs
309 | _
(* success *) -> fail tin
in
312 let check_pos_constraints constraints pvalu f tin
=
315 let success = [[]] in
317 (* relies on the fact that constraints on pos variables must refer to
318 inherited variables *)
319 (match Common.optionise
(fun () -> tin
.binding0
+> List.assoc c
) with
321 if Cocci_vs_c.equal_inh_metavarval exp valu'
322 then success else failure
324 (* if the variable is not there, it puts no constraints *)
325 (* not sure this is still useful *)
327 constraints pvalu f tin
329 (* ------------------------------------------------------------------------*)
331 (* ------------------------------------------------------------------------*)
332 (* pre: if have declared a new metavar that hide another one, then
333 * must be passed with a binding that deleted this metavar
335 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
336 * besoin de garder le X en interne, meme si julia s'en fout elle du
337 * X et qu'elle a mis X a DontSaved.
339 let check_add_metavars_binding strip _keep inherited
= fun (k
, valu
) tin
->
342 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc k
) with
344 if Cocci_vs_c.equal_inh_metavarval valu valu'
345 then Some tin
.binding
349 match Common.optionise
(fun () -> tin
.binding
+> List.assoc k
) with
351 if Cocci_vs_c.equal_metavarval valu valu'
352 then Some tin
.binding
357 Some
(tin
.binding
+> Common.insert_assoc
(k
, valu'
)) in
359 Ast_c.MetaIdVal
(a
,c
) ->
360 (* c is a negated constraint *)
361 let rec loop = function
362 [] -> success(Ast_c.MetaIdVal
(a
,[]))
366 (fun () -> tin
.binding0
+> List.assoc c
) in
368 Some
(Ast_c.MetaIdVal
(v
,_
)) ->
370 then None
(* failure *)
371 else success(Ast_c.MetaIdVal
(a
,[]))
372 | Some _
-> failwith
"Not possible"
373 | None
-> success(Ast_c.MetaIdVal
(a
,[]))) in
375 | Ast_c.MetaFuncVal a
->
376 success(Ast_c.MetaFuncVal a
)
377 | Ast_c.MetaLocalFuncVal a
->
378 success(Ast_c.MetaLocalFuncVal a
) (*more?*)
379 | Ast_c.MetaExprVal
(a
,c
) ->
380 (* c in the value is only to prepare for the future in which
381 we figure out how to have subterm constraints on unbound
382 variables. Now an environment will only contain expression
383 values with empty constraints, as all constraints are
384 resolved at binding time *)
387 then Lib_parsing_c.al_expr a
388 else Lib_parsing_c.semi_al_expr a
in
389 let inh_stripped = Lib_parsing_c.al_inh_expr a
in
390 let rec loop = function
391 [] -> success(Ast_c.MetaExprVal
(stripped,[]))
395 (fun () -> tin
.binding0
+> List.assoc c
) in
397 Some
(Ast_c.MetaExprVal
(v
,_
)) ->
398 if C_vs_c.subexpression_of_expression
inh_stripped v
399 then loop cs
(* forget satisfied constraints *)
400 else None
(* failure *)
401 | Some _
-> failwith
"not possible"
402 (* fail if this should be a subterm of something that
406 | Ast_c.MetaExprListVal a
->
408 (Ast_c.MetaExprListVal
410 then Lib_parsing_c.al_arguments a
411 else Lib_parsing_c.semi_al_arguments a
))
413 | Ast_c.MetaDeclVal a
->
417 then Lib_parsing_c.al_declaration a
418 else Lib_parsing_c.semi_al_declaration a
))
419 | Ast_c.MetaFieldVal a
->
423 then Lib_parsing_c.al_field a
424 else Lib_parsing_c.semi_al_field a
))
425 | Ast_c.MetaStmtVal a
->
429 then Lib_parsing_c.al_statement a
430 else Lib_parsing_c.semi_al_statement a
))
431 | Ast_c.MetaTypeVal a
->
435 then Lib_parsing_c.al_type a
436 else Lib_parsing_c.semi_al_type a
))
438 | Ast_c.MetaInitVal a
->
442 then Lib_parsing_c.al_init a
443 else Lib_parsing_c.semi_al_init a
))
445 | Ast_c.MetaListlenVal a
-> success(Ast_c.MetaListlenVal a
)
447 | Ast_c.MetaParamVal a
->
451 then Lib_parsing_c.al_param a
452 else Lib_parsing_c.semi_al_param a
))
453 | Ast_c.MetaParamListVal a
->
455 (Ast_c.MetaParamListVal
457 then Lib_parsing_c.al_params a
458 else Lib_parsing_c.semi_al_params a
))
460 | Ast_c.MetaPosVal
(pos1
,pos2
) ->
461 success(Ast_c.MetaPosVal
(pos1
,pos2
))
462 | Ast_c.MetaPosValList l
-> success (Ast_c.MetaPosValList l
))
464 let envf keep inherited
= fun (k
, valu
, get_max_min
) f tin
->
465 let x = Ast_cocci.unwrap_mcode k
in
466 match check_add_metavars_binding true keep inherited
(x, valu
) tin
with
468 let new_tin = {tin
with binding
= binding
} in
469 (match Ast_cocci.get_pos_var k
with
470 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
472 let (file
,current_element
,min
,max
) = get_max_min
() in
473 Ast_c.MetaPosValList
[(file
,current_element
,min
,max
)] in
474 (* check constraints. success means that there is a match with
475 one of the constraints, which will ultimately result in
477 check_pos_constraints constraints
pvalu
479 (* constraints are satisfied, now see if we are compatible
480 with existing bindings *)
482 let x = Ast_cocci.unwrap_mcode name
in
484 check_add_metavars_binding false keep inherited
(x, pvalu)
487 f
() {new_tin with binding
= binding
}
490 | Ast_cocci.NoMetaPos
-> f
() new_tin)
493 (* ------------------------------------------------------------------------*)
494 (* Environment, allbounds *)
495 (* ------------------------------------------------------------------------*)
496 (* all referenced inherited variables have to be bound. This would
497 * be naturally checked for the minus or context ones in the
498 * matching process, but have to check the plus ones as well. The
499 * result of get_inherited contains all of these, but the potential
500 * redundant checking for the minus and context ones is probably not
501 * a big deal. If it's a problem, could fix free_vars to distinguish
502 * between + variables and the other ones. *)
504 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
505 l
+> List.for_all
(fun inhvar
->
506 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc inhvar
) with
511 let optional_storage_flag f
= fun tin
->
512 f
(tin
.extra
.optional_storage_iso
) tin
514 let optional_qualifier_flag f
= fun tin
->
515 f
(tin
.extra
.optional_qualifier_iso
) tin
517 let value_format_flag f
= fun tin
->
518 f
(tin
.extra
.value_format_iso
) tin
520 (* ------------------------------------------------------------------------*)
522 (* ------------------------------------------------------------------------*)
523 let tokenf ia ib
= fun tin
->
524 let pos = Ast_c.info_to_fixpos ib
in
525 let posmck = Ast_cocci.FixPos
(pos, pos) in
526 let finish tin
= tag_mck_pos_mcode ia
posmck ib tin
in
527 match Ast_cocci.get_pos_var ia
with
528 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
529 let mpos = Lib_parsing_c.lin_col_by_pos
[ib
] in
530 let pvalu = Ast_c.MetaPosValList
[mpos] in
531 check_pos_constraints constraints
pvalu
533 (* constraints are satisfied, now see if we are compatible
534 with existing bindings *)
536 let x = Ast_cocci.unwrap_mcode name
in
538 check_add_metavars_binding false keep inherited
(x, pvalu) tin
540 Some binding
-> finish {tin
with binding
= binding
}
545 let tokenf_mck mck ib
= fun tin
->
546 let pos = Ast_c.info_to_fixpos ib
in
547 let posmck = Ast_cocci.FixPos
(pos, pos) in
548 [(tag_mck_pos mck
posmck, ib
), tin
.binding
]
552 (*****************************************************************************)
554 (*****************************************************************************)
555 module MATCH
= Cocci_vs_c.COCCI_VS_C
(XMATCH
)
558 let match_re_node2 dropped_isos a b binding0
=
562 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
563 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
564 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
567 XMATCH.binding0
= binding0
;
570 MATCH.rule_elem_node a b
tin
571 (* take only the tagged-SP, the 'a' *)
572 +> List.map
(fun ((a
,_b
), binding
) -> a
, binding
)
575 let match_re_node a b c d
=
576 Common.profile_code
"Pattern3.match_re_node"
577 (fun () -> match_re_node2 a b c d
)