2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
29 module Flag_engine
= Flag_matcher
30 (*****************************************************************************)
31 (* The functor argument *)
32 (*****************************************************************************)
34 (* info passed recursively in monad in addition to binding *)
36 optional_storage_iso
: bool;
37 optional_qualifier_iso
: bool;
38 value_format_iso
: bool;
39 optional_declarer_semicolon_iso
: bool;
42 module XMATCH
= struct
44 (* ------------------------------------------------------------------------*)
45 (* Combinators history *)
46 (* ------------------------------------------------------------------------*)
49 * type ('a, 'b) matcher = 'a -> 'b -> bool
51 * version1: same but with a global variable holding the current binding
53 * - can have multiple possibilities
55 * - sometimes have to undo, cos if start match, then it binds,
56 * and if later it does not match, then must undo the first binds.
57 * ex: when match parameters, can try to match, but then we found far
58 * later that the last argument of a function does not match
59 * => have to uando the binding !!!
60 * (can handle that too with a global, by saving the
61 * global, ... but sux)
62 * => better not use global
65 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
67 * Empty list mean failure (let matchfailure = []).
68 * To be able to have pretty code, have to use partial application
69 * powa, and so the type is in fact
72 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
74 * Then by defining the correct combinators, can have quite pretty code (that
75 * looks like the clean code of version0).
77 * opti: return a lazy list of possible matchs ?
79 * version4: type tin = Lib_engine.metavars_binding
82 (* ------------------------------------------------------------------------*)
83 (* Standard type and operators *)
84 (* ------------------------------------------------------------------------*)
88 binding
: Lib_engine.metavars_binding
;
89 binding0
: Lib_engine.metavars_binding
; (* inherited bindings *)
91 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
92 (* opti? use set instead of list *)
93 type 'x tout
= ('x
* Lib_engine.metavars_binding
) list
95 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
98 let (>>=) m1 m2
= fun tin
->
100 let xxs = xs +> List.map
(fun ((a
,b
), binding
) ->
101 m2 a b
{tin
with binding
= binding
}
105 (* Je compare les bindings retournés par les differentes branches.
106 * Si la deuxieme branche amene a des bindings qui sont deja presents
107 * dans la premiere branche, alors je ne les accepte pas.
109 * update: still useful now that julia better handle Exp directly via
110 * ctl tricks using positions ?
112 let (>|+|>) m1 m2
= fun tin
->
121 let list_bindings_already = List.map snd
res1 in
123 (res2 +> List.filter
(fun (x
, binding
) ->
125 (list_bindings_already +> List.exists
(fun already
->
126 Lib_engine.equal_binding binding already
))
132 let (>||>) m1 m2
= fun tin
->
139 (* opti? use set instead of list *)
142 if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
145 let return res
= fun tin
->
148 let fail = fun tin
->
151 let (>&&>) f m
= fun tin
->
157 let mode = Cocci_vs_c.PatternMode
159 (* ------------------------------------------------------------------------*)
161 (* ------------------------------------------------------------------------*)
162 let cocciExp = fun expf expa node
-> fun tin
->
164 let globals = ref [] in
167 Visitor_c.default_visitor_c
with
168 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
169 match expf expa expb tin
with
170 | [] -> (* failed *) k expb
172 globals := xs @ !globals;
173 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
176 * push2 expr globals; k expr
178 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
184 Visitor_c.vk_node
bigf node
;
185 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
189 (* same as cocciExp, but for expressions in an expression, not expressions
191 let cocciExpExp = fun expf expa expb
-> fun tin
->
193 let globals = ref [] in
196 Visitor_c.default_visitor_c
with
197 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
198 match expf expa expb tin
with
199 | [] -> (* failed *) k expb
201 globals := xs @ !globals;
202 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
205 * push2 expr globals; k expr
207 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
213 Visitor_c.vk_expr
bigf expb
;
214 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
218 let cocciTy = fun expf expa node
-> fun tin
->
220 let globals = ref [] in
222 Visitor_c.default_visitor_c
with
223 Visitor_c.ktype
= (fun (k
, bigf) expb
->
224 match expf expa expb tin
with
225 | [] -> (* failed *) k expb
226 | xs -> globals := xs @ !globals);
230 Visitor_c.vk_node
bigf node
;
231 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
235 let cocciInit = fun expf expa node
-> fun tin
->
237 let globals = ref [] in
239 Visitor_c.default_visitor_c
with
240 Visitor_c.kini
= (fun (k
, bigf) expb
->
241 match expf expa expb tin
with
242 | [] -> (* failed *) k expb
243 | xs -> globals := xs @ !globals);
247 Visitor_c.vk_node
bigf node
;
248 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
253 (* ------------------------------------------------------------------------*)
254 (* Distribute mcode *)
255 (* ------------------------------------------------------------------------*)
256 let tag_mck_pos mck posmck
=
258 | Ast_cocci.PLUS c
-> Ast_cocci.PLUS c
259 | Ast_cocci.CONTEXT
(pos
, xs) ->
260 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
261 Ast_cocci.CONTEXT
(posmck
, xs)
262 | Ast_cocci.MINUS
(pos
, inst
, adj
, xs) ->
263 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
264 Ast_cocci.MINUS
(posmck
, inst
, adj
, xs)
267 let tag_mck_pos_mcode (x
,info
,mck
,pos
) posmck stuff
= fun tin
->
268 [((x
, info
, tag_mck_pos mck posmck
, pos
),stuff
), tin
.binding
]
271 let distrf (ii_of_x_f
) =
272 fun mcode x
-> fun tin
->
273 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
275 let posmck = Ast_cocci.FixPos
(min
, max
) (* subtil: and not max, min !!*)
277 tag_mck_pos_mcode mcode
posmck x tin
279 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
)
280 let distrf_args = distrf (Lib_parsing_c.ii_of_args
)
281 let distrf_type = distrf (Lib_parsing_c.ii_of_type
)
282 let distrf_param = distrf (Lib_parsing_c.ii_of_param
)
283 let distrf_params = distrf (Lib_parsing_c.ii_of_params
)
284 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
)
285 let distrf_inis = distrf (Lib_parsing_c.ii_of_inis
)
286 let distrf_decl = distrf (Lib_parsing_c.ii_of_decl
)
287 let distrf_field = distrf (Lib_parsing_c.ii_of_field
)
288 let distrf_node = distrf (Lib_parsing_c.ii_of_node
)
289 let distrf_enum_fields = distrf (Lib_parsing_c.ii_of_enum_fields
)
290 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields
)
291 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst
)
292 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params
)
295 (* ------------------------------------------------------------------------*)
296 (* Constraints on metavariable values *)
297 (* ------------------------------------------------------------------------*)
298 let check_idconstraint matcher c id
= fun f tin
->
306 let check_constraints_ne matcher constraints exp
= fun f tin
->
307 let rec loop = function
308 [] -> f
() tin
(* success *)
310 match matcher c exp tin
with
311 [] (* failure *) -> loop cs
312 | _
(* success *) -> fail tin
in
315 let check_pos_constraints constraints pvalu f tin
=
318 let success = [[]] in
320 (* relies on the fact that constraints on pos variables must refer to
321 inherited variables *)
322 (match Common.optionise
(fun () -> tin
.binding0
+> List.assoc c
) with
324 if Cocci_vs_c.equal_inh_metavarval exp valu'
325 then success else failure
327 (* if the variable is not there, it puts no constraints *)
328 (* not sure this is still useful *)
330 constraints pvalu f tin
332 (* ------------------------------------------------------------------------*)
334 (* ------------------------------------------------------------------------*)
335 (* pre: if have declared a new metavar that hide another one, then
336 * must be passed with a binding that deleted this metavar
338 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
339 * besoin de garder le X en interne, meme si julia s'en fout elle du
340 * X et qu'elle a mis X a DontSaved.
342 let check_add_metavars_binding strip _keep inherited
= fun (k
, valu
) tin
->
345 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc k
) with
347 if Cocci_vs_c.equal_inh_metavarval valu valu'
348 then Some tin
.binding
352 match Common.optionise
(fun () -> tin
.binding
+> List.assoc k
) with
354 if Cocci_vs_c.equal_metavarval valu valu'
355 then Some tin
.binding
360 Some
(tin
.binding
+> Common.insert_assoc
(k
, valu'
)) in
362 Ast_c.MetaIdVal
(a
,c
) ->
363 (* c is a negated constraint *)
364 let rec loop = function
365 [] -> success(Ast_c.MetaIdVal
(a
,[]))
369 (fun () -> tin
.binding0
+> List.assoc c
) in
371 Some
(Ast_c.MetaIdVal
(v
,_
)) ->
373 then None
(* failure *)
374 else success(Ast_c.MetaIdVal
(a
,[]))
375 | Some _
-> failwith
"Not possible"
376 | None
-> success(Ast_c.MetaIdVal
(a
,[]))) in
378 | Ast_c.MetaFuncVal a
->
379 success(Ast_c.MetaFuncVal a
)
380 | Ast_c.MetaLocalFuncVal a
->
381 success(Ast_c.MetaLocalFuncVal a
) (*more?*)
382 | Ast_c.MetaExprVal
(a
,c
) ->
383 (* c in the value is only to prepare for the future in which
384 we figure out how to have subterm constraints on unbound
385 variables. Now an environment will only contain expression
386 values with empty constraints, as all constraints are
387 resolved at binding time *)
390 then Lib_parsing_c.al_expr a
391 else Lib_parsing_c.semi_al_expr a
in
392 let inh_stripped = Lib_parsing_c.al_inh_expr a
in
393 let rec loop = function
394 [] -> success(Ast_c.MetaExprVal
(stripped,[]))
398 (fun () -> tin
.binding0
+> List.assoc c
) in
400 Some
(Ast_c.MetaExprVal
(v
,_
)) ->
401 if C_vs_c.subexpression_of_expression
inh_stripped v
402 then loop cs
(* forget satisfied constraints *)
403 else None
(* failure *)
404 | Some _
-> failwith
"not possible"
405 (* fail if this should be a subterm of something that
409 | Ast_c.MetaExprListVal a
->
411 (Ast_c.MetaExprListVal
413 then Lib_parsing_c.al_arguments a
414 else Lib_parsing_c.semi_al_arguments a
))
416 | Ast_c.MetaDeclVal a
->
420 then Lib_parsing_c.al_declaration a
421 else Lib_parsing_c.semi_al_declaration a
))
422 | Ast_c.MetaFieldVal a
->
426 then Lib_parsing_c.al_field a
427 else Lib_parsing_c.semi_al_field a
))
428 | Ast_c.MetaFieldListVal a
->
430 (Ast_c.MetaFieldListVal
432 then Lib_parsing_c.al_fields a
433 else Lib_parsing_c.semi_al_fields a
))
434 | Ast_c.MetaStmtVal a
->
438 then Lib_parsing_c.al_statement a
439 else Lib_parsing_c.semi_al_statement a
))
440 | Ast_c.MetaTypeVal a
->
444 then Lib_parsing_c.al_type a
445 else Lib_parsing_c.semi_al_type a
))
447 | Ast_c.MetaInitVal a
->
451 then Lib_parsing_c.al_init a
452 else Lib_parsing_c.semi_al_init a
))
454 | Ast_c.MetaInitListVal a
->
456 (Ast_c.MetaInitListVal
458 then Lib_parsing_c.al_inits a
459 else Lib_parsing_c.semi_al_inits a
))
461 | Ast_c.MetaListlenVal a
-> success(Ast_c.MetaListlenVal a
)
463 | Ast_c.MetaParamVal a
->
467 then Lib_parsing_c.al_param a
468 else Lib_parsing_c.semi_al_param a
))
469 | Ast_c.MetaParamListVal a
->
471 (Ast_c.MetaParamListVal
473 then Lib_parsing_c.al_params a
474 else Lib_parsing_c.semi_al_params a
))
476 | Ast_c.MetaPosVal
(pos1
,pos2
) ->
477 success(Ast_c.MetaPosVal
(pos1
,pos2
))
478 | Ast_c.MetaPosValList l
-> success (Ast_c.MetaPosValList l
))
480 let pos_variables tin ia get_pvalu finish
=
481 match Ast_cocci.get_pos_var ia
with
484 let pvalu = Ast_c.MetaPosValList
(get_pvalu
()) in
485 let rec loop tin
= function
487 | Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) :: rest
->
488 check_pos_constraints constraints
pvalu
490 (* constraints are satisfied, now see if we are compatible
491 with existing bindings *)
493 let x = Ast_cocci.unwrap_mcode name
in
495 check_add_metavars_binding false keep inherited
497 (match new_binding with
498 Some binding
-> loop {tin
with binding
= binding
} rest
503 let envf keep inherited
= fun (k
, valu
, get_max_min
) f tin
->
504 let x = Ast_cocci.unwrap_mcode k
in
505 match check_add_metavars_binding true keep inherited
(x, valu
) tin
with
507 let new_tin = {tin
with binding
= binding
} in
508 pos_variables new_tin k
510 let (file
,current_element
,min
,max
) = get_max_min
() in
511 [(file
,current_element
,min
,max
)])
515 (* ------------------------------------------------------------------------*)
516 (* Environment, allbounds *)
517 (* ------------------------------------------------------------------------*)
518 (* all referenced inherited variables have to be bound. This would
519 * be naturally checked for the minus or context ones in the
520 * matching process, but have to check the plus ones as well. The
521 * result of get_inherited contains all of these, but the potential
522 * redundant checking for the minus and context ones is probably not
523 * a big deal. If it's a problem, could fix free_vars to distinguish
524 * between + variables and the other ones. *)
526 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
527 l
+> List.for_all
(fun inhvar
->
528 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc inhvar
) with
533 let optional_storage_flag f
= fun tin
->
534 f
(tin
.extra
.optional_storage_iso
) tin
536 let optional_qualifier_flag f
= fun tin
->
537 f
(tin
.extra
.optional_qualifier_iso
) tin
539 let value_format_flag f
= fun tin
->
540 f
(tin
.extra
.value_format_iso
) tin
542 let optional_declarer_semicolon_flag f
= fun tin
->
543 f
(tin
.extra
.optional_declarer_semicolon_iso
) tin
545 (* ------------------------------------------------------------------------*)
547 (* ------------------------------------------------------------------------*)
548 let tokenf ia ib
= fun tin
->
549 let pos = Ast_c.info_to_fixpos ib
in
550 let posmck = Ast_cocci.FixPos
(pos, pos) in
551 let finish tin
= tag_mck_pos_mcode ia
posmck ib tin
in
552 pos_variables tin ia
(function _
-> [Lib_parsing_c.lin_col_by_pos
[ib
]])
555 let tokenf_mck mck ib
= fun tin
->
556 let pos = Ast_c.info_to_fixpos ib
in
557 let posmck = Ast_cocci.FixPos
(pos, pos) in
558 [(tag_mck_pos mck
posmck, ib
), tin
.binding
]
562 (*****************************************************************************)
564 (*****************************************************************************)
565 module MATCH
= Cocci_vs_c.COCCI_VS_C
(XMATCH
)
568 let match_re_node2 dropped_isos a b binding0
=
572 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
573 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
574 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
575 optional_declarer_semicolon_iso
=
576 not
(List.mem
"optional_declarer_semicolon" dropped_isos
);
579 XMATCH.binding0
= binding0
;
582 MATCH.rule_elem_node a b
tin
583 (* take only the tagged-SP, the 'a' *)
584 +> List.map
(fun ((a
,_b
), binding
) -> a
, binding
)
587 let match_re_node a b c d
=
588 Common.profile_code
"Pattern3.match_re_node"
589 (fun () -> match_re_node2 a b c d
)