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 Flag_engine
= 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;
30 module XMATCH
= struct
32 (* ------------------------------------------------------------------------*)
33 (* Combinators history *)
34 (* ------------------------------------------------------------------------*)
37 * type ('a, 'b) matcher = 'a -> 'b -> bool
39 * version1: same but with a global variable holding the current binding
41 * - can have multiple possibilities
43 * - sometimes have to undo, cos if start match, then it binds,
44 * and if later it does not match, then must undo the first binds.
45 * ex: when match parameters, can try to match, but then we found far
46 * later that the last argument of a function does not match
47 * => have to uando the binding !!!
48 * (can handle that too with a global, by saving the
49 * global, ... but sux)
50 * => better not use global
53 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
55 * Empty list mean failure (let matchfailure = []).
56 * To be able to have pretty code, have to use partial application
57 * powa, and so the type is in fact
60 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
62 * Then by defining the correct combinators, can have quite pretty code (that
63 * looks like the clean code of version0).
65 * opti: return a lazy list of possible matchs ?
67 * version4: type tin = Lib_engine.metavars_binding
70 (* ------------------------------------------------------------------------*)
71 (* Standard type and operators *)
72 (* ------------------------------------------------------------------------*)
76 binding
: Lib_engine.metavars_binding
;
77 binding0
: Lib_engine.metavars_binding
; (* inherited bindings *)
79 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
80 (* opti? use set instead of list *)
81 type 'x tout
= ('x
* Lib_engine.metavars_binding
) list
83 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
86 let (>>=) m1 m2
= fun tin
->
88 let xxs = xs +> List.map
(fun ((a
,b
), binding
) ->
89 m2 a b
{tin
with binding
= binding
}
93 (* Je compare les bindings retournés par les differentes branches.
94 * Si la deuxieme branche amene a des bindings qui sont deja presents
95 * dans la premiere branche, alors je ne les accepte pas.
97 * update: still useful now that julia better handle Exp directly via
98 * ctl tricks using positions ?
100 let (>|+|>) m1 m2
= fun tin
->
109 let list_bindings_already = List.map snd
res1 in
111 (res2 +> List.filter
(fun (x
, binding
) ->
113 (list_bindings_already +> List.exists
(fun already
->
114 Lib_engine.equal_binding binding already
))
120 let (>||>) m1 m2
= fun tin
->
127 (* opti? use set instead of list *)
131 let return res
= fun tin
->
134 let fail = fun tin
->
137 let (>&&>) f m
= fun tin
->
143 let mode = Cocci_vs_c.PatternMode
145 (* ------------------------------------------------------------------------*)
147 (* ------------------------------------------------------------------------*)
148 let cocciExp = fun expf expa node
-> fun tin
->
150 let globals = ref [] in
153 Visitor_c.default_visitor_c
with
154 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
155 match expf expa expb tin
with
156 | [] -> (* failed *) k expb
158 globals := xs @ !globals;
159 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
162 * push2 expr globals; k expr
164 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
170 Visitor_c.vk_node
bigf node
;
171 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
175 (* same as cocciExp, but for expressions in an expression, not expressions
177 let cocciExpExp = fun expf expa expb
-> fun tin
->
179 let globals = ref [] in
182 Visitor_c.default_visitor_c
with
183 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
184 match expf expa expb tin
with
185 | [] -> (* failed *) k expb
187 globals := xs @ !globals;
188 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
191 * push2 expr globals; k expr
193 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
199 Visitor_c.vk_expr
bigf expb
;
200 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
204 let cocciTy = fun expf expa node
-> fun tin
->
206 let globals = ref [] in
208 Visitor_c.default_visitor_c
with
209 Visitor_c.ktype
= (fun (k
, bigf) expb
->
210 match expf expa expb tin
with
211 | [] -> (* failed *) k expb
212 | xs -> globals := xs @ !globals);
216 Visitor_c.vk_node
bigf node
;
217 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
221 let cocciInit = fun expf expa node
-> fun tin
->
223 let globals = ref [] in
225 Visitor_c.default_visitor_c
with
226 Visitor_c.kini
= (fun (k
, bigf) expb
->
227 match expf expa expb tin
with
228 | [] -> (* failed *) k expb
229 | xs -> globals := xs @ !globals);
233 Visitor_c.vk_node
bigf node
;
234 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
239 (* ------------------------------------------------------------------------*)
240 (* Distribute mcode *)
241 (* ------------------------------------------------------------------------*)
242 let tag_mck_pos mck posmck
=
244 | Ast_cocci.PLUS c
-> Ast_cocci.PLUS c
245 | Ast_cocci.CONTEXT
(pos
, xs) ->
246 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
247 Ast_cocci.CONTEXT
(posmck
, xs)
248 | Ast_cocci.MINUS
(pos
, inst
, adj
, xs) ->
249 assert (pos
=*= Ast_cocci.NoPos
|| pos
=*= Ast_cocci.DontCarePos
);
250 Ast_cocci.MINUS
(posmck
, inst
, adj
, xs)
253 let tag_mck_pos_mcode (x
,info
,mck
,pos
) posmck stuff
= fun tin
->
254 [((x
, info
, tag_mck_pos mck posmck
, pos
),stuff
), tin
.binding
]
257 let distrf (ii_of_x_f
) =
258 fun mcode x
-> fun tin
->
259 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
261 let posmck = Ast_cocci.FixPos
(min
, max
) (* subtil: and not max, min !!*)
263 tag_mck_pos_mcode mcode
posmck x tin
265 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
)
266 let distrf_args = distrf (Lib_parsing_c.ii_of_args
)
267 let distrf_type = distrf (Lib_parsing_c.ii_of_type
)
268 let distrf_param = distrf (Lib_parsing_c.ii_of_param
)
269 let distrf_params = distrf (Lib_parsing_c.ii_of_params
)
270 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
)
271 let distrf_node = distrf (Lib_parsing_c.ii_of_node
)
272 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields
)
273 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst
)
274 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params
)
277 (* ------------------------------------------------------------------------*)
278 (* Constraints on metavariable values *)
279 (* ------------------------------------------------------------------------*)
280 let check_idconstraint matcher c id
= fun f tin
->
288 let check_constraints_ne matcher constraints exp
= fun f tin
->
289 let rec loop = function
290 [] -> f
() tin
(* success *)
292 match matcher c exp tin
with
293 [] (* failure *) -> loop cs
294 | _
(* success *) -> fail tin
in
297 let check_pos_constraints constraints pvalu f tin
=
300 let success = [[]] in
302 (* relies on the fact that constraints on pos variables must refer to
303 inherited variables *)
304 (match Common.optionise
(fun () -> tin
.binding0
+> List.assoc c
) with
306 if Cocci_vs_c.equal_inh_metavarval exp valu'
307 then success else failure
309 (* if the variable is not there, it puts no constraints *)
310 (* not sure this is still useful *)
312 constraints pvalu f tin
314 (* ------------------------------------------------------------------------*)
316 (* ------------------------------------------------------------------------*)
317 (* pre: if have declared a new metavar that hide another one, then
318 * must be passed with a binding that deleted this metavar
320 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
321 * besoin de garder le X en interne, meme si julia s'en fout elle du
322 * X et qu'elle a mis X a DontSaved.
324 let check_add_metavars_binding strip _keep inherited
= fun (k
, valu
) tin
->
327 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc k
) with
329 if Cocci_vs_c.equal_inh_metavarval valu valu'
330 then Some tin
.binding
334 match Common.optionise
(fun () -> tin
.binding
+> List.assoc k
) with
336 if Cocci_vs_c.equal_metavarval valu valu'
337 then Some tin
.binding
343 Ast_c.MetaIdVal a
-> Ast_c.MetaIdVal a
344 | Ast_c.MetaFuncVal a
-> Ast_c.MetaFuncVal a
345 | Ast_c.MetaLocalFuncVal a
-> Ast_c.MetaLocalFuncVal a
(*more?*)
346 | Ast_c.MetaExprVal a
->
349 then Lib_parsing_c.al_expr a
350 else Lib_parsing_c.semi_al_expr a
)
351 | Ast_c.MetaExprListVal a
->
352 Ast_c.MetaExprListVal
354 then Lib_parsing_c.al_arguments a
355 else Lib_parsing_c.semi_al_arguments a
)
357 | Ast_c.MetaStmtVal a
->
360 then Lib_parsing_c.al_statement a
361 else Lib_parsing_c.semi_al_statement a
)
362 | Ast_c.MetaTypeVal a
->
365 then Lib_parsing_c.al_type a
366 else Lib_parsing_c.semi_al_type a
)
368 | Ast_c.MetaInitVal a
->
371 then Lib_parsing_c.al_init a
372 else Lib_parsing_c.semi_al_init a
)
374 | Ast_c.MetaListlenVal a
-> Ast_c.MetaListlenVal a
376 | Ast_c.MetaParamVal a
-> failwith
"not handling MetaParamVal"
377 | Ast_c.MetaParamListVal a
->
378 Ast_c.MetaParamListVal
380 then Lib_parsing_c.al_params a
381 else Lib_parsing_c.semi_al_params a
)
383 | Ast_c.MetaPosVal
(pos1
,pos2
) -> Ast_c.MetaPosVal
(pos1
,pos2
)
384 | Ast_c.MetaPosValList l
-> Ast_c.MetaPosValList l
385 in Some
(tin
.binding
+> Common.insert_assoc
(k
, valu'
))
387 let envf keep inherited
= fun (k
, valu, get_max_min
) f tin
->
388 let x = Ast_cocci.unwrap_mcode k
in
389 match check_add_metavars_binding true keep inherited
(x, valu) tin
with
391 let new_tin = {tin
with binding
= binding
} in
392 (match Ast_cocci.get_pos_var k
with
393 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
395 let (file
,current_element
,min
,max
) = get_max_min
() in
396 Ast_c.MetaPosValList
[(file
,current_element
,min
,max
)] in
397 (* check constraints. success means that there is a match with
398 one of the constraints, which will ultimately result in
400 check_pos_constraints constraints
pvalu
402 (* constraints are satisfied, now see if we are compatible
403 with existing bindings *)
405 let x = Ast_cocci.unwrap_mcode name
in
407 check_add_metavars_binding false keep inherited
(x, pvalu)
410 f
() {new_tin with binding
= binding
}
413 | Ast_cocci.NoMetaPos
-> f
() new_tin)
416 (* ------------------------------------------------------------------------*)
417 (* Environment, allbounds *)
418 (* ------------------------------------------------------------------------*)
419 (* all referenced inherited variables have to be bound. This would
420 * be naturally checked for the minus or context ones in the
421 * matching process, but have to check the plus ones as well. The
422 * result of get_inherited contains all of these, but the potential
423 * redundant checking for the minus and context ones is probably not
424 * a big deal. If it's a problem, could fix free_vars to distinguish
425 * between + variables and the other ones. *)
427 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
428 l
+> List.for_all
(fun inhvar
->
429 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc inhvar
) with
434 let optional_storage_flag f
= fun tin
->
435 f
(tin
.extra
.optional_storage_iso
) tin
437 let optional_qualifier_flag f
= fun tin
->
438 f
(tin
.extra
.optional_qualifier_iso
) tin
440 let value_format_flag f
= fun tin
->
441 f
(tin
.extra
.value_format_iso
) tin
444 (* ------------------------------------------------------------------------*)
446 (* ------------------------------------------------------------------------*)
447 let tokenf ia ib
= fun tin
->
448 let pos = Ast_c.info_to_fixpos ib
in
449 let posmck = Ast_cocci.FixPos
(pos, pos) in
450 let finish tin
= tag_mck_pos_mcode ia
posmck ib tin
in
451 match Ast_cocci.get_pos_var ia
with
452 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
453 let mpos = Lib_parsing_c.lin_col_by_pos
[ib
] in
454 let pvalu = Ast_c.MetaPosValList
[mpos] in
455 check_pos_constraints constraints
pvalu
457 (* constraints are satisfied, now see if we are compatible
458 with existing bindings *)
460 let x = Ast_cocci.unwrap_mcode name
in
462 check_add_metavars_binding false keep inherited
(x, pvalu) tin
464 Some binding
-> finish {tin
with binding
= binding
}
469 let tokenf_mck mck ib
= fun tin
->
470 let pos = Ast_c.info_to_fixpos ib
in
471 let posmck = Ast_cocci.FixPos
(pos, pos) in
472 [(tag_mck_pos mck
posmck, ib
), tin
.binding
]
476 (*****************************************************************************)
478 (*****************************************************************************)
479 module MATCH
= Cocci_vs_c.COCCI_VS_C
(XMATCH
)
482 let match_re_node2 dropped_isos a b binding0
=
486 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
487 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
488 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
491 XMATCH.binding0
= binding0
;
494 MATCH.rule_elem_node a b
tin
495 (* take only the tagged-SP, the 'a' *)
496 +> List.map
(fun ((a
,_b
), binding
) -> a
, binding
)
499 let match_re_node a b c d
=
500 Common.profile_code
"Pattern3.match_re_node"
501 (fun () -> match_re_node2 a b c d
)