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 *)
130 if l2 = [] then l1 else l1 ++ l2 (*a small benefit; avoid a trivial @*)
133 let return res = fun tin ->
136 let fail = fun tin ->
139 let (>&&>) f m = fun tin ->
145 let mode = Cocci_vs_c.PatternMode
147 (* ------------------------------------------------------------------------*)
149 (* ------------------------------------------------------------------------*)
150 let cocciExp = fun expf expa node -> fun tin ->
152 let globals = ref [] in
155 Visitor_c.default_visitor_c with
156 Visitor_c.kexpr = (fun (k, bigf) expb ->
157 match expf expa expb tin with
158 | [] -> (* failed *) k expb
160 globals := xs @ !globals;
161 if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
164 * push2 expr globals; k expr
166 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
172 Visitor_c.vk_node bigf node;
173 !globals +> List.map (fun ((a, _exp), binding) ->
177 (* same as cocciExp, but for expressions in an expression, not expressions
179 let cocciExpExp = fun expf expa expb -> fun tin ->
181 let globals = ref [] in
184 Visitor_c.default_visitor_c with
185 Visitor_c.kexpr = (fun (k, bigf) expb ->
186 match expf expa expb tin with
187 | [] -> (* failed *) k expb
189 globals := xs @ !globals;
190 if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *)
193 * push2 expr globals; k expr
195 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
201 Visitor_c.vk_expr bigf expb;
202 !globals +> List.map (fun ((a, _exp), binding) ->
206 let cocciTy = fun expf expa node -> fun tin ->
208 let globals = ref [] in
210 Visitor_c.default_visitor_c with
211 Visitor_c.ktype = (fun (k, bigf) expb ->
212 match expf expa expb tin with
213 | [] -> (* failed *) k expb
214 | xs -> globals := xs @ !globals);
218 Visitor_c.vk_node bigf node;
219 !globals +> List.map (fun ((a, _exp), binding) ->
223 let cocciInit = fun expf expa node -> fun tin ->
225 let globals = ref [] in
227 Visitor_c.default_visitor_c with
228 Visitor_c.kini = (fun (k, bigf) expb ->
229 match expf expa expb tin with
230 | [] -> (* failed *) k expb
231 | xs -> globals := xs @ !globals);
235 Visitor_c.vk_node bigf node;
236 !globals +> List.map (fun ((a, _exp), binding) ->
241 (* ------------------------------------------------------------------------*)
242 (* Distribute mcode *)
243 (* ------------------------------------------------------------------------*)
244 let tag_mck_pos mck posmck =
246 | Ast_cocci.PLUS c -> Ast_cocci.PLUS c
247 | Ast_cocci.CONTEXT (pos, xs) ->
248 assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
249 Ast_cocci.CONTEXT (posmck, xs)
250 | Ast_cocci.MINUS (pos, inst, adj, xs) ->
251 assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos);
252 Ast_cocci.MINUS (posmck, inst, adj, xs)
255 let tag_mck_pos_mcode (x,info,mck,pos) posmck stuff = fun tin ->
256 [((x, info, tag_mck_pos mck posmck, pos),stuff), tin.binding]
259 let distrf (ii_of_x_f) =
260 fun mcode x -> fun tin ->
261 let (max, min) = Lib_parsing_c.max_min_by_pos (ii_of_x_f x)
263 let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*)
265 tag_mck_pos_mcode mcode posmck x tin
267 let distrf_e = distrf (Lib_parsing_c.ii_of_expr)
268 let distrf_args = distrf (Lib_parsing_c.ii_of_args)
269 let distrf_type = distrf (Lib_parsing_c.ii_of_type)
270 let distrf_param = distrf (Lib_parsing_c.ii_of_param)
271 let distrf_params = distrf (Lib_parsing_c.ii_of_params)
272 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini)
273 let distrf_decl = distrf (Lib_parsing_c.ii_of_decl)
274 let distrf_field = distrf (Lib_parsing_c.ii_of_field)
275 let distrf_node = distrf (Lib_parsing_c.ii_of_node)
276 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields)
277 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst)
278 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params)
281 (* ------------------------------------------------------------------------*)
282 (* Constraints on metavariable values *)
283 (* ------------------------------------------------------------------------*)
284 let check_idconstraint matcher c id = fun f tin ->
292 let check_constraints_ne matcher constraints exp = fun f tin ->
293 let rec loop = function
294 [] -> f () tin (* success *)
296 match matcher c exp tin with
297 [] (* failure *) -> loop cs
298 | _ (* success *) -> fail tin in
301 let check_pos_constraints constraints pvalu f tin =
304 let success = [[]] in
306 (* relies on the fact that constraints on pos variables must refer to
307 inherited variables *)
308 (match Common.optionise (fun () -> tin.binding0 +> List.assoc c) with
310 if Cocci_vs_c.equal_inh_metavarval exp valu'
311 then success else failure
313 (* if the variable is not there, it puts no constraints *)
314 (* not sure this is still useful *)
316 constraints pvalu f tin
318 (* ------------------------------------------------------------------------*)
320 (* ------------------------------------------------------------------------*)
321 (* pre: if have declared a new metavar that hide another one, then
322 * must be passed with a binding that deleted this metavar
324 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
325 * besoin de garder le X en interne, meme si julia s'en fout elle du
326 * X et qu'elle a mis X a DontSaved.
328 let check_add_metavars_binding strip _keep inherited = fun (k, valu) tin ->
331 match Common.optionise (fun () -> tin.binding0 +> List.assoc k) with
333 if Cocci_vs_c.equal_inh_metavarval valu valu'
334 then Some tin.binding
338 match Common.optionise (fun () -> tin.binding +> List.assoc k) with
340 if Cocci_vs_c.equal_metavarval valu valu'
341 then Some tin.binding
346 Some (tin.binding +> Common.insert_assoc (k, valu')) in
348 Ast_c.MetaIdVal (a,c) ->
349 (* c is a negated constraint *)
350 let rec loop = function
351 [] -> success(Ast_c.MetaIdVal(a,[]))
355 (fun () -> tin.binding0 +> List.assoc c) in
357 Some (Ast_c.MetaIdVal(v,_)) ->
359 then None (* failure *)
360 else success(Ast_c.MetaIdVal(a,[]))
361 | Some _ -> failwith "Not possible"
362 | None -> success(Ast_c.MetaIdVal(a,[]))) in
364 | Ast_c.MetaFuncVal a ->
365 success(Ast_c.MetaFuncVal a)
366 | Ast_c.MetaLocalFuncVal a ->
367 success(Ast_c.MetaLocalFuncVal a) (*more?*)
368 | Ast_c.MetaExprVal (a,c) ->
369 (* c in the value is only to prepare for the future in which
370 we figure out how to have subterm constraints on unbound
371 variables. Now an environment will only contain expression
372 values with empty constraints, as all constraints are
373 resolved at binding time *)
376 then Lib_parsing_c.al_expr a
377 else Lib_parsing_c.semi_al_expr a in
378 let inh_stripped = Lib_parsing_c.al_inh_expr a in
379 let rec loop = function
380 [] -> success(Ast_c.MetaExprVal(stripped,[]))
384 (fun () -> tin.binding0 +> List.assoc c) in
386 Some (Ast_c.MetaExprVal(v,_)) ->
387 if C_vs_c.subexpression_of_expression inh_stripped v
388 then loop cs (* forget satisfied constraints *)
389 else None (* failure *)
390 | Some _ -> failwith "not possible"
391 (* fail if this should be a subterm of something that
395 | Ast_c.MetaExprListVal a ->
397 (Ast_c.MetaExprListVal
399 then Lib_parsing_c.al_arguments a
400 else Lib_parsing_c.semi_al_arguments a))
402 | Ast_c.MetaDeclVal a ->
406 then Lib_parsing_c.al_declaration a
407 else Lib_parsing_c.semi_al_declaration a))
408 | Ast_c.MetaFieldVal a ->
412 then Lib_parsing_c.al_field a
413 else Lib_parsing_c.semi_al_field a))
414 | Ast_c.MetaStmtVal a ->
418 then Lib_parsing_c.al_statement a
419 else Lib_parsing_c.semi_al_statement a))
420 | Ast_c.MetaTypeVal a ->
424 then Lib_parsing_c.al_type a
425 else Lib_parsing_c.semi_al_type a))
427 | Ast_c.MetaInitVal a ->
431 then Lib_parsing_c.al_init a
432 else Lib_parsing_c.semi_al_init a))
434 | Ast_c.MetaListlenVal a -> success(Ast_c.MetaListlenVal a)
436 | Ast_c.MetaParamVal a ->
440 then Lib_parsing_c.al_param a
441 else Lib_parsing_c.semi_al_param a))
442 | Ast_c.MetaParamListVal a ->
444 (Ast_c.MetaParamListVal
446 then Lib_parsing_c.al_params a
447 else Lib_parsing_c.semi_al_params a))
449 | Ast_c.MetaPosVal (pos1,pos2) ->
450 success(Ast_c.MetaPosVal (pos1,pos2))
451 | Ast_c.MetaPosValList l -> success (Ast_c.MetaPosValList l))
453 let envf keep inherited = fun (k, valu, get_max_min) f tin ->
454 let x = Ast_cocci.unwrap_mcode k in
455 match check_add_metavars_binding true keep inherited (x, valu) tin with
457 let new_tin = {tin with binding = binding} in
458 (match Ast_cocci.get_pos_var k with
459 Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
461 let (file,current_element,min,max) = get_max_min() in
462 Ast_c.MetaPosValList[(file,current_element,min,max)] in
463 (* check constraints. success means that there is a match with
464 one of the constraints, which will ultimately result in
466 check_pos_constraints constraints pvalu
468 (* constraints are satisfied, now see if we are compatible
469 with existing bindings *)
471 let x = Ast_cocci.unwrap_mcode name in
473 check_add_metavars_binding false keep inherited (x, pvalu)
476 f () {new_tin with binding = binding}
479 | Ast_cocci.NoMetaPos -> f () new_tin)
482 (* ------------------------------------------------------------------------*)
483 (* Environment, allbounds *)
484 (* ------------------------------------------------------------------------*)
485 (* all referenced inherited variables have to be bound. This would
486 * be naturally checked for the minus or context ones in the
487 * matching process, but have to check the plus ones as well. The
488 * result of get_inherited contains all of these, but the potential
489 * redundant checking for the minus and context ones is probably not
490 * a big deal. If it's a problem, could fix free_vars to distinguish
491 * between + variables and the other ones. *)
493 let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin ->
494 l +> List.for_all (fun inhvar ->
495 match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with
500 let optional_storage_flag f = fun tin ->
501 f (tin.extra.optional_storage_iso) tin
503 let optional_qualifier_flag f = fun tin ->
504 f (tin.extra.optional_qualifier_iso) tin
506 let value_format_flag f = fun tin ->
507 f (tin.extra.value_format_iso) tin
510 (* ------------------------------------------------------------------------*)
512 (* ------------------------------------------------------------------------*)
513 let tokenf ia ib = fun tin ->
514 let pos = Ast_c.info_to_fixpos ib in
515 let posmck = Ast_cocci.FixPos (pos, pos) in
516 let finish tin = tag_mck_pos_mcode ia posmck ib tin in
517 match Ast_cocci.get_pos_var ia with
518 Ast_cocci.MetaPos(name,constraints,per,keep,inherited) ->
519 let mpos = Lib_parsing_c.lin_col_by_pos [ib] in
520 let pvalu = Ast_c.MetaPosValList [mpos] in
521 check_pos_constraints constraints pvalu
523 (* constraints are satisfied, now see if we are compatible
524 with existing bindings *)
526 let x = Ast_cocci.unwrap_mcode name in
528 check_add_metavars_binding false keep inherited (x, pvalu) tin
530 Some binding -> finish {tin with binding = binding}
535 let tokenf_mck mck ib = fun tin ->
536 let pos = Ast_c.info_to_fixpos ib in
537 let posmck = Ast_cocci.FixPos (pos, pos) in
538 [(tag_mck_pos mck posmck, ib), tin.binding]
542 (*****************************************************************************)
544 (*****************************************************************************)
545 module MATCH = Cocci_vs_c.COCCI_VS_C (XMATCH)
548 let match_re_node2 dropped_isos a b binding0 =
552 optional_storage_iso = not(List.mem "optional_storage" dropped_isos);
553 optional_qualifier_iso = not(List.mem "optional_qualifier" dropped_isos);
554 value_format_iso = not(List.mem "value_format" dropped_isos);
557 XMATCH.binding0 = binding0;
560 MATCH.rule_elem_node a b tin
561 (* take only the tagged-SP, the 'a' *)
562 +> List.map (fun ((a,_b), binding) -> a, binding)
565 let match_re_node a b c d =
566 Common.profile_code "Pattern3.match_re_node"
567 (fun () -> match_re_node2 a b c d)