2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
25 module Flag_engine = Flag_matcher
26 (*****************************************************************************)
27 (* The functor argument *)
28 (*****************************************************************************)
30 (* info passed recursively in monad in addition to binding *)
32 optional_storage_iso : bool;
33 optional_qualifier_iso : bool;
34 value_format_iso : bool;
37 module XMATCH = struct
39 (* ------------------------------------------------------------------------*)
40 (* Combinators history *)
41 (* ------------------------------------------------------------------------*)
44 * type ('a, 'b) matcher = 'a -> 'b -> bool
46 * version1: same but with a global variable holding the current binding
48 * - can have multiple possibilities
50 * - sometimes have to undo, cos if start match, then it binds,
51 * and if later it does not match, then must undo the first binds.
52 * ex: when match parameters, can try to match, but then we found far
53 * later that the last argument of a function does not match
54 * => have to uando the binding !!!
55 * (can handle that too with a global, by saving the
56 * global, ... but sux)
57 * => better not use global
60 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
62 * Empty list mean failure (let matchfailure = []).
63 * To be able to have pretty code, have to use partial application
64 * powa, and so the type is in fact
67 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
69 * Then by defining the correct combinators, can have quite pretty code (that
70 * looks like the clean code of version0).
72 * opti: return a lazy list of possible matchs ?
74 * version4: type tin = Lib_engine.metavars_binding
77 (* ------------------------------------------------------------------------*)
78 (* Standard type and operators *)
79 (* ------------------------------------------------------------------------*)
83 binding: Lib_engine.metavars_binding;
84 binding0: Lib_engine.metavars_binding; (* inherited bindings *)
86 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
87 (* opti? use set instead of list *)
88 type 'x tout = ('x * Lib_engine.metavars_binding) list
90 type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout
93 let (>>=) m1 m2 = fun tin ->
95 let xxs = xs +> List.map (fun ((a,b), binding) ->
96 m2 a b {tin with binding = binding}
100 (* Je compare les bindings retournés par les differentes branches.
101 * Si la deuxieme branche amene a des bindings qui sont deja presents
102 * dans la premiere branche, alors je ne les accepte pas.
104 * update: still useful now that julia better handle Exp directly via
105 * ctl tricks using positions ?
107 let (>|+|>) m1 m2 = fun tin ->
116 let list_bindings_already = List.map snd res1 in
118 (res2 +> List.filter (fun (x, binding) ->
120 (list_bindings_already +> List.exists (fun already ->
121 Lib_engine.equal_binding binding already))
127 let (>||>) m1 m2 = fun tin ->
134 (* opti? use set instead of list *)
138 let return res = fun tin ->
141 let fail = fun tin ->
144 let (>&&>) f m = fun tin ->
150 let mode = Cocci_vs_c.PatternMode
152 (* ------------------------------------------------------------------------*)
154 (* ------------------------------------------------------------------------*)
155 let cocciExp = fun expf expa node -> fun tin ->
157 let globals = ref [] in
160 Visitor_c.default_visitor_c with
161 Visitor_c.kexpr = (fun (k, bigf) expb ->
162 match expf expa expb tin with
163 | [] -> (* failed *) k expb
165 globals := xs @ !globals;
166 if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
169 * push2 expr globals; k expr
171 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
177 Visitor_c.vk_node bigf node;
178 !globals +> List.map (fun ((a, _exp), binding) ->
182 (* same as cocciExp, but for expressions in an expression, not expressions
184 let cocciExpExp = fun expf expa expb -> fun tin ->
186 let globals = ref [] in
189 Visitor_c.default_visitor_c with
190 Visitor_c.kexpr = (fun (k, bigf) expb ->
191 match expf expa expb tin with
192 | [] -> (* failed *) k expb
194 globals := xs @ !globals;
195 if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
198 * push2 expr globals; k expr
200 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
206 Visitor_c.vk_expr bigf expb;
207 !globals +> List.map (fun ((a, _exp), binding) ->
211 let cocciTy = fun expf expa node -> fun tin ->
213 let globals = ref [] in
215 Visitor_c.default_visitor_c with
216 Visitor_c.ktype = (fun (k, bigf) expb ->
217 match expf expa expb tin with
218 | [] -> (* failed *) k expb
219 | xs -> globals := xs @ !globals);
223 Visitor_c.vk_node bigf node;
224 !globals +> List.map (fun ((a, _exp), binding) ->
228 let cocciInit = fun expf expa node -> fun tin ->
230 let globals = ref [] in
232 Visitor_c.default_visitor_c with
233 Visitor_c.kini = (fun (k, bigf) expb ->
234 match expf expa expb tin with
235 | [] -> (* failed *) k expb
236 | xs -> globals := xs @ !globals);
240 Visitor_c.vk_node bigf node;
241 !globals +> List.map (fun ((a, _exp), binding) ->
246 (* ------------------------------------------------------------------------*)
247 (* Distribute mcode *)
248 (* ------------------------------------------------------------------------*)
249 let tag_mck_pos mck posmck =
251 | Ast_cocci.PLUS -> Ast_cocci.PLUS
252 | Ast_cocci.CONTEXT (pos, xs) ->
253 assert (pos = Ast_cocci.NoPos || pos = Ast_cocci.DontCarePos);
254 Ast_cocci.CONTEXT (posmck, xs)
255 | Ast_cocci.MINUS (pos, xs) ->
256 assert (pos = Ast_cocci.NoPos || pos = Ast_cocci.DontCarePos);
257 Ast_cocci.MINUS (posmck, xs)
260 let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
261 [((x, info, tag_mck_pos mck posmck, pos),stuff), tin.binding]
264 let distrf (ii_of_x_f) =
265 fun mcode x -> fun tin ->
266 let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
268 let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
270 tag_mck_pos_mcode mcode posmck x tin
272 let distrf_e = distrf (Lib_parsing_c.ii_of_expr)
273 let distrf_args = distrf (Lib_parsing_c.ii_of_args)
274 let distrf_type = distrf (Lib_parsing_c.ii_of_type)
275 let distrf_param = distrf (Lib_parsing_c.ii_of_param)
276 let distrf_params = distrf (Lib_parsing_c.ii_of_params)
277 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini)
278 let distrf_node = distrf (Lib_parsing_c.ii_of_node)
279 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
280 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst)
281 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params)
284 (* ------------------------------------------------------------------------*)
285 (* Constraints on metavariable values *)
286 (* ------------------------------------------------------------------------*)
287 let check_constraints matcher constraints exp = fun f tin ->
288 let rec loop = function
289 [] -> f () tin (* success *)
291 match matcher c exp tin with
292 [] (* failure *) -> loop cs
293 | _ (* success *) -> fail tin in
296 let check_pos_constraints constraints pvalu f tin =
299 let success = [[]] in
301 (* relies on the fact that constraints on pos variables must refer to
302 inherited variables *)
303 (match Common.optionise (fun () -> tin.binding0 +> List.assoc c) with
305 if Cocci_vs_c.equal_metavarval exp valu'
306 then success else failure
308 (* if the variable is not there, it puts no constraints *)
309 (* not sure this is still useful *)
311 constraints pvalu f tin
313 (* ------------------------------------------------------------------------*)
315 (* ------------------------------------------------------------------------*)
316 (* pre: if have declared a new metavar that hide another one, then
317 * must be passed with a binding that deleted this metavar
319 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
320 * besoin de garder le X en interne, meme si julia s'en fout elle du
321 * X et qu'elle a mis X a DontSaved.
323 let check_add_metavars_binding strip _keep inherited = fun (k, valu) tin ->
326 match Common.optionise (fun () -> tin.binding0 +> List.assoc k) with
328 if Cocci_vs_c.equal_metavarval valu valu'
329 then Some tin.binding
333 match Common.optionise (fun () -> tin.binding +> List.assoc k) with
335 if Cocci_vs_c.equal_metavarval valu valu'
336 then Some tin.binding
342 Ast_c.MetaIdVal a -> Ast_c.MetaIdVal a
343 | Ast_c.MetaFuncVal a -> Ast_c.MetaFuncVal a
344 | Ast_c.MetaLocalFuncVal a -> Ast_c.MetaLocalFuncVal a (*more?*)
345 | Ast_c.MetaExprVal a ->
348 then Lib_parsing_c.al_expr a
349 else Lib_parsing_c.semi_al_expr a)
350 | Ast_c.MetaExprListVal a ->
351 Ast_c.MetaExprListVal
353 then Lib_parsing_c.al_arguments a
354 else Lib_parsing_c.semi_al_arguments a)
356 | Ast_c.MetaStmtVal a ->
359 then Lib_parsing_c.al_statement a
360 else Lib_parsing_c.semi_al_statement a)
361 | Ast_c.MetaTypeVal a ->
364 then Lib_parsing_c.al_type a
365 else Lib_parsing_c.semi_al_type a)
367 | Ast_c.MetaListlenVal a -> Ast_c.MetaListlenVal a
369 | Ast_c.MetaParamVal a -> failwith "not handling MetaParamVal"
370 | Ast_c.MetaParamListVal a ->
371 Ast_c.MetaParamListVal
373 then Lib_parsing_c.al_params a
374 else Lib_parsing_c.semi_al_params a)
376 | Ast_c.MetaPosVal (pos1,pos2) -> Ast_c.MetaPosVal (pos1,pos2)
377 | Ast_c.MetaPosValList l -> Ast_c.MetaPosValList l
378 in Some (tin.binding +> Common.insert_assoc (k, valu'))
380 let envf keep inherited = fun (k, valu, get_max_min) f tin ->
381 let x = Ast_cocci.unwrap_mcode k in
382 match check_add_metavars_binding true keep inherited (x, valu) tin with
384 let new_tin = {tin with binding = binding} in
385 (match Ast_cocci.get_pos_var k with
386 Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
388 let (file,current_element,min,max) = get_max_min() in
389 Ast_c.MetaPosValList[(file,current_element,min,max)] in
390 (* check constraints. success means that there is a match with
391 one of the constraints, which will ultimately result in
393 check_pos_constraints constraints pvalu
395 (* constraints are satisfied, now see if we are compatible
396 with existing bindings *)
398 let x = Ast_cocci.unwrap_mcode name in
400 check_add_metavars_binding false keep inherited (x, pvalu)
403 f () {new_tin with binding = binding}
406 | Ast_cocci.NoMetaPos -> f () new_tin)
409 (* ------------------------------------------------------------------------*)
410 (* Environment, allbounds *)
411 (* ------------------------------------------------------------------------*)
412 (* all referenced inherited variables have to be bound. This would
413 * be naturally checked for the minus or context ones in the
414 * matching process, but have to check the plus ones as well. The
415 * result of get_inherited contains all of these, but the potential
416 * redundant checking for the minus and context ones is probably not
417 * a big deal. If it's a problem, could fix free_vars to distinguish
418 * between + variables and the other ones. *)
420 let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
421 l +> List.for_all (fun inhvar ->
422 match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with
427 let optional_storage_flag f = fun tin ->
428 f (tin.extra.optional_storage_iso) tin
430 let optional_qualifier_flag f = fun tin ->
431 f (tin.extra.optional_qualifier_iso) tin
433 let value_format_flag f = fun tin ->
434 f (tin.extra.value_format_iso) tin
437 (* ------------------------------------------------------------------------*)
439 (* ------------------------------------------------------------------------*)
440 let tokenf ia ib = fun tin ->
441 let pos = Ast_c.info_to_fixpos ib in
442 let posmck = Ast_cocci.FixPos (pos, pos) in
443 let finish tin = tag_mck_pos_mcode ia posmck ib tin in
444 match Ast_cocci.get_pos_var ia with
445 Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
446 let mpos = Lib_parsing_c.lin_col_by_pos [ib] in
447 let pvalu = Ast_c.MetaPosValList [mpos] in
448 check_pos_constraints constraints pvalu
450 (* constraints are satisfied, now see if we are compatible
451 with existing bindings *)
453 let x = Ast_cocci.unwrap_mcode name in
455 check_add_metavars_binding false keep inherited (x, pvalu) tin
457 Some binding -> finish {tin with binding = binding}
462 let tokenf_mck mck ib = fun tin ->
463 let pos = Ast_c.info_to_fixpos ib in
464 let posmck = Ast_cocci.FixPos (pos, pos) in
465 [(tag_mck_pos mck posmck, ib), tin.binding]
469 (*****************************************************************************)
471 (*****************************************************************************)
472 module MATCH = Cocci_vs_c.COCCI_VS_C (XMATCH)
475 let match_re_node2 dropped_isos a b binding0 =
479 optional_storage_iso = not(List.mem "optional_storage" dropped_isos);
480 optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
481 value_format_iso = not(List.mem "value_format" dropped_isos);
484 XMATCH.binding0 = binding0;
487 MATCH.rule_elem_node a b tin
488 (* take only the tagged-SP, the 'a' *)
489 +> List.map (fun ((a,_b), binding) -> a, binding)
492 let match_re_node a b c d =
493 Common.profile_code "Pattern3.match_re_node"
494 (fun () -> match_re_node2 a b c d)