Commit | Line | Data |
---|---|---|
951c7801 C |
1 | (* Yoann Padioleau |
2 | * | |
3 | * Copyright (C) 2006, 2007 Ecole des Mines de Nantes | |
4 | * | |
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. | |
8 | * | |
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. | |
13 | * | |
14 | * This file was part of Coccinelle. | |
15 | *) | |
34e49164 C |
16 | open Common |
17 | ||
485bce71 | 18 | module Flag_engine = Flag_matcher |
34e49164 C |
19 | (*****************************************************************************) |
20 | (* The functor argument *) | |
21 | (*****************************************************************************) | |
22 | ||
23 | (* info passed recursively in monad in addition to binding *) | |
24 | type xinfo = { | |
25 | optional_storage_iso : bool; | |
26 | optional_qualifier_iso : bool; | |
27 | value_format_iso : bool; | |
28 | } | |
29 | ||
30 | module XMATCH = struct | |
31 | ||
32 | (* ------------------------------------------------------------------------*) | |
33 | (* Combinators history *) | |
34 | (* ------------------------------------------------------------------------*) | |
35 | (* | |
36 | * version0: | |
37 | * type ('a, 'b) matcher = 'a -> 'b -> bool | |
38 | * | |
39 | * version1: same but with a global variable holding the current binding | |
40 | * BUT bug | |
41 | * - can have multiple possibilities | |
42 | * - globals sux | |
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 | |
51 | * | |
52 | * version2: | |
53 | * type ('a, 'b) matcher = binding -> 'a -> 'b -> binding list | |
54 | * | |
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 | |
58 | * | |
59 | * version3: | |
60 | * type ('a, 'b) matcher = 'a -> 'b -> binding -> binding list | |
61 | * | |
62 | * Then by defining the correct combinators, can have quite pretty code (that | |
63 | * looks like the clean code of version0). | |
64 | * | |
65 | * opti: return a lazy list of possible matchs ? | |
66 | * | |
67 | * version4: type tin = Lib_engine.metavars_binding | |
68 | *) | |
69 | ||
70 | (* ------------------------------------------------------------------------*) | |
71 | (* Standard type and operators *) | |
72 | (* ------------------------------------------------------------------------*) | |
73 | ||
74 | type tin = { | |
75 | extra: xinfo; | |
76 | binding: Lib_engine.metavars_binding; | |
1be43e12 | 77 | binding0: Lib_engine.metavars_binding; (* inherited bindings *) |
34e49164 C |
78 | } |
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 | |
82 | ||
83 | type ('a, 'b) matcher = 'a -> 'b -> tin -> ('a * 'b) tout | |
84 | ||
85 | (* was >&&> *) | |
86 | let (>>=) m1 m2 = fun tin -> | |
87 | let xs = m1 tin in | |
88 | let xxs = xs +> List.map (fun ((a,b), binding) -> | |
1be43e12 | 89 | m2 a b {tin with binding = binding} |
34e49164 C |
90 | ) in |
91 | List.flatten xxs | |
92 | ||
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. | |
96 | * | |
97 | * update: still useful now that julia better handle Exp directly via | |
98 | * ctl tricks using positions ? | |
99 | *) | |
100 | let (>|+|>) m1 m2 = fun tin -> | |
101 | (* CHOICE | |
102 | let xs = m1 tin in | |
103 | if null xs | |
104 | then m2 tin | |
105 | else xs | |
106 | *) | |
107 | let res1 = m1 tin in | |
108 | let res2 = m2 tin in | |
109 | let list_bindings_already = List.map snd res1 in | |
110 | res1 ++ | |
111 | (res2 +> List.filter (fun (x, binding) -> | |
112 | not | |
113 | (list_bindings_already +> List.exists (fun already -> | |
114 | Lib_engine.equal_binding binding already)) | |
115 | )) | |
116 | ||
117 | ||
118 | ||
119 | ||
120 | let (>||>) m1 m2 = fun tin -> | |
121 | (* CHOICE | |
122 | let xs = m1 tin in | |
123 | if null xs | |
124 | then m2 tin | |
125 | else xs | |
126 | *) | |
127 | (* opti? use set instead of list *) | |
128 | m1 tin ++ m2 tin | |
129 | ||
130 | ||
131 | let return res = fun tin -> | |
132 | [res, tin.binding] | |
133 | ||
134 | let fail = fun tin -> | |
135 | [] | |
136 | ||
137 | let (>&&>) f m = fun tin -> | |
138 | if f tin | |
139 | then m tin | |
140 | else fail tin | |
141 | ||
142 | ||
485bce71 | 143 | let mode = Cocci_vs_c.PatternMode |
34e49164 C |
144 | |
145 | (* ------------------------------------------------------------------------*) | |
146 | (* Exp *) | |
147 | (* ------------------------------------------------------------------------*) | |
148 | let cocciExp = fun expf expa node -> fun tin -> | |
149 | ||
150 | let globals = ref [] in | |
151 | let bigf = { | |
152 | (* julia's style *) | |
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 | |
157 | | xs -> | |
158 | globals := xs @ !globals; | |
159 | if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *) | |
160 | ); | |
161 | (* pad's style. | |
162 | * push2 expr globals; k expr | |
163 | * ... | |
164 | * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e) | |
165 | * (return false) | |
166 | * | |
167 | *) | |
168 | } | |
169 | in | |
170 | Visitor_c.vk_node bigf node; | |
171 | !globals +> List.map (fun ((a, _exp), binding) -> | |
172 | (a, node), binding | |
173 | ) | |
174 | ||
175 | (* same as cocciExp, but for expressions in an expression, not expressions | |
176 | in a node *) | |
177 | let cocciExpExp = fun expf expa expb -> fun tin -> | |
178 | ||
179 | let globals = ref [] in | |
180 | let bigf = { | |
181 | (* julia's style *) | |
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 | |
186 | | xs -> | |
187 | globals := xs @ !globals; | |
188 | if not !Flag_engine.disallow_nested_exps then k expb (* CHOICE *) | |
189 | ); | |
190 | (* pad's style. | |
191 | * push2 expr globals; k expr | |
192 | * ... | |
193 | * !globals +> List.fold_left (fun acc e -> acc >||> match_e_e expr e) | |
194 | * (return false) | |
195 | * | |
196 | *) | |
197 | } | |
198 | in | |
199 | Visitor_c.vk_expr bigf expb; | |
200 | !globals +> List.map (fun ((a, _exp), binding) -> | |
201 | (a, expb), binding | |
202 | ) | |
203 | ||
204 | let cocciTy = fun expf expa node -> fun tin -> | |
205 | ||
206 | let globals = ref [] in | |
207 | let bigf = { | |
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); | |
213 | ||
214 | } | |
215 | in | |
216 | Visitor_c.vk_node bigf node; | |
217 | !globals +> List.map (fun ((a, _exp), binding) -> | |
218 | (a, node), binding | |
219 | ) | |
220 | ||
1be43e12 C |
221 | let cocciInit = fun expf expa node -> fun tin -> |
222 | ||
223 | let globals = ref [] in | |
224 | let bigf = { | |
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); | |
230 | ||
231 | } | |
232 | in | |
233 | Visitor_c.vk_node bigf node; | |
234 | !globals +> List.map (fun ((a, _exp), binding) -> | |
235 | (a, node), binding | |
236 | ) | |
237 | ||
34e49164 C |
238 | |
239 | (* ------------------------------------------------------------------------*) | |
240 | (* Distribute mcode *) | |
241 | (* ------------------------------------------------------------------------*) | |
242 | let tag_mck_pos mck posmck = | |
243 | match mck with | |
951c7801 | 244 | | Ast_cocci.PLUS c -> Ast_cocci.PLUS c |
34e49164 | 245 | | Ast_cocci.CONTEXT (pos, xs) -> |
b1b2de81 | 246 | assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos); |
34e49164 | 247 | Ast_cocci.CONTEXT (posmck, xs) |
708f4980 | 248 | | Ast_cocci.MINUS (pos, inst, adj, xs) -> |
b1b2de81 | 249 | assert (pos =*= Ast_cocci.NoPos || pos =*= Ast_cocci.DontCarePos); |
708f4980 | 250 | Ast_cocci.MINUS (posmck, inst, adj, xs) |
34e49164 C |
251 | |
252 | ||
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] | |
255 | ||
256 | ||
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) | |
260 | in | |
261 | let posmck = Ast_cocci.FixPos (min, max) (* subtil: and not max, min !!*) | |
262 | in | |
263 | tag_mck_pos_mcode mcode posmck x tin | |
264 | ||
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) | |
275 | ||
276 | ||
277 | (* ------------------------------------------------------------------------*) | |
951c7801 | 278 | (* Constraints on metavariable values *) |
34e49164 | 279 | (* ------------------------------------------------------------------------*) |
951c7801 C |
280 | let check_idconstraint matcher c id = fun f tin -> |
281 | if matcher c id then | |
282 | (* success *) | |
283 | f () tin | |
284 | else | |
285 | (* failure *) | |
286 | fail tin | |
287 | ||
288 | let check_constraints_ne matcher constraints exp = fun f tin -> | |
34e49164 C |
289 | let rec loop = function |
290 | [] -> f () tin (* success *) | |
291 | | c::cs -> | |
292 | match matcher c exp tin with | |
293 | [] (* failure *) -> loop cs | |
294 | | _ (* success *) -> fail tin in | |
295 | loop constraints | |
296 | ||
297 | let check_pos_constraints constraints pvalu f tin = | |
951c7801 | 298 | check_constraints_ne |
34e49164 C |
299 | (fun c exp tin -> |
300 | let success = [[]] in | |
301 | let failure = [] in | |
1be43e12 C |
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 | |
34e49164 | 305 | Some valu' -> |
978fd7e5 | 306 | if Cocci_vs_c.equal_inh_metavarval exp valu' |
34e49164 C |
307 | then success else failure |
308 | | None -> | |
309 | (* if the variable is not there, it puts no constraints *) | |
310 | (* not sure this is still useful *) | |
311 | failure)) | |
312 | constraints pvalu f tin | |
313 | ||
314 | (* ------------------------------------------------------------------------*) | |
315 | (* Environment *) | |
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 | |
319 | * | |
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. | |
323 | *) | |
324 | let check_add_metavars_binding strip _keep inherited = fun (k, valu) tin -> | |
1be43e12 C |
325 | if inherited |
326 | then | |
327 | match Common.optionise (fun () -> tin.binding0 +> List.assoc k) with | |
328 | | Some (valu') -> | |
978fd7e5 | 329 | if Cocci_vs_c.equal_inh_metavarval valu valu' |
1be43e12 C |
330 | then Some tin.binding |
331 | else None | |
332 | | None -> None | |
333 | else | |
334 | match Common.optionise (fun () -> tin.binding +> List.assoc k) with | |
335 | | Some (valu') -> | |
485bce71 | 336 | if Cocci_vs_c.equal_metavarval valu valu' |
1be43e12 C |
337 | then Some tin.binding |
338 | else None | |
339 | ||
340 | | None -> | |
34e49164 C |
341 | let valu' = |
342 | match valu with | |
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 -> | |
1be43e12 | 347 | Ast_c.MetaExprVal |
34e49164 C |
348 | (if strip |
349 | then Lib_parsing_c.al_expr a | |
350 | else Lib_parsing_c.semi_al_expr a) | |
351 | | Ast_c.MetaExprListVal a -> | |
1be43e12 | 352 | Ast_c.MetaExprListVal |
34e49164 C |
353 | (if strip |
354 | then Lib_parsing_c.al_arguments a | |
355 | else Lib_parsing_c.semi_al_arguments a) | |
356 | ||
357 | | Ast_c.MetaStmtVal a -> | |
1be43e12 | 358 | Ast_c.MetaStmtVal |
34e49164 C |
359 | (if strip |
360 | then Lib_parsing_c.al_statement a | |
361 | else Lib_parsing_c.semi_al_statement a) | |
362 | | Ast_c.MetaTypeVal a -> | |
1be43e12 | 363 | Ast_c.MetaTypeVal |
34e49164 C |
364 | (if strip |
365 | then Lib_parsing_c.al_type a | |
366 | else Lib_parsing_c.semi_al_type a) | |
1be43e12 | 367 | |
113803cf C |
368 | | Ast_c.MetaInitVal a -> |
369 | Ast_c.MetaInitVal | |
370 | (if strip | |
371 | then Lib_parsing_c.al_init a | |
372 | else Lib_parsing_c.semi_al_init a) | |
373 | ||
34e49164 | 374 | | Ast_c.MetaListlenVal a -> Ast_c.MetaListlenVal a |
1be43e12 | 375 | |
34e49164 C |
376 | | Ast_c.MetaParamVal a -> failwith "not handling MetaParamVal" |
377 | | Ast_c.MetaParamListVal a -> | |
1be43e12 | 378 | Ast_c.MetaParamListVal |
34e49164 C |
379 | (if strip |
380 | then Lib_parsing_c.al_params a | |
381 | else Lib_parsing_c.semi_al_params a) | |
1be43e12 | 382 | |
34e49164 C |
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')) | |
34e49164 C |
386 | |
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 | |
390 | | Some binding -> | |
1be43e12 | 391 | let new_tin = {tin with binding = binding} in |
34e49164 C |
392 | (match Ast_cocci.get_pos_var k with |
393 | Ast_cocci.MetaPos(name,constraints,per,keep,inherited) -> | |
394 | let pvalu = | |
485bce71 C |
395 | let (file,current_element,min,max) = get_max_min() in |
396 | Ast_c.MetaPosValList[(file,current_element,min,max)] in | |
34e49164 C |
397 | (* check constraints. success means that there is a match with |
398 | one of the constraints, which will ultimately result in | |
399 | failure. *) | |
400 | check_pos_constraints constraints pvalu | |
401 | (function () -> | |
402 | (* constraints are satisfied, now see if we are compatible | |
403 | with existing bindings *) | |
404 | function new_tin -> | |
405 | let x = Ast_cocci.unwrap_mcode name in | |
406 | (match | |
407 | check_add_metavars_binding false keep inherited (x, pvalu) | |
408 | new_tin with | |
409 | | Some binding -> | |
1be43e12 | 410 | f () {new_tin with binding = binding} |
34e49164 C |
411 | | None -> fail tin)) |
412 | new_tin | |
413 | | Ast_cocci.NoMetaPos -> f () new_tin) | |
414 | | None -> fail tin | |
415 | ||
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. *) | |
426 | ||
427 | let (all_bound : Ast_cocci.meta_name list -> tin -> bool) = fun l tin -> | |
428 | l +> List.for_all (fun inhvar -> | |
1be43e12 | 429 | match Common.optionise (fun () -> tin.binding0 +> List.assoc inhvar) with |
34e49164 C |
430 | | Some _ -> true |
431 | | None -> false | |
432 | ) | |
433 | ||
434 | let optional_storage_flag f = fun tin -> | |
435 | f (tin.extra.optional_storage_iso) tin | |
436 | ||
437 | let optional_qualifier_flag f = fun tin -> | |
438 | f (tin.extra.optional_qualifier_iso) tin | |
439 | ||
440 | let value_format_flag f = fun tin -> | |
441 | f (tin.extra.value_format_iso) tin | |
442 | ||
443 | ||
444 | (* ------------------------------------------------------------------------*) | |
445 | (* Tokens *) | |
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 | |
456 | (function () -> | |
457 | (* constraints are satisfied, now see if we are compatible | |
458 | with existing bindings *) | |
459 | function new_tin -> | |
460 | let x = Ast_cocci.unwrap_mcode name in | |
461 | (match | |
462 | check_add_metavars_binding false keep inherited (x, pvalu) tin | |
463 | with | |
1be43e12 | 464 | Some binding -> finish {tin with binding = binding} |
34e49164 C |
465 | | None -> fail tin)) |
466 | tin | |
467 | | _ -> finish tin | |
468 | ||
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] | |
473 | ||
474 | end | |
475 | ||
476 | (*****************************************************************************) | |
477 | (* Entry point *) | |
478 | (*****************************************************************************) | |
485bce71 | 479 | module MATCH = Cocci_vs_c.COCCI_VS_C (XMATCH) |
34e49164 C |
480 | |
481 | ||
1be43e12 | 482 | let match_re_node2 dropped_isos a b binding0 = |
34e49164 C |
483 | |
484 | let tin = { | |
485 | XMATCH.extra = { | |
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); | |
489 | }; | |
1be43e12 C |
490 | XMATCH.binding = []; |
491 | XMATCH.binding0 = binding0; | |
34e49164 C |
492 | } in |
493 | ||
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) | |
497 | ||
498 | ||
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) |