2 * Copyright 2005-2008, 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 (*****************************************************************************)
26 (* The functor argument *)
27 (*****************************************************************************)
29 (* info passed recursively in monad in addition to binding *)
31 optional_storage_iso
: bool;
32 optional_qualifier_iso
: bool;
33 value_format_iso
: bool;
36 module XMATCH
= struct
38 (* ------------------------------------------------------------------------*)
39 (* Combinators history *)
40 (* ------------------------------------------------------------------------*)
43 * type ('a, 'b) matcher = 'a -> 'b -> bool
45 * version1: same but with a global variable holding the current binding
47 * - can have multiple possibilities
49 * - sometimes have to undo, cos if start match, then it binds,
50 * and if later it does not match, then must undo the first binds.
51 * ex: when match parameters, can try to match, but then we found far
52 * later that the last argument of a function does not match
53 * => have to uando the binding !!!
54 * (can handle that too with a global, by saving the
55 * global, ... but sux)
56 * => better not use global
59 * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list
61 * Empty list mean failure (let matchfailure = []).
62 * To be able to have pretty code, have to use partial application
63 * powa, and so the type is in fact
66 * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list
68 * Then by defining the correct combinators, can have quite pretty code (that
69 * looks like the clean code of version0).
71 * opti: return a lazy list of possible matchs ?
73 * version4: type tin = Lib_engine.metavars_binding
76 (* ------------------------------------------------------------------------*)
77 (* Standard type and operators *)
78 (* ------------------------------------------------------------------------*)
82 binding
: Lib_engine.metavars_binding
;
83 binding0
: Lib_engine.metavars_binding
; (* inherited bindings *)
85 (* 'x is a ('a * 'b) but in fact dont care about 'b, we just tag the SP *)
86 (* opti? use set instead of list *)
87 type 'x tout
= ('x
* Lib_engine.metavars_binding
) list
89 type ('a
, 'b
) matcher
= 'a
-> 'b
-> tin
-> ('a
* 'b
) tout
92 let (>>=) m1 m2
= fun tin
->
94 let xxs = xs +> List.map
(fun ((a
,b
), binding
) ->
95 m2 a b
{tin
with binding
= binding
}
99 (* Je compare les bindings retournés par les differentes branches.
100 * Si la deuxieme branche amene a des bindings qui sont deja presents
101 * dans la premiere branche, alors je ne les accepte pas.
103 * update: still useful now that julia better handle Exp directly via
104 * ctl tricks using positions ?
106 let (>|+|>) m1 m2
= fun tin
->
115 let list_bindings_already = List.map snd
res1 in
117 (res2 +> List.filter
(fun (x
, binding
) ->
119 (list_bindings_already +> List.exists
(fun already
->
120 Lib_engine.equal_binding binding already
))
126 let (>||>) m1 m2
= fun tin
->
133 (* opti? use set instead of list *)
137 let return res
= fun tin
->
140 let fail = fun tin
->
143 let (>&&>) f m
= fun tin
->
149 let mode = Cocci_vs_c_3.PatternMode
151 (* ------------------------------------------------------------------------*)
153 (* ------------------------------------------------------------------------*)
154 let cocciExp = fun expf expa node
-> fun tin
->
156 let globals = ref [] in
159 Visitor_c.default_visitor_c
with
160 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
161 match expf expa expb tin
with
162 | [] -> (* failed *) k expb
164 globals := xs @ !globals;
165 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
168 * push2 expr globals; k expr
170 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
176 Visitor_c.vk_node
bigf node
;
177 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
181 (* same as cocciExp, but for expressions in an expression, not expressions
183 let cocciExpExp = fun expf expa expb
-> fun tin
->
185 let globals = ref [] in
188 Visitor_c.default_visitor_c
with
189 Visitor_c.kexpr
= (fun (k
, bigf) expb
->
190 match expf expa expb tin
with
191 | [] -> (* failed *) k expb
193 globals := xs @ !globals;
194 if not
!Flag_engine.disallow_nested_exps
then k expb
(* CHOICE *)
197 * push2 expr globals; k expr
199 * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e)
205 Visitor_c.vk_expr
bigf expb
;
206 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
210 let cocciTy = fun expf expa node
-> fun tin
->
212 let globals = ref [] in
214 Visitor_c.default_visitor_c
with
215 Visitor_c.ktype
= (fun (k
, bigf) expb
->
216 match expf expa expb tin
with
217 | [] -> (* failed *) k expb
218 | xs -> globals := xs @ !globals);
222 Visitor_c.vk_node
bigf node
;
223 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
227 let cocciInit = fun expf expa node
-> fun tin
->
229 let globals = ref [] in
231 Visitor_c.default_visitor_c
with
232 Visitor_c.kini
= (fun (k
, bigf) expb
->
233 match expf expa expb tin
with
234 | [] -> (* failed *) k expb
235 | xs -> globals := xs @ !globals);
239 Visitor_c.vk_node
bigf node
;
240 !globals +> List.map
(fun ((a
, _exp
), binding
) ->
245 (* ------------------------------------------------------------------------*)
246 (* Distribute mcode *)
247 (* ------------------------------------------------------------------------*)
248 let tag_mck_pos mck posmck
=
250 | Ast_cocci.PLUS
-> Ast_cocci.PLUS
251 | Ast_cocci.CONTEXT
(pos
, xs) ->
252 assert (pos
= Ast_cocci.NoPos
|| pos
= Ast_cocci.DontCarePos
);
253 Ast_cocci.CONTEXT
(posmck
, xs)
254 | Ast_cocci.MINUS
(pos
, xs) ->
255 assert (pos
= Ast_cocci.NoPos
|| pos
= Ast_cocci.DontCarePos
);
256 Ast_cocci.MINUS
(posmck
, xs)
259 let tag_mck_pos_mcode (x
,info
,mck
,pos
) posmck stuff
= fun tin
->
260 [((x
, info
, tag_mck_pos mck posmck
, pos
),stuff
), tin
.binding
]
263 let distrf (ii_of_x_f
) =
264 fun mcode x
-> fun tin
->
265 let (max
, min
) = Lib_parsing_c.max_min_by_pos
(ii_of_x_f x
)
267 let posmck = Ast_cocci.FixPos
(min
, max
) (* subtil: and not max, min !!*)
269 tag_mck_pos_mcode mcode
posmck x tin
271 let distrf_e = distrf (Lib_parsing_c.ii_of_expr
)
272 let distrf_args = distrf (Lib_parsing_c.ii_of_args
)
273 let distrf_type = distrf (Lib_parsing_c.ii_of_type
)
274 let distrf_param = distrf (Lib_parsing_c.ii_of_param
)
275 let distrf_params = distrf (Lib_parsing_c.ii_of_params
)
276 let distrf_ini = distrf (Lib_parsing_c.ii_of_ini
)
277 let distrf_node = distrf (Lib_parsing_c.ii_of_node
)
278 let distrf_struct_fields = distrf (Lib_parsing_c.ii_of_struct_fields
)
279 let distrf_cst = distrf (Lib_parsing_c.ii_of_cst
)
280 let distrf_define_params = distrf (Lib_parsing_c.ii_of_define_params
)
283 (* ------------------------------------------------------------------------*)
284 (* Constraints on metavariable values *)
285 (* ------------------------------------------------------------------------*)
286 let check_constraints matcher constraints exp
= fun f tin
->
287 let rec loop = function
288 [] -> f
() tin
(* success *)
290 match matcher c exp tin
with
291 [] (* failure *) -> loop cs
292 | _
(* success *) -> fail tin
in
295 let check_pos_constraints constraints pvalu f tin
=
298 let success = [[]] in
300 (* relies on the fact that constraints on pos variables must refer to
301 inherited variables *)
302 (match Common.optionise
(fun () -> tin
.binding0
+> List.assoc c
) with
304 if Cocci_vs_c_3.equal_metavarval exp valu'
305 then success else failure
307 (* if the variable is not there, it puts no constraints *)
308 (* not sure this is still useful *)
310 constraints pvalu f tin
312 (* ------------------------------------------------------------------------*)
314 (* ------------------------------------------------------------------------*)
315 (* pre: if have declared a new metavar that hide another one, then
316 * must be passed with a binding that deleted this metavar
318 * Here we dont use the keep argument of julia. cf f(X,X), J'ai
319 * besoin de garder le X en interne, meme si julia s'en fout elle du
320 * X et qu'elle a mis X a DontSaved.
322 let check_add_metavars_binding strip _keep inherited
= fun (k
, valu
) tin
->
325 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc k
) with
327 if Cocci_vs_c_3.equal_metavarval valu valu'
328 then Some tin
.binding
332 match Common.optionise
(fun () -> tin
.binding
+> List.assoc k
) with
334 if Cocci_vs_c_3.equal_metavarval valu valu'
335 then Some tin
.binding
341 Ast_c.MetaIdVal a
-> Ast_c.MetaIdVal a
342 | Ast_c.MetaFuncVal a
-> Ast_c.MetaFuncVal a
343 | Ast_c.MetaLocalFuncVal a
-> Ast_c.MetaLocalFuncVal a
(*more?*)
344 | Ast_c.MetaExprVal a
->
347 then Lib_parsing_c.al_expr a
348 else Lib_parsing_c.semi_al_expr a
)
349 | Ast_c.MetaExprListVal a
->
350 Ast_c.MetaExprListVal
352 then Lib_parsing_c.al_arguments a
353 else Lib_parsing_c.semi_al_arguments a
)
355 | Ast_c.MetaStmtVal a
->
358 then Lib_parsing_c.al_statement a
359 else Lib_parsing_c.semi_al_statement a
)
360 | Ast_c.MetaTypeVal a
->
363 then Lib_parsing_c.al_type a
364 else Lib_parsing_c.semi_al_type a
)
366 | Ast_c.MetaListlenVal a
-> Ast_c.MetaListlenVal a
368 | Ast_c.MetaParamVal a
-> failwith
"not handling MetaParamVal"
369 | Ast_c.MetaParamListVal a
->
370 Ast_c.MetaParamListVal
372 then Lib_parsing_c.al_params a
373 else Lib_parsing_c.semi_al_params a
)
375 | Ast_c.MetaPosVal
(pos1
,pos2
) -> Ast_c.MetaPosVal
(pos1
,pos2
)
376 | Ast_c.MetaPosValList l
-> Ast_c.MetaPosValList l
377 in Some
(tin
.binding
+> Common.insert_assoc
(k
, valu'
))
379 let envf keep inherited
= fun (k
, valu, get_max_min
) f tin
->
380 let x = Ast_cocci.unwrap_mcode k
in
381 match check_add_metavars_binding true keep inherited
(x, valu) tin
with
383 let new_tin = {tin
with binding
= binding
} in
384 (match Ast_cocci.get_pos_var k
with
385 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
387 let (file
,min
,max
) = get_max_min
() in
388 Ast_c.MetaPosValList
[(file
,min
,max
)] in
389 (* check constraints. success means that there is a match with
390 one of the constraints, which will ultimately result in
392 check_pos_constraints constraints
pvalu
394 (* constraints are satisfied, now see if we are compatible
395 with existing bindings *)
397 let x = Ast_cocci.unwrap_mcode name
in
399 check_add_metavars_binding false keep inherited
(x, pvalu)
402 f
() {new_tin with binding
= binding
}
405 | Ast_cocci.NoMetaPos
-> f
() new_tin)
408 (* ------------------------------------------------------------------------*)
409 (* Environment, allbounds *)
410 (* ------------------------------------------------------------------------*)
411 (* all referenced inherited variables have to be bound. This would
412 * be naturally checked for the minus or context ones in the
413 * matching process, but have to check the plus ones as well. The
414 * result of get_inherited contains all of these, but the potential
415 * redundant checking for the minus and context ones is probably not
416 * a big deal. If it's a problem, could fix free_vars to distinguish
417 * between + variables and the other ones. *)
419 let (all_bound
: Ast_cocci.meta_name list
-> tin
-> bool) = fun l tin
->
420 l
+> List.for_all
(fun inhvar
->
421 match Common.optionise
(fun () -> tin
.binding0
+> List.assoc inhvar
) with
426 let optional_storage_flag f
= fun tin
->
427 f
(tin
.extra
.optional_storage_iso
) tin
429 let optional_qualifier_flag f
= fun tin
->
430 f
(tin
.extra
.optional_qualifier_iso
) tin
432 let value_format_flag f
= fun tin
->
433 f
(tin
.extra
.value_format_iso
) tin
436 (* ------------------------------------------------------------------------*)
438 (* ------------------------------------------------------------------------*)
439 let tokenf ia ib
= fun tin
->
440 let pos = Ast_c.info_to_fixpos ib
in
441 let posmck = Ast_cocci.FixPos
(pos, pos) in
442 let finish tin
= tag_mck_pos_mcode ia
posmck ib tin
in
443 match Ast_cocci.get_pos_var ia
with
444 Ast_cocci.MetaPos
(name
,constraints
,per
,keep
,inherited
) ->
445 let mpos = Lib_parsing_c.lin_col_by_pos
[ib
] in
446 let pvalu = Ast_c.MetaPosValList
[mpos] in
447 check_pos_constraints constraints
pvalu
449 (* constraints are satisfied, now see if we are compatible
450 with existing bindings *)
452 let x = Ast_cocci.unwrap_mcode name
in
454 check_add_metavars_binding false keep inherited
(x, pvalu) tin
456 Some binding
-> finish {tin
with binding
= binding
}
461 let tokenf_mck mck ib
= fun tin
->
462 let pos = Ast_c.info_to_fixpos ib
in
463 let posmck = Ast_cocci.FixPos
(pos, pos) in
464 [(tag_mck_pos mck
posmck, ib
), tin
.binding
]
468 (*****************************************************************************)
470 (*****************************************************************************)
471 module MATCH
= Cocci_vs_c_3.COCCI_VS_C
(XMATCH
)
474 let match_re_node2 dropped_isos a b binding0
=
478 optional_storage_iso
= not
(List.mem
"optional_storage" dropped_isos
);
479 optional_qualifier_iso
= not
(List.mem
"optional_qualifier" dropped_isos
);
480 value_format_iso
= not
(List.mem
"value_format" dropped_isos
);
483 XMATCH.binding0
= binding0
;
486 MATCH.rule_elem_node a b
tin
487 (* take only the tagged-SP, the 'a' *)
488 +> List.map
(fun ((a
,_b
), binding
) -> a
, binding
)
491 let match_re_node a b c d
=
492 Common.profile_code
"Pattern3.match_re_node"
493 (fun () -> match_re_node2 a b c d
)