3ce58d6e75891891f5e4b86054599bec5730e9f9
[bpt/coccinelle.git] / parsing_cocci / iso_pattern.ml
1 (*
2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
9 *
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
13 *
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
18 *
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
21 *
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
24 *)
25
26
27 # 0 "./iso_pattern.ml"
28 (* Potential problem: offset of mcode is not updated when an iso is
29 instantiated, implying that a term may end up with many mcodes with the
30 same offset. On the other hand, at the moment offset only seems to be used
31 before this phase. Furthermore add_dot_binding relies on the offset to
32 remain the same between matching an iso and instantiating it with bindings. *)
33
34 (* Consider whether ... in iso should match <... ...> in smpl? *)
35
36 (* --------------------------------------------------------------------- *)
37 (* match a SmPL expression against a SmPL abstract syntax tree,
38 either - or + *)
39
40 module Ast = Ast_cocci
41 module Ast0 = Ast0_cocci
42 module V0 = Visitor_ast0
43 module VT0 = Visitor_ast0_types
44
45 let current_rule = ref ""
46
47 (* --------------------------------------------------------------------- *)
48
49 type isomorphism =
50 Ast_cocci.metavar list * Ast0_cocci.anything list list * string (* name *)
51
52 let strip_info =
53 let mcode (term,_,_,_,_,_) =
54 (term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS Ast.ONE,
55 ref [],-1) in
56 let donothing r k e =
57 let x = k e in
58 {(Ast0.wrap (Ast0.unwrap x)) with
59 Ast0.mcodekind = ref (Ast0.PLUS Ast.ONE);
60 Ast0.true_if_test = x.Ast0.true_if_test} in
61 V0.flat_rebuilder
62 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
63 donothing donothing donothing donothing donothing donothing
64 donothing donothing donothing donothing donothing donothing donothing
65 donothing donothing donothing
66
67 let anything_equal = function
68 (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) ->
69 failwith "not a possible variable binding" (*not sure why these are pbs*)
70 | (Ast0.DotsInitTag(d1),Ast0.DotsInitTag(d2)) ->
71 failwith "not a possible variable binding"
72 | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
73 failwith "not a possible variable binding"
74 | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) ->
75 (strip_info.VT0.rebuilder_rec_statement_dots d1) =
76 (strip_info.VT0.rebuilder_rec_statement_dots d2)
77 | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) ->
78 failwith "not a possible variable binding"
79 | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) ->
80 failwith "not a possible variable binding"
81 | (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) ->
82 (strip_info.VT0.rebuilder_rec_ident d1) =
83 (strip_info.VT0.rebuilder_rec_ident d2)
84 | (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) ->
85 (strip_info.VT0.rebuilder_rec_expression d1) =
86 (strip_info.VT0.rebuilder_rec_expression d2)
87 | (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) ->
88 failwith "not possible - only in isos1"
89 | (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) ->
90 failwith "not possible - only in isos1"
91 | (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) ->
92 (strip_info.VT0.rebuilder_rec_typeC d1) =
93 (strip_info.VT0.rebuilder_rec_typeC d2)
94 | (Ast0.InitTag(d1),Ast0.InitTag(d2)) ->
95 (strip_info.VT0.rebuilder_rec_initialiser d1) =
96 (strip_info.VT0.rebuilder_rec_initialiser d2)
97 | (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) ->
98 (strip_info.VT0.rebuilder_rec_parameter d1) =
99 (strip_info.VT0.rebuilder_rec_parameter d2)
100 | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) ->
101 (strip_info.VT0.rebuilder_rec_declaration d1) =
102 (strip_info.VT0.rebuilder_rec_declaration d2)
103 | (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) ->
104 (strip_info.VT0.rebuilder_rec_statement d1) =
105 (strip_info.VT0.rebuilder_rec_statement d2)
106 | (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) ->
107 (strip_info.VT0.rebuilder_rec_case_line d1) =
108 (strip_info.VT0.rebuilder_rec_case_line d2)
109 | (Ast0.TopTag(d1),Ast0.TopTag(d2)) ->
110 (strip_info.VT0.rebuilder_rec_top_level d1) =
111 (strip_info.VT0.rebuilder_rec_top_level d2)
112 | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) ->
113 failwith "only for isos within iso phase"
114 | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
115 failwith "only for isos within iso phase"
116 | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_)) ->
117 failwith "only for isos within iso phase"
118 | _ -> false
119
120 let term (var1,_,_,_,_,_) = var1
121 let dot_term (var1,_,info,_,_,_) =
122 ("", var1 ^ (string_of_int info.Ast0.pos_info.Ast0.offset))
123
124
125 type reason =
126 NotPure of Ast0.pure * Ast.meta_name * Ast0.anything
127 | NotPureLength of Ast.meta_name
128 | ContextRequired of Ast0.anything
129 | NonMatch
130 | Braces of Ast0.statement
131 | Nest of Ast0.statement
132 | Position of Ast.meta_name
133 | TypeMatch of reason list
134
135 let rec interpret_reason name line reason printer =
136 Printf.printf
137 "warning: iso %s does not match the code below on line %d\n" name line;
138 printer(); Format.print_newline();
139 match reason with
140 NotPure(Ast0.Pure,(_,var),nonpure) ->
141 Printf.printf
142 "pure metavariable %s is matched against the following nonpure code:\n"
143 var;
144 Unparse_ast0.unparse_anything nonpure
145 | NotPure(Ast0.Context,(_,var),nonpure) ->
146 Printf.printf
147 "context metavariable %s is matched against the following\nnoncontext code:\n"
148 var;
149 Unparse_ast0.unparse_anything nonpure
150 | NotPure(Ast0.PureContext,(_,var),nonpure) ->
151 Printf.printf
152 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
153 var;
154 Unparse_ast0.unparse_anything nonpure
155 | NotPureLength((_,var)) ->
156 Printf.printf
157 "pure metavariable %s is matched against too much or too little code\n"
158 var;
159 | ContextRequired(term) ->
160 Printf.printf
161 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
162 Unparse_ast0.unparse_anything term
163 | Braces(s) ->
164 Printf.printf "braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
165 Unparse_ast0.statement "" s;
166 Format.print_newline()
167 | Nest(s) ->
168 Printf.printf "iso with nest doesn't match whencode (TODO):\n";
169 Unparse_ast0.statement "" s;
170 Format.print_newline()
171 | Position(rule,name) ->
172 Printf.printf "position variable %s.%s conflicts with an isomorphism\n"
173 rule name
174 | TypeMatch reason_list ->
175 List.iter (function r -> interpret_reason name line r printer)
176 reason_list
177 | _ -> failwith "not possible"
178
179 type 'a either = OK of 'a | Fail of reason
180
181 let add_binding var exp bindings =
182 let var = term var in
183 let attempt bindings =
184 try
185 let cur = List.assoc var bindings in
186 if anything_equal(exp,cur) then [bindings] else []
187 with Not_found -> [((var,exp)::bindings)] in
188 match List.concat(List.map attempt bindings) with
189 [] -> Fail NonMatch
190 | x -> OK x
191
192 let add_dot_binding var exp bindings =
193 let var = dot_term var in
194 let attempt bindings =
195 try
196 let cur = List.assoc var bindings in
197 if anything_equal(exp,cur) then [bindings] else []
198 with Not_found -> [((var,exp)::bindings)] in
199 match List.concat(List.map attempt bindings) with
200 [] -> Fail NonMatch
201 | x -> OK x
202
203 (* multi-valued *)
204 let add_multi_dot_binding var exp bindings =
205 let var = dot_term var in
206 let attempt bindings = [((var,exp)::bindings)] in
207 match List.concat(List.map attempt bindings) with
208 [] -> Fail NonMatch
209 | x -> OK x
210
211 let rec nub ls =
212 match ls with
213 [] -> []
214 | (x::xs) when (List.mem x xs) -> nub xs
215 | (x::xs) -> x::(nub xs)
216
217 (* --------------------------------------------------------------------- *)
218
219 let init_env = [[]]
220
221 let debug str m binding =
222 let res = m binding in
223 (match res with
224 None -> Printf.printf "%s: failed\n" str
225 | Some binding ->
226 List.iter
227 (function binding ->
228 Printf.printf "%s: %s\n" str
229 (String.concat " " (List.map (function (x,_) -> x) binding)))
230 binding);
231 res
232
233 let conjunct_bindings
234 (m1 : 'binding -> 'binding either)
235 (m2 : 'binding -> 'binding either)
236 (binding : 'binding) : 'binding either =
237 match m1 binding with Fail(reason) -> Fail(reason) | OK binding -> m2 binding
238
239 let rec conjunct_many_bindings = function
240 [] -> failwith "not possible"
241 | [x] -> x
242 | x::xs -> conjunct_bindings x (conjunct_many_bindings xs)
243
244 let mcode_equal (x,_,_,_,_,_) (y,_,_,_,_,_) = x = y
245
246 let return b binding = if b then OK binding else Fail NonMatch
247 let return_false reason binding = Fail reason
248
249 let match_option f t1 t2 =
250 match (t1,t2) with
251 (Some t1, Some t2) -> f t1 t2
252 | (None, None) -> return true
253 | _ -> return false
254
255 let bool_match_option f t1 t2 =
256 match (t1,t2) with
257 (Some t1, Some t2) -> f t1 t2
258 | (None, None) -> true
259 | _ -> false
260
261 (* context_required is for the example
262 if (
263 + (int * )
264 x == NULL)
265 where we can't change x == NULL to eg NULL == x. So there can either be
266 nothing attached to the root or the term has to be all removed.
267 if would be nice if we knew more about the relationship between the - and +
268 code, because in the case where the + code is a separate statement in a
269 sequence, this is not a problem. Perhaps something could be done in
270 insert_plus
271
272 The example seems strange. Why isn't the cast attached to x?
273 *)
274 let is_context e =
275 !Flag.sgrep_mode2 or (* everything is context for sgrep *)
276 (match Ast0.get_mcodekind e with
277 Ast0.CONTEXT(cell) -> true
278 | _ -> false)
279
280 (* needs a special case when there is a Disj or an empty DOTS
281 the following stops at the statement level, and gives true if one
282 statement is replaced by another *)
283 let rec is_pure_context s =
284 !Flag.sgrep_mode2 or (* everything is context for sgrep *)
285 (match Ast0.unwrap s with
286 Ast0.Disj(starter,statement_dots_list,mids,ender) ->
287 List.for_all
288 (function x ->
289 match Ast0.undots x with
290 [s] -> is_pure_context s
291 | _ -> false (* could we do better? *))
292 statement_dots_list
293 | _ ->
294 (match Ast0.get_mcodekind s with
295 Ast0.CONTEXT(mc) ->
296 (match !mc with
297 (Ast.NOTHING,_,_) -> true
298 | _ -> false)
299 | Ast0.MINUS(mc) ->
300 (match !mc with
301 (* do better for the common case of replacing a stmt by another one *)
302 (Ast.REPLACEMENT([[Ast.StatementTag(s)]],_),_) ->
303 (match Ast.unwrap s with
304 Ast.IfThen(_,_,_) -> false (* potentially dangerous *)
305 | _ -> true)
306 | (_,_) -> false)
307 | _ -> false))
308
309 let is_minus e =
310 match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
311
312 let match_list matcher is_list_matcher do_list_match la lb =
313 let rec loop = function
314 ([],[]) -> return true
315 | ([x],lb) when is_list_matcher x -> do_list_match x lb
316 | (x::xs,y::ys) -> conjunct_bindings (matcher x y) (loop (xs,ys))
317 | _ -> return false in
318 loop (la,lb)
319
320 let all_caps = Str.regexp "^[A-Z_][A-Z_0-9]*$"
321
322 let match_maker checks_needed context_required whencode_allowed =
323
324 let check_mcode pmc (*pattern*) cmc (*code*) binding =
325 if checks_needed
326 then
327 match Ast0.get_pos cmc with
328 [] -> OK binding (* no hidden vars in smpl code, so nothing to do *)
329 | ((a::_) as hidden_code) ->
330 let hidden_pattern =
331 List.filter (function Ast0.HiddenVarTag _ -> true | _ -> false)
332 (Ast0.get_pos pmc) in
333 (match hidden_pattern with
334 [Ast0.HiddenVarTag([Ast0.MetaPosTag(Ast0.MetaPos (name1,_,_))])] ->
335 add_binding name1 (Ast0.HiddenVarTag(hidden_code)) binding
336 | [] -> Fail(Position(Ast0.unwrap_mcode(Ast0.meta_pos_name a)))
337 | _ -> failwith "badly compiled iso - multiple hidden variable")
338 else OK binding in
339
340 let match_dots matcher is_list_matcher do_list_match d1 d2 =
341 match (Ast0.unwrap d1, Ast0.unwrap d2) with
342 (Ast0.DOTS(la),Ast0.DOTS(lb))
343 | (Ast0.CIRCLES(la),Ast0.CIRCLES(lb))
344 | (Ast0.STARS(la),Ast0.STARS(lb)) ->
345 match_list matcher is_list_matcher (do_list_match d2) la lb
346 | _ -> return false in
347
348 let is_elist_matcher el =
349 match Ast0.unwrap el with Ast0.MetaExprList(_,_,_) -> true | _ -> false in
350
351 let is_plist_matcher pl =
352 match Ast0.unwrap pl with Ast0.MetaParamList(_,_,_) -> true | _ -> false in
353
354 let is_slist_matcher pl =
355 match Ast0.unwrap pl with Ast0.MetaStmtList(_,_) -> true | _ -> false in
356
357 let no_list _ = false in
358
359 let build_dots pattern data =
360 match Ast0.unwrap pattern with
361 Ast0.DOTS(_) -> Ast0.rewrap pattern (Ast0.DOTS(data))
362 | Ast0.CIRCLES(_) -> Ast0.rewrap pattern (Ast0.CIRCLES(data))
363 | Ast0.STARS(_) -> Ast0.rewrap pattern (Ast0.STARS(data)) in
364
365 let pure_sp_code =
366 let bind = Ast0.lub_pure in
367 let option_default = Ast0.Context in
368 let pure_mcodekind mc =
369 if !Flag.sgrep_mode2
370 then Ast0.PureContext
371 else
372 match mc with
373 Ast0.CONTEXT(mc) ->
374 (match !mc with
375 (Ast.NOTHING,_,_) -> Ast0.PureContext
376 | _ -> Ast0.Context)
377 | Ast0.MINUS(mc) ->
378 (match !mc with
379 (Ast.NOREPLACEMENT,_) -> Ast0.Pure
380 | _ -> Ast0.Impure)
381 | _ -> Ast0.Impure in
382 let donothing r k e =
383 bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
384
385 let mcode m = pure_mcodekind (Ast0.get_mcode_mcodekind m) in
386
387 (* a case for everything that has a metavariable *)
388 (* pure is supposed to match only unitary metavars, not anything that
389 contains only unitary metavars *)
390 let ident r k i =
391 bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i))
392 (match Ast0.unwrap i with
393 Ast0.MetaId(name,_,_,pure) | Ast0.MetaFunc(name,_,pure)
394 | Ast0.MetaLocalFunc(name,_,pure) -> pure
395 | _ -> Ast0.Impure) in
396
397 let expression r k e =
398 bind (bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e))
399 (match Ast0.unwrap e with
400 Ast0.MetaErr(name,_,pure)
401 | Ast0.MetaExpr(name,_,_,_,pure) | Ast0.MetaExprList(name,_,pure) ->
402 pure
403 | _ -> Ast0.Impure) in
404
405 let typeC r k t =
406 bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
407 (match Ast0.unwrap t with
408 Ast0.MetaType(name,pure) -> pure
409 | _ -> Ast0.Impure) in
410
411 let init r k t =
412 bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
413 (match Ast0.unwrap t with
414 Ast0.MetaInit(name,pure) | Ast0.MetaInitList(name,_,pure) -> pure
415 | _ -> Ast0.Impure) in
416
417 let param r k p =
418 bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p))
419 (match Ast0.unwrap p with
420 Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure
421 | _ -> Ast0.Impure) in
422
423 let decl r k d =
424 bind (bind (pure_mcodekind (Ast0.get_mcodekind d)) (k d))
425 (match Ast0.unwrap d with
426 Ast0.MetaDecl(name,pure) | Ast0.MetaField(name,pure)
427 | Ast0.MetaFieldList(name,_,pure) ->
428 pure
429 | _ -> Ast0.Impure) in
430
431 let stmt r k s =
432 bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s))
433 (match Ast0.unwrap s with
434 Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure
435 | _ -> Ast0.Impure) in
436
437 V0.flat_combiner bind option_default
438 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
439 donothing donothing donothing donothing donothing donothing
440 ident expression typeC init param decl stmt donothing donothing
441 donothing in
442
443 let add_pure_list_binding name pure is_pure builder1 builder2 lst =
444 match (checks_needed,pure) with
445 (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
446 (match lst with
447 [x] ->
448 if (Ast0.lub_pure (is_pure x) pure) = pure
449 then add_binding name (builder1 lst)
450 else return_false (NotPure (pure,term name,builder1 lst))
451 | _ -> return_false (NotPureLength (term name)))
452 | (false,_) | (_,Ast0.Impure) -> add_binding name (builder2 lst) in
453
454 let add_pure_binding name pure is_pure builder x =
455 match (checks_needed,pure) with
456 (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
457 if (Ast0.lub_pure (is_pure x) pure) = pure
458 then add_binding name (builder x)
459 else return_false (NotPure (pure,term name, builder x))
460 | (false,_) | (_,Ast0.Impure) -> add_binding name (builder x) in
461
462 let do_elist_match builder el lst =
463 match Ast0.unwrap el with
464 Ast0.MetaExprList(name,lenname,pure) ->
465 (*how to handle lenname? should it be an option type and always None?*)
466 failwith "expr list pattern not supported in iso"
467 (*add_pure_list_binding name pure
468 pure_sp_code.V0.combiner_expression
469 (function lst -> Ast0.ExprTag(List.hd lst))
470 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
471 lst*)
472 | _ -> failwith "not possible" in
473
474 let do_plist_match builder pl lst =
475 match Ast0.unwrap pl with
476 Ast0.MetaParamList(name,lename,pure) ->
477 failwith "param list pattern not supported in iso"
478 (*add_pure_list_binding name pure
479 pure_sp_code.V0.combiner_parameter
480 (function lst -> Ast0.ParamTag(List.hd lst))
481 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
482 lst*)
483 | _ -> failwith "not possible" in
484
485 let do_slist_match builder sl lst =
486 match Ast0.unwrap sl with
487 Ast0.MetaStmtList(name,pure) ->
488 add_pure_list_binding name pure
489 pure_sp_code.VT0.combiner_rec_statement
490 (function lst -> Ast0.StmtTag(List.hd lst))
491 (function lst -> Ast0.DotsStmtTag(build_dots builder lst))
492 lst
493 | _ -> failwith "not possible" in
494
495 let do_nolist_match _ _ = failwith "not possible" in
496
497 let rec match_ident pattern id =
498 match Ast0.unwrap pattern with
499 Ast0.MetaId(name,_,_,pure) ->
500 (add_pure_binding name pure pure_sp_code.VT0.combiner_rec_ident
501 (function id -> Ast0.IdentTag id) id)
502 | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
503 | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
504 | up ->
505 if not(checks_needed) or not(context_required) or is_context id
506 then
507 match (up,Ast0.unwrap id) with
508 (Ast0.Id(namea),Ast0.Id(nameb)) ->
509 if mcode_equal namea nameb
510 then check_mcode namea nameb
511 else return false
512 | (Ast0.DisjId(_,ids,_,_),_) ->
513 failwith "not allowed in the pattern of an isomorphism"
514 | (Ast0.OptIdent(ida),Ast0.OptIdent(idb))
515 | (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) ->
516 match_ident ida idb
517 | (_,Ast0.OptIdent(idb))
518 | (_,Ast0.UniqueIdent(idb)) -> match_ident pattern idb
519 | _ -> return false
520 else return_false (ContextRequired (Ast0.IdentTag id)) in
521
522 (* should we do something about matching metavars against ...? *)
523 let rec match_expr pattern expr =
524 match Ast0.unwrap pattern with
525 Ast0.MetaExpr(name,_,ty,form,pure) ->
526 let form_ok =
527 match (form,expr) with
528 (Ast.ANY,_) -> true
529 | (Ast.CONST,e) ->
530 let rec matches e =
531 match Ast0.unwrap e with
532 Ast0.Constant(c) -> true
533 | Ast0.Ident(c) ->
534 (match Ast0.unwrap c with
535 Ast0.Id(nm) ->
536 let nm = Ast0.unwrap_mcode nm in
537 (* all caps is a const *)
538 Str.string_match all_caps nm 0
539 | _ -> false)
540 | Ast0.Cast(lp,ty,rp,e) -> matches e
541 | Ast0.SizeOfExpr(se,exp) -> true
542 | Ast0.SizeOfType(se,lp,ty,rp) -> true
543 | Ast0.MetaExpr(nm,_,_,Ast.CONST,p) ->
544 (Ast0.lub_pure p pure) = pure
545 | _ -> false in
546 matches e
547 | (Ast.ID,e) | (Ast.LocalID,e) ->
548 let rec matches e =
549 match Ast0.unwrap e with
550 Ast0.Ident(c) -> true
551 | Ast0.Cast(lp,ty,rp,e) -> matches e
552 | Ast0.MetaExpr(nm,_,_,Ast.ID,p) ->
553 (Ast0.lub_pure p pure) = pure
554 | _ -> false in
555 matches e in
556 if form_ok
557 then
558 match ty with
559 Some ts ->
560 if List.exists
561 (function Type_cocci.MetaType(_,_,_) -> true | _ -> false)
562 ts
563 then
564 (match ts with
565 [Type_cocci.MetaType(tyname,_,_)] ->
566 let expty =
567 match (Ast0.unwrap expr,Ast0.get_type expr) with
568 (* easier than updating type inferencer to manage multiple
569 types *)
570 (Ast0.MetaExpr(_,_,Some tts,_,_),_) -> Some tts
571 | (_,Some ty) -> Some [ty]
572 | _ -> None in
573 (match expty with
574 Some expty ->
575 let tyname = Ast0.rewrap_mcode name tyname in
576 conjunct_bindings
577 (add_pure_binding name pure
578 pure_sp_code.VT0.combiner_rec_expression
579 (function expr -> Ast0.ExprTag expr)
580 expr)
581 (function bindings ->
582 let attempts =
583 List.map
584 (function expty ->
585 (try
586 add_pure_binding tyname Ast0.Impure
587 (function _ -> Ast0.Impure)
588 (function ty -> Ast0.TypeCTag ty)
589 (Ast0.rewrap expr
590 (Ast0.reverse_type expty))
591 bindings
592 with Ast0.TyConv ->
593 Printf.printf
594 "warning: unconvertible type";
595 return false bindings))
596 expty in
597 if List.exists
598 (function Fail _ -> false | OK x -> true)
599 attempts
600 then
601 (* not sure why this is ok. can there be more
602 than one OK? *)
603 OK (List.concat
604 (List.map
605 (function Fail _ -> [] | OK x -> x)
606 attempts))
607 else
608 Fail
609 (TypeMatch
610 (List.map
611 (function
612 Fail r -> r
613 | OK x -> failwith "not possible")
614 attempts)))
615 | _ ->
616 (*Printf.printf
617 "warning: type metavar can only match one type";*)
618 return false)
619 | _ ->
620 failwith
621 "mixture of metatype and other types not supported")
622 else
623 let expty = Ast0.get_type expr in
624 if List.exists (function t -> Type_cocci.compatible t expty) ts
625 then
626 add_pure_binding name pure
627 pure_sp_code.VT0.combiner_rec_expression
628 (function expr -> Ast0.ExprTag expr)
629 expr
630 else return false
631 | None ->
632 add_pure_binding name pure
633 pure_sp_code.VT0.combiner_rec_expression
634 (function expr -> Ast0.ExprTag expr)
635 expr
636 else return false
637 | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
638 | Ast0.MetaExprList(_,_,_) -> failwith "metaexprlist not supported"
639 | up ->
640 if not(checks_needed) or not(context_required) or is_context expr
641 then
642 match (up,Ast0.unwrap expr) with
643 (Ast0.Ident(ida),Ast0.Ident(idb)) ->
644 match_ident ida idb
645 | (Ast0.Constant(consta),Ast0.Constant(constb)) ->
646 if mcode_equal consta constb
647 then check_mcode consta constb
648 else return false
649 | (Ast0.FunCall(fna,lp1,argsa,rp1),Ast0.FunCall(fnb,lp,argsb,rp)) ->
650 conjunct_many_bindings
651 [check_mcode lp1 lp; check_mcode rp1 rp; match_expr fna fnb;
652 match_dots match_expr is_elist_matcher do_elist_match
653 argsa argsb]
654 | (Ast0.Assignment(lefta,opa,righta,_),
655 Ast0.Assignment(leftb,opb,rightb,_)) ->
656 if mcode_equal opa opb
657 then
658 conjunct_many_bindings
659 [check_mcode opa opb; match_expr lefta leftb;
660 match_expr righta rightb]
661 else return false
662 | (Ast0.Sequence(lefta,opa,righta),
663 Ast0.Sequence(leftb,opb,rightb)) ->
664 if mcode_equal opa opb
665 then
666 conjunct_many_bindings
667 [check_mcode opa opb; match_expr lefta leftb;
668 match_expr righta rightb]
669 else return false
670 | (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a),
671 Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) ->
672 conjunct_many_bindings
673 [check_mcode lp1 lp; check_mcode rp1 rp;
674 match_expr exp1a exp1b; match_option match_expr exp2a exp2b;
675 match_expr exp3a exp3b]
676 | (Ast0.Postfix(expa,opa),Ast0.Postfix(expb,opb)) ->
677 if mcode_equal opa opb
678 then
679 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
680 else return false
681 | (Ast0.Infix(expa,opa),Ast0.Infix(expb,opb)) ->
682 if mcode_equal opa opb
683 then
684 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
685 else return false
686 | (Ast0.Unary(expa,opa),Ast0.Unary(expb,opb)) ->
687 if mcode_equal opa opb
688 then
689 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
690 else return false
691 | (Ast0.Binary(lefta,opa,righta),Ast0.Binary(leftb,opb,rightb)) ->
692 if mcode_equal opa opb
693 then
694 conjunct_many_bindings
695 [check_mcode opa opb; match_expr lefta leftb;
696 match_expr righta rightb]
697 else return false
698 | (Ast0.Paren(lp1,expa,rp1),Ast0.Paren(lp,expb,rp)) ->
699 conjunct_many_bindings
700 [check_mcode lp1 lp; check_mcode rp1 rp; match_expr expa expb]
701 | (Ast0.ArrayAccess(exp1a,lb1,exp2a,rb1),
702 Ast0.ArrayAccess(exp1b,lb,exp2b,rb)) ->
703 conjunct_many_bindings
704 [check_mcode lb1 lb; check_mcode rb1 rb;
705 match_expr exp1a exp1b; match_expr exp2a exp2b]
706 | (Ast0.RecordAccess(expa,opa,fielda),
707 Ast0.RecordAccess(expb,op,fieldb))
708 | (Ast0.RecordPtAccess(expa,opa,fielda),
709 Ast0.RecordPtAccess(expb,op,fieldb)) ->
710 conjunct_many_bindings
711 [check_mcode opa op; match_expr expa expb;
712 match_ident fielda fieldb]
713 | (Ast0.Cast(lp1,tya,rp1,expa),Ast0.Cast(lp,tyb,rp,expb)) ->
714 conjunct_many_bindings
715 [check_mcode lp1 lp; check_mcode rp1 rp;
716 match_typeC tya tyb; match_expr expa expb]
717 | (Ast0.SizeOfExpr(szf1,expa),Ast0.SizeOfExpr(szf,expb)) ->
718 conjunct_bindings (check_mcode szf1 szf) (match_expr expa expb)
719 | (Ast0.SizeOfType(szf1,lp1,tya,rp1),
720 Ast0.SizeOfType(szf,lp,tyb,rp)) ->
721 conjunct_many_bindings
722 [check_mcode lp1 lp; check_mcode rp1 rp;
723 check_mcode szf1 szf; match_typeC tya tyb]
724 | (Ast0.Constructor(lp1,tya,rp1,inita),
725 Ast0.Constructor(lp,tyb,rp,initb)) ->
726 conjunct_many_bindings
727 [check_mcode lp1 lp; check_mcode rp1 rp;
728 match_typeC tya tyb; match_init inita initb]
729 | (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) ->
730 match_typeC tya tyb
731 | (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm
732 | (Ast0.DisjExpr(_,expsa,_,_),_) ->
733 failwith "not allowed in the pattern of an isomorphism"
734 | (Ast0.NestExpr(_,exp_dotsa,_,_,_),_) ->
735 failwith "not allowed in the pattern of an isomorphism"
736 | (Ast0.Edots(d,None),Ast0.Edots(d1,None))
737 | (Ast0.Ecircles(d,None),Ast0.Ecircles(d1,None))
738 | (Ast0.Estars(d,None),Ast0.Estars(d1,None)) -> check_mcode d d1
739 | (Ast0.Edots(ed,None),Ast0.Edots(ed1,Some wc))
740 | (Ast0.Ecircles(ed,None),Ast0.Ecircles(ed1,Some wc))
741 | (Ast0.Estars(ed,None),Ast0.Estars(ed1,Some wc)) ->
742 (* hope that mcode of edots is unique somehow *)
743 conjunct_bindings (check_mcode ed ed1)
744 (let (edots_whencode_allowed,_,_) = whencode_allowed in
745 if edots_whencode_allowed
746 then add_dot_binding ed (Ast0.ExprTag wc)
747 else
748 (Printf.printf
749 "warning: not applying iso because of whencode";
750 return false))
751 | (Ast0.Edots(_,Some _),_) | (Ast0.Ecircles(_,Some _),_)
752 | (Ast0.Estars(_,Some _),_) ->
753 failwith "whencode not allowed in a pattern1"
754 | (Ast0.OptExp(expa),Ast0.OptExp(expb))
755 | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) ->
756 match_expr expa expb
757 | (_,Ast0.OptExp(expb))
758 | (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
759 | _ -> return false
760 else return_false (ContextRequired (Ast0.ExprTag expr))
761
762 (* the special case for function types prevents the eg T X; -> T X = E; iso
763 from applying, which doesn't seem very relevant, but it also avoids a
764 mysterious bug that is obtained with eg int attach(...); *)
765 and match_typeC pattern t =
766 match Ast0.unwrap pattern with
767 Ast0.MetaType(name,pure) ->
768 (match Ast0.unwrap t with
769 Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false
770 | _ ->
771 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_typeC
772 (function ty -> Ast0.TypeCTag ty)
773 t)
774 | up ->
775 if not(checks_needed) or not(context_required) or is_context t
776 then
777 match (up,Ast0.unwrap t) with
778 (Ast0.ConstVol(cva,tya),Ast0.ConstVol(cvb,tyb)) ->
779 if mcode_equal cva cvb
780 then
781 conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb)
782 else return false
783 | (Ast0.BaseType(tya,stringsa),Ast0.BaseType(tyb,stringsb)) ->
784 if tya = tyb
785 then
786 match_list check_mcode
787 (function _ -> false) (function _ -> failwith "")
788 stringsa stringsb
789 else return false
790 | (Ast0.Signed(signa,tya),Ast0.Signed(signb,tyb)) ->
791 if mcode_equal signa signb
792 then
793 conjunct_bindings (check_mcode signa signb)
794 (match_option match_typeC tya tyb)
795 else return false
796 | (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) ->
797 conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb)
798 | (Ast0.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
799 Ast0.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
800 conjunct_many_bindings
801 [check_mcode stara starb; check_mcode lp1a lp1b;
802 check_mcode rp1a rp1b; check_mcode lp2a lp2b;
803 check_mcode rp2a rp2b; match_typeC tya tyb;
804 match_dots match_param is_plist_matcher
805 do_plist_match paramsa paramsb]
806 | (Ast0.FunctionType(tya,lp1a,paramsa,rp1a),
807 Ast0.FunctionType(tyb,lp1b,paramsb,rp1b)) ->
808 conjunct_many_bindings
809 [check_mcode lp1a lp1b; check_mcode rp1a rp1b;
810 match_option match_typeC tya tyb;
811 match_dots match_param is_plist_matcher do_plist_match
812 paramsa paramsb]
813 | (Ast0.Array(tya,lb1,sizea,rb1),Ast0.Array(tyb,lb,sizeb,rb)) ->
814 conjunct_many_bindings
815 [check_mcode lb1 lb; check_mcode rb1 rb;
816 match_typeC tya tyb; match_option match_expr sizea sizeb]
817 | (Ast0.EnumName(kinda,Some namea),
818 Ast0.EnumName(kindb,Some nameb)) ->
819 conjunct_bindings (check_mcode kinda kindb)
820 (match_ident namea nameb)
821 | (Ast0.EnumDef(tya,lb1,idsa,rb1),
822 Ast0.EnumDef(tyb,lb,idsb,rb)) ->
823 conjunct_many_bindings
824 [check_mcode lb1 lb; check_mcode rb1 rb;
825 match_typeC tya tyb;
826 match_dots match_expr no_list do_nolist_match idsa idsb]
827 | (Ast0.StructUnionName(kinda,Some namea),
828 Ast0.StructUnionName(kindb,Some nameb)) ->
829 if mcode_equal kinda kindb
830 then
831 conjunct_bindings (check_mcode kinda kindb)
832 (match_ident namea nameb)
833 else return false
834 | (Ast0.StructUnionDef(tya,lb1,declsa,rb1),
835 Ast0.StructUnionDef(tyb,lb,declsb,rb)) ->
836 conjunct_many_bindings
837 [check_mcode lb1 lb; check_mcode rb1 rb;
838 match_typeC tya tyb;
839 match_dots match_decl no_list do_nolist_match declsa declsb]
840 | (Ast0.TypeName(namea),Ast0.TypeName(nameb)) ->
841 if mcode_equal namea nameb
842 then check_mcode namea nameb
843 else return false
844 | (Ast0.DisjType(_,typesa,_,_),_) ->
845 failwith "not allowed in the pattern of an isomorphism"
846 | (Ast0.OptType(tya),Ast0.OptType(tyb))
847 | (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb
848 | (_,Ast0.OptType(tyb))
849 | (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb
850 | _ -> return false
851 else return_false (ContextRequired (Ast0.TypeCTag t))
852
853 and match_decl pattern d =
854 match Ast0.unwrap pattern with
855 Ast0.MetaDecl(name,pure) ->
856 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_declaration
857 (function d -> Ast0.DeclTag d)
858 d
859 | Ast0.MetaField(name,pure) ->
860 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_declaration
861 (function d -> Ast0.DeclTag d)
862 d
863 | Ast0.MetaFieldList(name,_,pure) -> failwith "metafieldlist not supporte"
864 | up ->
865 if not(checks_needed) or not(context_required) or is_context d
866 then
867 match (up,Ast0.unwrap d) with
868 (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
869 Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
870 if bool_match_option mcode_equal stga stgb
871 then
872 conjunct_many_bindings
873 [check_mcode eq1 eq; check_mcode sc1 sc;
874 match_option check_mcode stga stgb;
875 match_typeC tya tyb; match_ident ida idb;
876 match_init inia inib]
877 else return false
878 | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
879 if bool_match_option mcode_equal stga stgb
880 then
881 conjunct_many_bindings
882 [check_mcode sc1 sc; match_option check_mcode stga stgb;
883 match_typeC tya tyb; match_ident ida idb]
884 else return false
885 | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
886 Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
887 conjunct_many_bindings
888 [match_ident namea nameb;
889 check_mcode lp1 lp; check_mcode rp1 rp;
890 check_mcode sc1 sc;
891 match_dots match_expr is_elist_matcher do_elist_match
892 argsa argsb]
893 | (Ast0.MacroDeclInit(namea,lp1,argsa,rp1,eq1,ini1,sc1),
894 Ast0.MacroDeclInit(nameb,lp,argsb,rp,eq,ini,sc)) ->
895 conjunct_many_bindings
896 [match_ident namea nameb;
897 check_mcode lp1 lp; check_mcode rp1 rp;
898 check_mcode eq1 eq;
899 check_mcode sc1 sc;
900 match_dots match_expr is_elist_matcher do_elist_match
901 argsa argsb;
902 match_init ini1 ini]
903 | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
904 conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
905 | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
906 conjunct_bindings (check_mcode sc1 sc)
907 (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
908 | (Ast0.DisjDecl(_,declsa,_,_),_) ->
909 failwith "not allowed in the pattern of an isomorphism"
910 | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
911 | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
912 conjunct_bindings (check_mcode dd d)
913 (* hope that mcode of ddots is unique somehow *)
914 (let (ddots_whencode_allowed,_,_) = whencode_allowed in
915 if ddots_whencode_allowed
916 then add_dot_binding dd (Ast0.DeclTag wc)
917 else
918 (Printf.printf "warning: not applying iso because of whencode";
919 return false))
920 | (Ast0.Ddots(_,Some _),_) ->
921 failwith "whencode not allowed in a pattern1"
922
923 | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
924 | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
925 match_decl decla declb
926 | (_,Ast0.OptDecl(declb))
927 | (_,Ast0.UniqueDecl(declb)) ->
928 match_decl pattern declb
929 | _ -> return false
930 else return_false (ContextRequired (Ast0.DeclTag d))
931
932 and match_init pattern i =
933 match Ast0.unwrap pattern with
934 Ast0.MetaInit(name,pure) ->
935 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_initialiser
936 (function ini -> Ast0.InitTag ini)
937 i
938 | up ->
939 if not(checks_needed) or not(context_required) or is_context i
940 then
941 match (up,Ast0.unwrap i) with
942 (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
943 match_expr expa expb
944 | (Ast0.InitList(lb1,initlista,rb1,oa),
945 Ast0.InitList(lb,initlistb,rb,ob))
946 when oa = ob ->
947 conjunct_many_bindings
948 [check_mcode lb1 lb; check_mcode rb1 rb;
949 match_dots match_init no_list do_nolist_match
950 initlista initlistb]
951 | (Ast0.InitGccExt(designators1,e1,inia),
952 Ast0.InitGccExt(designators2,e2,inib)) ->
953 conjunct_many_bindings
954 [match_list match_designator
955 (function _ -> false) (function _ -> failwith "")
956 designators1 designators2;
957 check_mcode e1 e2;
958 match_init inia inib]
959 | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
960 conjunct_many_bindings
961 [check_mcode c1 c; match_ident namea nameb;
962 match_init inia inib]
963 | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
964 | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
965 | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
966 conjunct_bindings (check_mcode id d)
967 (* hope that mcode of edots is unique somehow *)
968 (let (_,idots_whencode_allowed,_) = whencode_allowed in
969 if idots_whencode_allowed
970 then add_dot_binding id (Ast0.InitTag wc)
971 else
972 (Printf.printf
973 "warning: not applying iso because of whencode";
974 return false))
975 | (Ast0.Idots(_,Some _),_) ->
976 failwith "whencode not allowed in a pattern2"
977 | (Ast0.OptIni(ia),Ast0.OptIni(ib))
978 | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
979 | (_,Ast0.OptIni(ib))
980 | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
981 | _ -> return false
982 else return_false (ContextRequired (Ast0.InitTag i))
983
984 and match_designator pattern d =
985 match (pattern,d) with
986 (Ast0.DesignatorField(dota,ida),Ast0.DesignatorField(dotb,idb)) ->
987 conjunct_bindings (check_mcode dota dotb) (match_ident ida idb)
988 | (Ast0.DesignatorIndex(lba,expa,rba),
989 Ast0.DesignatorIndex(lbb,expb,rbb)) ->
990 conjunct_many_bindings
991 [check_mcode lba lbb; match_expr expa expb;
992 check_mcode rba rbb]
993 | (Ast0.DesignatorRange(lba,mina,dotsa,maxa,rba),
994 Ast0.DesignatorRange(lbb,minb,dotsb,maxb,rbb)) ->
995 conjunct_many_bindings
996 [check_mcode lba lbb; match_expr mina minb;
997 check_mcode dotsa dotsb; match_expr maxa maxb;
998 check_mcode rba rbb]
999 | _ -> return false
1000
1001 and match_param pattern p =
1002 match Ast0.unwrap pattern with
1003 Ast0.MetaParam(name,pure) ->
1004 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_parameter
1005 (function p -> Ast0.ParamTag p)
1006 p
1007 | Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported"
1008 | up ->
1009 if not(checks_needed) or not(context_required) or is_context p
1010 then
1011 match (up,Ast0.unwrap p) with
1012 (Ast0.VoidParam(tya),Ast0.VoidParam(tyb)) -> match_typeC tya tyb
1013 | (Ast0.Param(tya,ida),Ast0.Param(tyb,idb)) ->
1014 conjunct_bindings (match_typeC tya tyb)
1015 (match_option match_ident ida idb)
1016 | (Ast0.PComma(c1),Ast0.PComma(c)) -> check_mcode c1 c
1017 | (Ast0.Pdots(d1),Ast0.Pdots(d))
1018 | (Ast0.Pcircles(d1),Ast0.Pcircles(d)) -> check_mcode d1 d
1019 | (Ast0.OptParam(parama),Ast0.OptParam(paramb))
1020 | (Ast0.UniqueParam(parama),Ast0.UniqueParam(paramb)) ->
1021 match_param parama paramb
1022 | (_,Ast0.OptParam(paramb))
1023 | (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb
1024 | _ -> return false
1025 else return_false (ContextRequired (Ast0.ParamTag p))
1026
1027 and match_statement pattern s =
1028 match Ast0.unwrap pattern with
1029 Ast0.MetaStmt(name,pure) ->
1030 (match Ast0.unwrap s with
1031 Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) ->
1032 return false (* ... is not a single statement *)
1033 | _ ->
1034 add_pure_binding name pure pure_sp_code.VT0.combiner_rec_statement
1035 (function ty -> Ast0.StmtTag ty)
1036 s)
1037 | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
1038 | up ->
1039 if not(checks_needed) or not(context_required) or is_context s
1040 then
1041 match (up,Ast0.unwrap s) with
1042 (Ast0.FunDecl(_,fninfoa,namea,lp1,paramsa,rp1,lb1,bodya,rb1),
1043 Ast0.FunDecl(_,fninfob,nameb,lp,paramsb,rp,lb,bodyb,rb)) ->
1044 conjunct_many_bindings
1045 [check_mcode lp1 lp; check_mcode rp1 rp;
1046 check_mcode lb1 lb; check_mcode rb1 rb;
1047 match_fninfo fninfoa fninfob; match_ident namea nameb;
1048 match_dots match_param is_plist_matcher do_plist_match
1049 paramsa paramsb;
1050 match_dots match_statement is_slist_matcher do_slist_match
1051 bodya bodyb]
1052 | (Ast0.Decl(_,decla),Ast0.Decl(_,declb)) ->
1053 match_decl decla declb
1054 | (Ast0.Seq(lb1,bodya,rb1),Ast0.Seq(lb,bodyb,rb)) ->
1055 (* seqs can only match if they are all minus (plus code
1056 allowed) or all context (plus code not allowed in the body).
1057 we could be more permissive if the expansions of the isos are
1058 also all seqs, but this would be hard to check except at top
1059 level, and perhaps not worth checking even in that case.
1060 Overall, the issue is that braces are used where single
1061 statements are required, and something not satisfying these
1062 conditions can cause a single statement to become a
1063 non-single statement after the transformation.
1064
1065 example: if { ... -foo(); ... }
1066 if we let the sequence convert to just -foo();
1067 then we produce invalid code. For some reason,
1068 single_statement can't deal with this case, perhaps because
1069 it starts introducing too many braces? don't remember the
1070 exact problem...
1071 *)
1072 conjunct_bindings (check_mcode lb1 lb)
1073 (conjunct_bindings (check_mcode rb1 rb)
1074 (if not(checks_needed) or is_minus s or
1075 (is_context s &&
1076 List.for_all is_pure_context (Ast0.undots bodyb))
1077 then
1078 match_dots match_statement is_slist_matcher do_slist_match
1079 bodya bodyb
1080 else return_false (Braces(s))))
1081 | (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) ->
1082 conjunct_bindings (check_mcode sc1 sc)
1083 (match_option match_expr expa expb)
1084 | (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_),
1085 Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) ->
1086 conjunct_many_bindings
1087 [check_mcode if1 if2; check_mcode lp1 lp2;
1088 check_mcode rp1 rp2;
1089 match_expr expa expb;
1090 match_statement branch1a branch1b]
1091 | (Ast0.IfThenElse(if1,lp1,expa,rp1,branch1a,e1,branch2a,_),
1092 Ast0.IfThenElse(if2,lp2,expb,rp2,branch1b,e2,branch2b,_)) ->
1093 conjunct_many_bindings
1094 [check_mcode if1 if2; check_mcode lp1 lp2;
1095 check_mcode rp1 rp2; check_mcode e1 e2;
1096 match_expr expa expb;
1097 match_statement branch1a branch1b;
1098 match_statement branch2a branch2b]
1099 | (Ast0.While(w1,lp1,expa,rp1,bodya,_),
1100 Ast0.While(w,lp,expb,rp,bodyb,_)) ->
1101 conjunct_many_bindings
1102 [check_mcode w1 w; check_mcode lp1 lp;
1103 check_mcode rp1 rp; match_expr expa expb;
1104 match_statement bodya bodyb]
1105 | (Ast0.Do(d1,bodya,w1,lp1,expa,rp1,_),
1106 Ast0.Do(d,bodyb,w,lp,expb,rp,_)) ->
1107 conjunct_many_bindings
1108 [check_mcode d1 d; check_mcode w1 w; check_mcode lp1 lp;
1109 check_mcode rp1 rp; match_statement bodya bodyb;
1110 match_expr expa expb]
1111 | (Ast0.For(f1,lp1,firsta,e2a,sc2a,e3a,rp1,bodya,_),
1112 Ast0.For(f,lp,firstb,e2b,sc2b,e3b,rp,bodyb,_)) ->
1113 let first =
1114 match (Ast0.unwrap firsta,Ast0.unwrap firstb) with
1115 (Ast0.ForExp(e1a,sc1a),Ast0.ForExp(e1b,sc1b)) ->
1116 conjunct_bindings
1117 (check_mcode sc2a sc2b)
1118 (match_option match_expr e1a e1b)
1119 | (Ast0.ForDecl (_,decla),Ast0.ForDecl (_,declb)) ->
1120 match_decl decla declb
1121 | _ -> return false in
1122 conjunct_many_bindings
1123 [check_mcode f1 f; check_mcode lp1 lp; first;
1124 check_mcode sc2a sc2b; check_mcode rp1 rp;
1125 match_option match_expr e2a e2b;
1126 match_option match_expr e3a e3b;
1127 match_statement bodya bodyb]
1128 | (Ast0.Iterator(nma,lp1,argsa,rp1,bodya,_),
1129 Ast0.Iterator(nmb,lp,argsb,rp,bodyb,_)) ->
1130 conjunct_many_bindings
1131 [match_ident nma nmb;
1132 check_mcode lp1 lp; check_mcode rp1 rp;
1133 match_dots match_expr is_elist_matcher do_elist_match
1134 argsa argsb;
1135 match_statement bodya bodyb]
1136 | (Ast0.Switch(s1,lp1,expa,rp1,lb1,declsa,casesa,rb1),
1137 Ast0.Switch(s,lp,expb,rp,lb,declsb,casesb,rb)) ->
1138 conjunct_many_bindings
1139 [check_mcode s1 s; check_mcode lp1 lp; check_mcode rp1 rp;
1140 check_mcode lb1 lb; check_mcode rb1 rb;
1141 match_expr expa expb;
1142 match_dots match_statement is_slist_matcher do_slist_match
1143 declsa declsb;
1144 match_dots match_case_line no_list do_nolist_match
1145 casesa casesb]
1146 | (Ast0.Break(b1,sc1),Ast0.Break(b,sc))
1147 | (Ast0.Continue(b1,sc1),Ast0.Continue(b,sc)) ->
1148 conjunct_bindings (check_mcode b1 b) (check_mcode sc1 sc)
1149 | (Ast0.Label(l1,c1),Ast0.Label(l2,c)) ->
1150 conjunct_bindings (match_ident l1 l2) (check_mcode c1 c)
1151 | (Ast0.Goto(g1,l1,sc1),Ast0.Goto(g,l2,sc)) ->
1152 conjunct_many_bindings
1153 [check_mcode g1 g; check_mcode sc1 sc; match_ident l1 l2]
1154 | (Ast0.Return(r1,sc1),Ast0.Return(r,sc)) ->
1155 conjunct_bindings (check_mcode r1 r) (check_mcode sc1 sc)
1156 | (Ast0.ReturnExpr(r1,expa,sc1),Ast0.ReturnExpr(r,expb,sc)) ->
1157 conjunct_many_bindings
1158 [check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb]
1159 | (Ast0.Disj(_,statement_dots_lista,_,_),_) ->
1160 failwith "disj not supported in patterns"
1161 | (Ast0.Nest(_,stmt_dotsa,_,[],multia),
1162 Ast0.Nest(_,stmt_dotsb,_,wc,multib)) ->
1163 if multia = multib
1164 then
1165 (match wc with
1166 [] ->
1167 (* not sure this is correct, perhaps too restrictive *)
1168 if not(checks_needed) or is_minus s or
1169 (is_context s &&
1170 List.for_all is_pure_context (Ast0.undots stmt_dotsb))
1171 then
1172 match_dots match_statement
1173 is_slist_matcher do_slist_match
1174 stmt_dotsa stmt_dotsb
1175 else return_false (Braces(s))
1176 | _ -> return_false (Nest(s)))
1177 else return false (* diff kind of nest *)
1178 | (Ast0.Nest(_,stmt_dotsa,_,_,_),_) ->
1179 failwith "nest with whencode not supported in patterns"
1180 | (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb
1181 | (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
1182 | (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
1183 | (Ast0.TopInit(inita),Ast0.TopInit(initb)) -> match_init inita initb
1184 | (Ast0.Ty(tya),Ast0.Ty(tyb)) -> match_typeC tya tyb
1185 | (Ast0.Dots(d,[]),Ast0.Dots(d1,wc))
1186 | (Ast0.Circles(d,[]),Ast0.Circles(d1,wc))
1187 | (Ast0.Stars(d,[]),Ast0.Stars(d1,wc)) ->
1188 (match wc with
1189 [] -> check_mcode d d1
1190 | _ ->
1191 let (_,_,dots_whencode_allowed) = whencode_allowed in
1192 if dots_whencode_allowed
1193 then
1194 conjunct_bindings (check_mcode d d1)
1195 (List.fold_left
1196 (function prev ->
1197 function
1198 | Ast0.WhenNot wc ->
1199 conjunct_bindings prev
1200 (add_multi_dot_binding d
1201 (Ast0.DotsStmtTag wc))
1202 | Ast0.WhenAlways wc ->
1203 conjunct_bindings prev
1204 (add_multi_dot_binding d (Ast0.StmtTag wc))
1205 | Ast0.WhenNotTrue wc ->
1206 conjunct_bindings prev
1207 (add_multi_dot_binding d
1208 (Ast0.IsoWhenTTag wc))
1209 | Ast0.WhenNotFalse wc ->
1210 conjunct_bindings prev
1211 (add_multi_dot_binding d
1212 (Ast0.IsoWhenFTag wc))
1213 | Ast0.WhenModifier(x) ->
1214 conjunct_bindings prev
1215 (add_multi_dot_binding d
1216 (Ast0.IsoWhenTag x)))
1217 (return true) wc)
1218 else
1219 (Printf.printf
1220 "warning: not applying iso because of whencode";
1221 return false))
1222 | (Ast0.Dots(_,_::_),_) | (Ast0.Circles(_,_::_),_)
1223 | (Ast0.Stars(_,_::_),_) ->
1224 failwith "whencode not allowed in a pattern3"
1225 | (Ast0.OptStm(rea),Ast0.OptStm(reb))
1226 | (Ast0.UniqueStm(rea),Ast0.UniqueStm(reb)) ->
1227 match_statement rea reb
1228 | (_,Ast0.OptStm(reb))
1229 | (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb
1230 | _ -> return false
1231 else return_false (ContextRequired (Ast0.StmtTag s))
1232
1233 (* first should provide a subset of the information in the second *)
1234 and match_fninfo patterninfo cinfo =
1235 let patterninfo = List.sort compare patterninfo in
1236 let cinfo = List.sort compare cinfo in
1237 let rec loop = function
1238 (Ast0.FStorage(sta)::resta,Ast0.FStorage(stb)::restb) ->
1239 if mcode_equal sta stb
1240 then conjunct_bindings (check_mcode sta stb) (loop (resta,restb))
1241 else return false
1242 | (Ast0.FType(tya)::resta,Ast0.FType(tyb)::restb) ->
1243 conjunct_bindings (match_typeC tya tyb) (loop (resta,restb))
1244 | (Ast0.FInline(ia)::resta,Ast0.FInline(ib)::restb) ->
1245 if mcode_equal ia ib
1246 then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
1247 else return false
1248 | (Ast0.FAttr(ia)::resta,Ast0.FAttr(ib)::restb) ->
1249 if mcode_equal ia ib
1250 then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
1251 else return false
1252 | (x::resta,((y::_) as restb)) ->
1253 (match compare x y with
1254 -1 -> return false
1255 | 1 -> loop (resta,restb)
1256 | _ -> failwith "not possible")
1257 | _ -> return false in
1258 loop (patterninfo,cinfo)
1259
1260 and match_case_line pattern c =
1261 if not(checks_needed) or not(context_required) or is_context c
1262 then
1263 match (Ast0.unwrap pattern,Ast0.unwrap c) with
1264 (Ast0.Default(d1,c1,codea),Ast0.Default(d,c,codeb)) ->
1265 conjunct_many_bindings
1266 [check_mcode d1 d; check_mcode c1 c;
1267 match_dots match_statement is_slist_matcher do_slist_match
1268 codea codeb]
1269 | (Ast0.Case(ca1,expa,c1,codea),Ast0.Case(ca,expb,c,codeb)) ->
1270 conjunct_many_bindings
1271 [check_mcode ca1 ca; check_mcode c1 c; match_expr expa expb;
1272 match_dots match_statement is_slist_matcher do_slist_match
1273 codea codeb]
1274 | (Ast0.DisjCase(_,case_linesa,_,_),_) ->
1275 failwith "not allowed in the pattern of an isomorphism"
1276 | (Ast0.OptCase(ca),Ast0.OptCase(cb)) -> match_case_line ca cb
1277 | (_,Ast0.OptCase(cb)) -> match_case_line pattern cb
1278 | _ -> return false
1279 else return_false (ContextRequired (Ast0.CaseLineTag c)) in
1280
1281 let match_statement_dots x y =
1282 match_dots match_statement is_slist_matcher do_slist_match x y in
1283
1284 (match_expr, match_decl, match_statement, match_typeC,
1285 match_statement_dots)
1286
1287 let match_expr dochecks context_required whencode_allowed =
1288 let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in
1289 fn
1290
1291 let match_decl dochecks context_required whencode_allowed =
1292 let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in
1293 fn
1294
1295 let match_statement dochecks context_required whencode_allowed =
1296 let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in
1297 fn
1298
1299 let match_typeC dochecks context_required whencode_allowed =
1300 let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in
1301 fn
1302
1303 let match_statement_dots dochecks context_required whencode_allowed =
1304 let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in
1305 fn
1306
1307 (* --------------------------------------------------------------------- *)
1308 (* make an entire tree MINUS *)
1309
1310 let make_minus =
1311 let mcode (term,arity,info,mcodekind,pos,adj) =
1312 let new_mcodekind =
1313 match mcodekind with
1314 Ast0.CONTEXT(mc) ->
1315 (match !mc with
1316 (Ast.NOTHING,_,_) ->
1317 Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info))
1318 | _ -> failwith "make_minus: unexpected befaft")
1319 | Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
1320 | _ -> failwith "make_minus mcode: unexpected mcodekind" in
1321 (term,arity,info,new_mcodekind,pos,adj) in
1322
1323 let update_mc mcodekind e =
1324 match !mcodekind with
1325 Ast0.CONTEXT(mc) ->
1326 (match !mc with
1327 (Ast.NOTHING,_,_) ->
1328 mcodekind :=
1329 Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info))
1330 | _ -> failwith "make_minus: unexpected befaft")
1331 | Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
1332 | Ast0.PLUS _ -> failwith "make_minus donothing: unexpected plus mcodekind"
1333 | _ -> failwith "make_minus donothing: unexpected mcodekind" in
1334
1335 let donothing r k e =
1336 let mcodekind = Ast0.get_mcodekind_ref e in
1337 let e = k e in update_mc mcodekind e; e in
1338
1339 (* special case for whencode, because it isn't processed by contextneg,
1340 since it doesn't appear in the + code *)
1341 (* cases for dots and nests *)
1342 let expression r k e =
1343 let mcodekind = Ast0.get_mcodekind_ref e in
1344 match Ast0.unwrap e with
1345 Ast0.Edots(d,whencode) ->
1346 (*don't recurse because whencode hasn't been processed by context_neg*)
1347 update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode))
1348 | Ast0.Ecircles(d,whencode) ->
1349 (*don't recurse because whencode hasn't been processed by context_neg*)
1350 update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode))
1351 | Ast0.Estars(d,whencode) ->
1352 (*don't recurse because whencode hasn't been processed by context_neg*)
1353 update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode))
1354 | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
1355 update_mc mcodekind e;
1356 Ast0.rewrap e
1357 (Ast0.NestExpr(mcode starter,
1358 r.VT0.rebuilder_rec_expression_dots expr_dots,
1359 mcode ender,whencode,multi))
1360 | _ -> donothing r k e in
1361
1362 let declaration r k e =
1363 let mcodekind = Ast0.get_mcodekind_ref e in
1364 match Ast0.unwrap e with
1365 Ast0.Ddots(d,whencode) ->
1366 (*don't recurse because whencode hasn't been processed by context_neg*)
1367 update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode))
1368 | _ -> donothing r k e in
1369
1370 let statement r k e =
1371 let mcodekind = Ast0.get_mcodekind_ref e in
1372 match Ast0.unwrap e with
1373 Ast0.Dots(d,whencode) ->
1374 (*don't recurse because whencode hasn't been processed by context_neg*)
1375 update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode))
1376 | Ast0.Circles(d,whencode) ->
1377 update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode))
1378 | Ast0.Stars(d,whencode) ->
1379 update_mc mcodekind e; Ast0.rewrap e (Ast0.Stars(mcode d,whencode))
1380 | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
1381 update_mc mcodekind e;
1382 Ast0.rewrap e
1383 (Ast0.Nest
1384 (mcode starter,r.VT0.rebuilder_rec_statement_dots stmt_dots,
1385 mcode ender,whencode,multi))
1386 | _ -> donothing r k e in
1387
1388 let initialiser r k e =
1389 let mcodekind = Ast0.get_mcodekind_ref e in
1390 match Ast0.unwrap e with
1391 Ast0.Idots(d,whencode) ->
1392 (*don't recurse because whencode hasn't been processed by context_neg*)
1393 update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode))
1394 | _ -> donothing r k e in
1395
1396 let dots r k e =
1397 let info = Ast0.get_info e in
1398 let mcodekind = Ast0.get_mcodekind_ref e in
1399 match Ast0.unwrap e with
1400 Ast0.DOTS([]) ->
1401 (* if context is - this should be - as well. There are no tokens
1402 here though, so the bottom-up minusifier in context_neg leaves it
1403 as mixed (or context for sgrep2). It would be better to fix
1404 context_neg, but that would
1405 require a special case for each term with a dots subterm. *)
1406 (match !mcodekind with
1407 Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
1408 (match !mc with
1409 (Ast.NOTHING,_,_) ->
1410 mcodekind :=
1411 Ast0.MINUS(ref(Ast.NOREPLACEMENT,Ast0.default_token_info));
1412 e
1413 | _ -> failwith "make_minus: unexpected befaft")
1414 (* code already processed by an enclosing iso *)
1415 | Ast0.MINUS(mc) -> e
1416 | _ ->
1417 failwith
1418 (Printf.sprintf
1419 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1420 info.Ast0.pos_info.Ast0.line_start (Dumper.dump e)))
1421 | _ -> donothing r k e in
1422
1423 V0.flat_rebuilder
1424 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1425 dots dots dots dots dots dots
1426 donothing expression donothing initialiser donothing declaration
1427 statement donothing donothing donothing
1428
1429 (* --------------------------------------------------------------------- *)
1430 (* rebuild mcode cells in an instantiated alt *)
1431
1432 (* mcodes will be side effected later with plus code, so we have to copy
1433 them on instantiating an isomorphism. One could wonder whether it would
1434 be better not to use side-effects, but they are convenient for insert_plus
1435 where is it useful to manipulate a list of the mcodes but side-effect a
1436 tree *)
1437 (* hmm... Insert_plus is called before Iso_pattern... *)
1438 let rebuild_mcode start_line =
1439 let copy_mcodekind = function
1440 Ast0.CONTEXT(mc) -> Ast0.CONTEXT(ref (!mc))
1441 | Ast0.MINUS(mc) -> Ast0.MINUS(ref (!mc))
1442 | Ast0.MIXED(mc) -> Ast0.MIXED(ref (!mc))
1443 | Ast0.PLUS count ->
1444 (* this function is used elsewhere where we need to rebuild the
1445 indices, and so we allow PLUS code as well *)
1446 Ast0.PLUS count in
1447
1448 let mcode (term,arity,info,mcodekind,pos,adj) =
1449 let info =
1450 match start_line with
1451 Some x ->
1452 let new_pos_info =
1453 {info.Ast0.pos_info with
1454 Ast0.line_start = x;
1455 Ast0.line_end = x; } in
1456 {info with Ast0.pos_info = new_pos_info}
1457 | None -> info in
1458 (term,arity,info,copy_mcodekind mcodekind,pos,adj) in
1459
1460 let copy_one x =
1461 let old_info = Ast0.get_info x in
1462 let info =
1463 match start_line with
1464 Some x ->
1465 let new_pos_info =
1466 {old_info.Ast0.pos_info with
1467 Ast0.line_start = x;
1468 Ast0.line_end = x; } in
1469 {old_info with Ast0.pos_info = new_pos_info}
1470 | None -> old_info in
1471 {x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x);
1472 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in
1473
1474 let donothing r k e = copy_one (k e) in
1475
1476 (* case for control operators (if, etc) *)
1477 let statement r k e =
1478 let s = k e in
1479 let res =
1480 copy_one
1481 (Ast0.rewrap s
1482 (match Ast0.unwrap s with
1483 Ast0.Decl((info,mc),decl) ->
1484 Ast0.Decl((info,copy_mcodekind mc),decl)
1485 | Ast0.IfThen(iff,lp,tst,rp,branch,(info,mc)) ->
1486 Ast0.IfThen(iff,lp,tst,rp,branch,(info,copy_mcodekind mc))
1487 | Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,(info,mc)) ->
1488 Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,
1489 (info,copy_mcodekind mc))
1490 | Ast0.While(whl,lp,exp,rp,body,(info,mc)) ->
1491 Ast0.While(whl,lp,exp,rp,body,(info,copy_mcodekind mc))
1492 | Ast0.For(fr,lp,first,e2,sem2,e3,rp,body,(info,mc)) ->
1493 Ast0.For(fr,lp,first,e2,sem2,e3,rp,body,
1494 (info,copy_mcodekind mc))
1495 | Ast0.Iterator(nm,lp,args,rp,body,(info,mc)) ->
1496 Ast0.Iterator(nm,lp,args,rp,body,(info,copy_mcodekind mc))
1497 | Ast0.FunDecl
1498 ((info,mc),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
1499 Ast0.FunDecl
1500 ((info,copy_mcodekind mc),
1501 fninfo,name,lp,params,rp,lbrace,body,rbrace)
1502 | s -> s)) in
1503 Ast0.set_dots_bef_aft res
1504 (match Ast0.get_dots_bef_aft res with
1505 Ast0.NoDots -> Ast0.NoDots
1506 | Ast0.AddingBetweenDots s ->
1507 Ast0.AddingBetweenDots(r.VT0.rebuilder_rec_statement s)
1508 | Ast0.DroppingBetweenDots s ->
1509 Ast0.DroppingBetweenDots(r.VT0.rebuilder_rec_statement s)) in
1510
1511 V0.flat_rebuilder
1512 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1513 donothing donothing donothing donothing donothing donothing
1514 donothing donothing donothing donothing donothing
1515 donothing statement donothing donothing donothing
1516
1517 (* --------------------------------------------------------------------- *)
1518 (* The problem of whencode. If an isomorphism contains dots in multiple
1519 rules, then the code that is matched cannot contain whencode, because we
1520 won't know which dots it goes with. Should worry about nests, but they
1521 aren't allowed in isomorphisms for the moment. *)
1522
1523 let count_edots =
1524 let option_default = 0 in
1525 let bind x y = x + y in
1526 let exprfn r k e =
1527 match Ast0.unwrap e with
1528 Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1
1529 | _ -> 0 in
1530
1531 V0.combiner bind option_default
1532 {V0.combiner_functions with VT0.combiner_exprfn = exprfn}
1533
1534 let count_idots =
1535 let option_default = 0 in
1536 let bind x y = x + y in
1537 let initfn r k e =
1538 match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in
1539
1540 V0.combiner bind option_default
1541 {V0.combiner_functions with VT0.combiner_initfn = initfn}
1542
1543 let count_dots =
1544 let option_default = 0 in
1545 let bind x y = x + y in
1546 let stmtfn r k e =
1547 match Ast0.unwrap e with
1548 Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1
1549 | _ -> 0 in
1550
1551 V0.combiner bind option_default
1552 {V0.combiner_functions with VT0.combiner_stmtfn = stmtfn}
1553
1554 (* --------------------------------------------------------------------- *)
1555
1556 let lookup name bindings mv_bindings =
1557 try Common.Left (List.assoc (term name) bindings)
1558 with
1559 Not_found ->
1560 (* failure is not possible anymore *)
1561 Common.Right (List.assoc (term name) mv_bindings)
1562
1563 (* mv_bindings is for the fresh metavariables that are introduced by the
1564 isomorphism *)
1565 let instantiate bindings mv_bindings =
1566 let mcode x =
1567 let (hidden,others) =
1568 List.partition
1569 (function Ast0.HiddenVarTag _ -> true | _ -> false)
1570 (Ast0.get_pos x) in
1571 let new_names =
1572 match hidden with
1573 [Ast0.HiddenVarTag([Ast0.MetaPosTag(Ast0.MetaPos (name,_,_))])] ->
1574 (try
1575 (* not at all sure that this is good enough *)
1576 match lookup name bindings mv_bindings with
1577 Common.Left(Ast0.HiddenVarTag(ids)) -> ids
1578 | _ -> failwith "not possible"
1579 with Not_found ->
1580 (*can't fail because checks_needed could be false?*)
1581 [])
1582 | [] -> [] (* no hidden metavars allowed *)
1583 | _ -> failwith "badly compiled mcode" in
1584 Ast0.set_pos (new_names@others) x in
1585 let donothing r k e = k e in
1586
1587 (* cases where metavariables can occur *)
1588 let identfn r k e =
1589 let e = k e in
1590 match Ast0.unwrap e with
1591 Ast0.MetaId(name,constraints,seed,pure) ->
1592 (rebuild_mcode None).VT0.rebuilder_rec_ident
1593 (match lookup name bindings mv_bindings with
1594 Common.Left(Ast0.IdentTag(id)) -> id
1595 | Common.Left(_) -> failwith "not possible 1"
1596 | Common.Right(new_mv) ->
1597 Ast0.rewrap e
1598 (Ast0.MetaId
1599 (Ast0.set_mcode_data new_mv name,constraints,seed,pure)))
1600 | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
1601 | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
1602 | _ -> e in
1603
1604 (* case for list metavariables *)
1605 let rec elist r same_dots = function
1606 [] -> []
1607 | [x] ->
1608 (match Ast0.unwrap x with
1609 Ast0.MetaExprList(name,lenname,pure) ->
1610 failwith "meta_expr_list in iso not supported"
1611 (*match lookup name bindings mv_bindings with
1612 Common.Left(Ast0.DotsExprTag(exp)) ->
1613 (match same_dots exp with
1614 Some l -> l
1615 | None -> failwith "dots put in incompatible context")
1616 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1617 | Common.Left(_) -> failwith "not possible 1"
1618 | Common.Right(new_mv) ->
1619 failwith "MetaExprList in SP not supported"*)
1620 | _ -> [r.VT0.rebuilder_rec_expression x])
1621 | x::xs -> (r.VT0.rebuilder_rec_expression x)::(elist r same_dots xs) in
1622
1623 let rec plist r same_dots = function
1624 [] -> []
1625 | [x] ->
1626 (match Ast0.unwrap x with
1627 Ast0.MetaParamList(name,lenname,pure) ->
1628 failwith "meta_param_list in iso not supported"
1629 (*match lookup name bindings mv_bindings with
1630 Common.Left(Ast0.DotsParamTag(param)) ->
1631 (match same_dots param with
1632 Some l -> l
1633 | None -> failwith "dots put in incompatible context")
1634 | Common.Left(Ast0.ParamTag(param)) -> [param]
1635 | Common.Left(_) -> failwith "not possible 1"
1636 | Common.Right(new_mv) ->
1637 failwith "MetaExprList in SP not supported"*)
1638 | _ -> [r.VT0.rebuilder_rec_parameter x])
1639 | x::xs -> (r.VT0.rebuilder_rec_parameter x)::(plist r same_dots xs) in
1640
1641 let rec slist r same_dots = function
1642 [] -> []
1643 | [x] ->
1644 (match Ast0.unwrap x with
1645 Ast0.MetaStmtList(name,pure) ->
1646 (match lookup name bindings mv_bindings with
1647 Common.Left(Ast0.DotsStmtTag(stm)) ->
1648 (match same_dots stm with
1649 Some l -> l
1650 | None -> failwith "dots put in incompatible context")
1651 | Common.Left(Ast0.StmtTag(stm)) -> [stm]
1652 | Common.Left(_) -> failwith "not possible 1"
1653 | Common.Right(new_mv) ->
1654 failwith "MetaExprList in SP not supported")
1655 | _ -> [r.VT0.rebuilder_rec_statement x])
1656 | x::xs -> (r.VT0.rebuilder_rec_statement x)::(slist r same_dots xs) in
1657
1658 let same_dots d =
1659 match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in
1660 let same_circles d =
1661 match Ast0.unwrap d with Ast0.CIRCLES(l) -> Some l |_ -> None in
1662 let same_stars d =
1663 match Ast0.unwrap d with Ast0.STARS(l) -> Some l |_ -> None in
1664
1665 let dots list_fn r k d =
1666 Ast0.rewrap d
1667 (match Ast0.unwrap d with
1668 Ast0.DOTS(l) -> Ast0.DOTS(list_fn r same_dots l)
1669 | Ast0.CIRCLES(l) -> Ast0.CIRCLES(list_fn r same_circles l)
1670 | Ast0.STARS(l) -> Ast0.STARS(list_fn r same_stars l)) in
1671
1672 let exprfn r k old_e = (* need to keep the original code for ! optim *)
1673 let e = k old_e in
1674 let e1 =
1675 match Ast0.unwrap e with
1676 Ast0.MetaExpr(name,constraints,x,form,pure) ->
1677 (rebuild_mcode None).VT0.rebuilder_rec_expression
1678 (match lookup name bindings mv_bindings with
1679 Common.Left(Ast0.ExprTag(exp)) -> exp
1680 | Common.Left(_) -> failwith "not possible 1"
1681 | Common.Right(new_mv) ->
1682 let new_types =
1683 match x with
1684 None -> None
1685 | Some types ->
1686 let rec renamer = function
1687 Type_cocci.MetaType(name,keep,inherited) ->
1688 (match
1689 lookup (name,(),(),(),None,-1)
1690 bindings mv_bindings
1691 with
1692 Common.Left(Ast0.TypeCTag(t)) ->
1693 Ast0.ast0_type_to_type t
1694 | Common.Left(_) ->
1695 failwith "iso pattern: unexpected type"
1696 | Common.Right(new_mv) ->
1697 Type_cocci.MetaType(new_mv,keep,inherited))
1698 | Type_cocci.ConstVol(cv,ty) ->
1699 Type_cocci.ConstVol(cv,renamer ty)
1700 | Type_cocci.Pointer(ty) ->
1701 Type_cocci.Pointer(renamer ty)
1702 | Type_cocci.FunctionPointer(ty) ->
1703 Type_cocci.FunctionPointer(renamer ty)
1704 | Type_cocci.Array(ty) ->
1705 Type_cocci.Array(renamer ty)
1706 | t -> t in
1707 Some(List.map renamer types) in
1708 Ast0.rewrap e
1709 (Ast0.MetaExpr
1710 (Ast0.set_mcode_data new_mv name,constraints,
1711 new_types,form,pure)))
1712 | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
1713 | Ast0.MetaExprList(namea,lenname,pure) ->
1714 failwith "metaexprlist not supported"
1715 | Ast0.Unary(exp,unop) ->
1716 (match Ast0.unwrap_mcode unop with
1717 (* propagate negation only when the propagated and the encountered
1718 negation have the same transformation, when there is nothing
1719 added to the original one, and when there is nothing added to
1720 the expression into which we are doing the propagation. This
1721 may be too conservative. *)
1722 Ast.Not ->
1723 let was_meta =
1724 (* k e doesn't change the outer structure of the term,
1725 only the metavars *)
1726 match Ast0.unwrap old_e with
1727 Ast0.Unary(exp,_) ->
1728 (match Ast0.unwrap exp with
1729 Ast0.MetaExpr(name,constraints,x,form,pure) -> true
1730 | _ -> false)
1731 | _ -> failwith "not possible" in
1732 let nomodif = function
1733 Ast0.MINUS(x) ->
1734 (match !x with
1735 (Ast.NOREPLACEMENT,_) -> true
1736 | _ -> false)
1737 | Ast0.CONTEXT(x) | Ast0.MIXED(x) ->
1738 (match !x with
1739 (Ast.NOTHING,_,_) -> true
1740 | _ -> false)
1741 | _ -> failwith "plus not possible" in
1742 let same_modif newop oldop =
1743 (* only propagate ! is they have the same modification
1744 and no + code on the old one (the new one from the iso
1745 surely has no + code) *)
1746 match (newop,oldop) with
1747 (Ast0.MINUS(x1),Ast0.MINUS(x2)) -> nomodif oldop
1748 | (Ast0.CONTEXT(x1),Ast0.CONTEXT(x2)) -> nomodif oldop
1749 | (Ast0.MIXED(x1),Ast0.MIXED(x2)) -> nomodif oldop
1750 | _ -> false in
1751 if was_meta
1752 then
1753 let idcont x = x in
1754 let rec negate e (*for rewrapping*) res (*code to process*) k =
1755 (* k accumulates parens, to keep negation outside if no
1756 propagation is possible *)
1757 if nomodif (Ast0.get_mcodekind e)
1758 then
1759 match Ast0.unwrap res with
1760 Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not &&
1761 same_modif
1762 (Ast0.get_mcode_mcodekind unop)
1763 (Ast0.get_mcode_mcodekind op) ->
1764 k e1
1765 | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res))
1766 | Ast0.Paren(lp,e1,rp) ->
1767 negate e e1
1768 (function x ->
1769 k (Ast0.rewrap res (Ast0.Paren(lp,x,rp))))
1770 | Ast0.Binary(e1,op,e2) when
1771 same_modif
1772 (Ast0.get_mcode_mcodekind unop)
1773 (Ast0.get_mcode_mcodekind op) ->
1774 let reb nop =
1775 Ast0.rewrap_mcode op (Ast.Logical(nop)) in
1776 let k1 x = k (Ast0.rewrap e x) in
1777 (match Ast0.unwrap_mcode op with
1778 Ast.Logical(Ast.Inf) ->
1779 k1 (Ast0.Binary(e1,reb Ast.SupEq,e2))
1780 | Ast.Logical(Ast.Sup) ->
1781 k1 (Ast0.Binary(e1,reb Ast.InfEq,e2))
1782 | Ast.Logical(Ast.InfEq) ->
1783 k1 (Ast0.Binary(e1,reb Ast.Sup,e2))
1784 | Ast.Logical(Ast.SupEq) ->
1785 k1 (Ast0.Binary(e1,reb Ast.Inf,e2))
1786 | Ast.Logical(Ast.Eq) ->
1787 k1 (Ast0.Binary(e1,reb Ast.NotEq,e2))
1788 | Ast.Logical(Ast.NotEq) ->
1789 k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
1790 | Ast.Logical(Ast.AndLog) ->
1791 k1 (Ast0.Binary(negate_reb e e1 idcont,
1792 reb Ast.OrLog,
1793 negate_reb e e2 idcont))
1794 | Ast.Logical(Ast.OrLog) ->
1795 k1 (Ast0.Binary(negate_reb e e1 idcont,
1796 reb Ast.AndLog,
1797 negate_reb e e2 idcont))
1798 | _ ->
1799 Ast0.rewrap e
1800 (Ast0.Unary(k res,
1801 Ast0.rewrap_mcode op Ast.Not)))
1802 | Ast0.DisjExpr(lp,exps,mids,rp) ->
1803 (* use res because it is the transformed argument *)
1804 let exps =
1805 List.map (function e1 -> negate_reb e e1 k) exps in
1806 Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
1807 | _ ->
1808 (*use e, because this might be the toplevel expression*)
1809 Ast0.rewrap e
1810 (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not))
1811 else
1812 Ast0.rewrap e
1813 (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not))
1814 and negate_reb e e1 k =
1815 (* used when ! is propagated to multiple places, to avoid
1816 duplicating mcode cells *)
1817 let start_line =
1818 Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
1819 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1820 (negate e e1 k) in
1821 negate e exp idcont
1822 else e
1823 | _ -> e)
1824 | Ast0.Edots(d,_) ->
1825 (try
1826 (match List.assoc (dot_term d) bindings with
1827 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Edots(d,Some exp))
1828 | _ -> failwith "unexpected binding")
1829 with Not_found -> e)
1830 | Ast0.Ecircles(d,_) ->
1831 (try
1832 (match List.assoc (dot_term d) bindings with
1833 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Ecircles(d,Some exp))
1834 | _ -> failwith "unexpected binding")
1835 with Not_found -> e)
1836 | Ast0.Estars(d,_) ->
1837 (try
1838 (match List.assoc (dot_term d) bindings with
1839 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Estars(d,Some exp))
1840 | _ -> failwith "unexpected binding")
1841 with Not_found -> e)
1842 | _ -> e in
1843 if Ast0.get_test_exp old_e then Ast0.set_test_exp e1 else e1 in
1844
1845 let tyfn r k e =
1846 let e = k e in
1847 match Ast0.unwrap e with
1848 Ast0.MetaType(name,pure) ->
1849 (rebuild_mcode None).VT0.rebuilder_rec_typeC
1850 (match lookup name bindings mv_bindings with
1851 Common.Left(Ast0.TypeCTag(ty)) -> ty
1852 | Common.Left(_) -> failwith "not possible 1"
1853 | Common.Right(new_mv) ->
1854 Ast0.rewrap e
1855 (Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure)))
1856 | _ -> e in
1857
1858 let initfn r k e =
1859 let e = k e in
1860 match Ast0.unwrap e with
1861 Ast0.MetaInit(name,pure) ->
1862 (rebuild_mcode None).VT0.rebuilder_rec_initialiser
1863 (match lookup name bindings mv_bindings with
1864 Common.Left(Ast0.InitTag(ty)) -> ty
1865 | Common.Left(_) -> failwith "not possible 1"
1866 | Common.Right(new_mv) ->
1867 Ast0.rewrap e
1868 (Ast0.MetaInit(Ast0.set_mcode_data new_mv name,pure)))
1869 | _ -> e in
1870
1871 let declfn r k e =
1872 let e = k e in
1873 match Ast0.unwrap e with
1874 Ast0.MetaDecl(name,pure) ->
1875 (rebuild_mcode None).VT0.rebuilder_rec_declaration
1876 (match lookup name bindings mv_bindings with
1877 Common.Left(Ast0.DeclTag(d)) -> d
1878 | Common.Left(_) -> failwith "not possible 1"
1879 | Common.Right(new_mv) ->
1880 Ast0.rewrap e
1881 (Ast0.MetaDecl(Ast0.set_mcode_data new_mv name, pure)))
1882 | Ast0.MetaField(name,pure) ->
1883 (rebuild_mcode None).VT0.rebuilder_rec_declaration
1884 (match lookup name bindings mv_bindings with
1885 Common.Left(Ast0.DeclTag(d)) -> d
1886 | Common.Left(_) -> failwith "not possible 1"
1887 | Common.Right(new_mv) ->
1888 Ast0.rewrap e
1889 (Ast0.MetaField(Ast0.set_mcode_data new_mv name, pure)))
1890 | Ast0.MetaFieldList(name,lenname,pure) ->
1891 failwith "metafieldlist not supported"
1892 | Ast0.Ddots(d,_) ->
1893 (try
1894 (match List.assoc (dot_term d) bindings with
1895 Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp))
1896 | _ -> failwith "unexpected binding")
1897 with Not_found -> e)
1898 | _ -> e in
1899
1900 let paramfn r k e =
1901 let e = k e in
1902 match Ast0.unwrap e with
1903 Ast0.MetaParam(name,pure) ->
1904 (rebuild_mcode None).VT0.rebuilder_rec_parameter
1905 (match lookup name bindings mv_bindings with
1906 Common.Left(Ast0.ParamTag(param)) -> param
1907 | Common.Left(_) -> failwith "not possible 1"
1908 | Common.Right(new_mv) ->
1909 Ast0.rewrap e
1910 (Ast0.MetaParam(Ast0.set_mcode_data new_mv name, pure)))
1911 | Ast0.MetaParamList(name,lenname,pure) ->
1912 failwith "metaparamlist not supported"
1913 | _ -> e in
1914
1915 let whenfn (_,v) =
1916 match v with
1917 Ast0.DotsStmtTag(stms) -> Ast0.WhenNot stms
1918 | Ast0.StmtTag(stm) -> Ast0.WhenAlways stm
1919 | Ast0.IsoWhenTTag(stm) -> Ast0.WhenNotTrue stm
1920 | Ast0.IsoWhenFTag(stm) -> Ast0.WhenNotFalse stm
1921 | Ast0.IsoWhenTag(x) -> Ast0.WhenModifier(x)
1922 | _ -> failwith "unexpected binding" in
1923
1924 let stmtfn r k e =
1925 let e = k e in
1926 match Ast0.unwrap e with
1927 Ast0.MetaStmt(name,pure) ->
1928 (rebuild_mcode None).VT0.rebuilder_rec_statement
1929 (match lookup name bindings mv_bindings with
1930 Common.Left(Ast0.StmtTag(stm)) -> stm
1931 | Common.Left(_) -> failwith "not possible 1"
1932 | Common.Right(new_mv) ->
1933 Ast0.rewrap e
1934 (Ast0.MetaStmt(Ast0.set_mcode_data new_mv name,pure)))
1935 | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
1936 | Ast0.Dots(d,_) ->
1937 Ast0.rewrap e
1938 (Ast0.Dots
1939 (d,
1940 List.map whenfn
1941 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1942 | Ast0.Circles(d,_) ->
1943 Ast0.rewrap e
1944 (Ast0.Circles
1945 (d,
1946 List.map whenfn
1947 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1948 | Ast0.Stars(d,_) ->
1949 Ast0.rewrap e
1950 (Ast0.Stars
1951 (d,
1952 List.map whenfn
1953 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1954 | _ -> e in
1955
1956 V0.flat_rebuilder
1957 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1958 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1959 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1960 donothing
1961
1962 (* --------------------------------------------------------------------- *)
1963
1964 let is_minus e =
1965 match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
1966
1967 let context_required e = not(is_minus e) && not !Flag.sgrep_mode2
1968
1969 let disj_fail bindings e =
1970 match bindings with
1971 Some x -> Printf.fprintf stderr "no disj available at this type"; e
1972 | None -> e
1973
1974 (* isomorphism code is by default CONTEXT *)
1975 let merge_plus model_mcode e_mcode =
1976 match model_mcode with
1977 Ast0.MINUS(mc) ->
1978 (* add the replacement information at the root *)
1979 (match e_mcode with
1980 Ast0.MINUS(emc) ->
1981 emc :=
1982 (match (!mc,!emc) with
1983 ((Ast.NOREPLACEMENT,_),(x,t))
1984 | ((x,_),(Ast.NOREPLACEMENT,t)) -> (x,t)
1985 | _ -> failwith "how can we combine minuses?")
1986 | _ -> failwith "not possible 6")
1987 | Ast0.CONTEXT(mc) ->
1988 (match e_mcode with
1989 Ast0.CONTEXT(emc) ->
1990 (* keep the logical line info as in the model *)
1991 let (mba,tb,ta) = !mc in
1992 let (eba,_,_) = !emc in
1993 (* merging may be required when a term is replaced by a subterm *)
1994 let merged =
1995 match (mba,eba) with
1996 (x,Ast.NOTHING) | (Ast.NOTHING,x) -> x
1997 | (Ast.BEFORE(b1,it1),Ast.BEFORE(b2,it2)) ->
1998 Ast.BEFORE(b1@b2,Ast.lub_count it1 it2)
1999 | (Ast.BEFORE(b,it1),Ast.AFTER(a,it2)) ->
2000 Ast.BEFOREAFTER(b,a,Ast.lub_count it1 it2)
2001 | (Ast.BEFORE(b1,it1),Ast.BEFOREAFTER(b2,a,it2)) ->
2002 Ast.BEFOREAFTER(b1@b2,a,Ast.lub_count it1 it2)
2003 | (Ast.AFTER(a,it1),Ast.BEFORE(b,it2)) ->
2004 Ast.BEFOREAFTER(b,a,Ast.lub_count it1 it2)
2005 | (Ast.AFTER(a1,it1),Ast.AFTER(a2,it2)) ->
2006 Ast.AFTER(a2@a1,Ast.lub_count it1 it2)
2007 | (Ast.AFTER(a1,it1),Ast.BEFOREAFTER(b,a2,it2)) ->
2008 Ast.BEFOREAFTER(b,a2@a1,Ast.lub_count it1 it2)
2009 | (Ast.BEFOREAFTER(b1,a,it1),Ast.BEFORE(b2,it2)) ->
2010 Ast.BEFOREAFTER(b1@b2,a,Ast.lub_count it1 it2)
2011 | (Ast.BEFOREAFTER(b,a1,it1),Ast.AFTER(a2,it2)) ->
2012 Ast.BEFOREAFTER(b,a2@a1,Ast.lub_count it1 it2)
2013 | (Ast.BEFOREAFTER(b1,a1,it1),Ast.BEFOREAFTER(b2,a2,it2)) ->
2014 Ast.BEFOREAFTER(b1@b2,a2@a1,Ast.lub_count it1 it2) in
2015 emc := (merged,tb,ta)
2016 | Ast0.MINUS(emc) ->
2017 let (anything_bef_aft,_,_) = !mc in
2018 let (anythings,t) = !emc in
2019 (match (anything_bef_aft,anythings) with
2020 (Ast.BEFORE(b1,it1),Ast.NOREPLACEMENT) ->
2021 emc := (Ast.REPLACEMENT(b1,it1),t)
2022 | (Ast.AFTER(a1,it1),Ast.NOREPLACEMENT) ->
2023 emc := (Ast.REPLACEMENT(a1,it1),t)
2024 | (Ast.BEFOREAFTER(b1,a1,it1),Ast.NOREPLACEMENT) ->
2025 emc := (Ast.REPLACEMENT(b1@a1,it1),t)
2026 | (Ast.NOTHING,Ast.NOREPLACEMENT) ->
2027 emc := (Ast.NOREPLACEMENT,t)
2028 | (Ast.BEFORE(b1,it1),Ast.REPLACEMENT(a2,it2)) ->
2029 emc := (Ast.REPLACEMENT(b1@a2,Ast.lub_count it1 it2),t)
2030 | (Ast.AFTER(a1,it1),Ast.REPLACEMENT(a2,it2)) ->
2031 emc := (Ast.REPLACEMENT(a2@a1,Ast.lub_count it1 it2),t)
2032 | (Ast.BEFOREAFTER(b1,a1,it1),Ast.REPLACEMENT(a2,it2)) ->
2033 emc := (Ast.REPLACEMENT(b1@a2@a1,Ast.lub_count it1 it2),t)
2034 | (Ast.NOTHING,Ast.REPLACEMENT(a2,it2)) -> ()) (* no change *)
2035 | Ast0.MIXED(_) -> failwith "how did this become mixed?"
2036 | _ -> failwith "not possible 7")
2037 | Ast0.MIXED(_) -> failwith "not possible 8"
2038 | Ast0.PLUS _ -> failwith "not possible 9"
2039
2040 let copy_plus printer minusify model e =
2041 if !Flag.sgrep_mode2
2042 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
2043 else
2044 begin
2045 let e =
2046 match Ast0.get_mcodekind model with
2047 Ast0.MINUS(mc) -> minusify e
2048 | Ast0.CONTEXT(mc) -> e
2049 | _ -> failwith "not possible: copy_plus\n" in
2050 merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
2051 e
2052 end
2053
2054 let copy_minus printer minusify model e =
2055 match Ast0.get_mcodekind model with
2056 Ast0.MINUS(mc) -> minusify e
2057 | Ast0.CONTEXT(mc) -> e
2058 | Ast0.MIXED(_) ->
2059 if !Flag.sgrep_mode2
2060 then e
2061 else failwith "not possible 8"
2062 | Ast0.PLUS _ -> failwith "not possible 9"
2063
2064 let whencode_allowed prev_ecount prev_icount prev_dcount
2065 ecount icount dcount rest =
2066 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
2067 won't be tested *)
2068 let other_ecount = (* number of edots *)
2069 List.fold_left (function rest -> function (_,ec,ic,dc) -> ec + rest)
2070 prev_ecount rest in
2071 let other_icount = (* number of dots *)
2072 List.fold_left (function rest -> function (_,ec,ic,dc) -> ic + rest)
2073 prev_icount rest in
2074 let other_dcount = (* number of dots *)
2075 List.fold_left (function rest -> function (_,ec,ic,dc) -> dc + rest)
2076 prev_dcount rest in
2077 (ecount = 0 or other_ecount = 0, icount = 0 or other_icount = 0,
2078 dcount = 0 or other_dcount = 0)
2079
2080 (* copy the befores and afters to the instantiated code *)
2081 let extra_copy_stmt_plus model e =
2082 (if not !Flag.sgrep_mode2 (* sgrep has no plus code, so nothing to do *)
2083 then
2084 (match Ast0.unwrap model with
2085 Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
2086 | Ast0.Decl((info,bef),_) ->
2087 (match Ast0.unwrap e with
2088 Ast0.FunDecl((info,bef1),_,_,_,_,_,_,_,_)
2089 | Ast0.Decl((info,bef1),_) ->
2090 merge_plus bef bef1
2091 | _ -> merge_plus bef (Ast0.get_mcodekind e))
2092 | Ast0.IfThen(_,_,_,_,_,(info,aft))
2093 | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
2094 | Ast0.While(_,_,_,_,_,(info,aft))
2095 | Ast0.For(_,_,_,_,_,_,_,_,(info,aft))
2096 | Ast0.Iterator(_,_,_,_,_,(info,aft)) ->
2097 (match Ast0.unwrap e with
2098 Ast0.IfThen(_,_,_,_,_,(info,aft1))
2099 | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft1))
2100 | Ast0.While(_,_,_,_,_,(info,aft1))
2101 | Ast0.For(_,_,_,_,_,_,_,_,(info,aft1))
2102 | Ast0.Iterator(_,_,_,_,_,(info,aft1)) ->
2103 merge_plus aft aft1
2104 | _ -> merge_plus aft (Ast0.get_mcodekind e))
2105 | _ -> ()));
2106 e
2107
2108 let extra_copy_other_plus model e = e
2109
2110 (* --------------------------------------------------------------------- *)
2111
2112 let mv_count = ref 0
2113 let new_mv (_,s) =
2114 let ct = !mv_count in
2115 mv_count := !mv_count + 1;
2116 "_"^s^"_"^(string_of_int ct)
2117
2118 let get_name = function
2119 Ast.MetaMetaDecl(ar,nm) ->
2120 (nm,function nm -> Ast.MetaMetaDecl(ar,nm))
2121 | Ast.MetaIdDecl(ar,nm) ->
2122 (nm,function nm -> Ast.MetaIdDecl(ar,nm))
2123 | Ast.MetaFreshIdDecl(nm,seed) ->
2124 (nm,function nm -> Ast.MetaFreshIdDecl(nm,seed))
2125 | Ast.MetaTypeDecl(ar,nm) ->
2126 (nm,function nm -> Ast.MetaTypeDecl(ar,nm))
2127 | Ast.MetaInitDecl(ar,nm) ->
2128 (nm,function nm -> Ast.MetaInitDecl(ar,nm))
2129 | Ast.MetaInitListDecl(ar,nm,nm1) ->
2130 (nm,function nm -> Ast.MetaInitListDecl(ar,nm,nm1))
2131 | Ast.MetaListlenDecl(nm) ->
2132 failwith "should not be rebuilt"
2133 | Ast.MetaParamDecl(ar,nm) ->
2134 (nm,function nm -> Ast.MetaParamDecl(ar,nm))
2135 | Ast.MetaParamListDecl(ar,nm,nm1) ->
2136 (nm,function nm -> Ast.MetaParamListDecl(ar,nm,nm1))
2137 | Ast.MetaConstDecl(ar,nm,ty) ->
2138 (nm,function nm -> Ast.MetaConstDecl(ar,nm,ty))
2139 | Ast.MetaErrDecl(ar,nm) ->
2140 (nm,function nm -> Ast.MetaErrDecl(ar,nm))
2141 | Ast.MetaExpDecl(ar,nm,ty) ->
2142 (nm,function nm -> Ast.MetaExpDecl(ar,nm,ty))
2143 | Ast.MetaIdExpDecl(ar,nm,ty) ->
2144 (nm,function nm -> Ast.MetaIdExpDecl(ar,nm,ty))
2145 | Ast.MetaLocalIdExpDecl(ar,nm,ty) ->
2146 (nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty))
2147 | Ast.MetaExpListDecl(ar,nm,nm1) ->
2148 (nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1))
2149 | Ast.MetaDeclDecl(ar,nm) ->
2150 (nm,function nm -> Ast.MetaDeclDecl(ar,nm))
2151 | Ast.MetaFieldListDecl(ar,nm,nm1) ->
2152 (nm,function nm -> Ast.MetaFieldListDecl(ar,nm,nm1))
2153 | Ast.MetaFieldDecl(ar,nm) ->
2154 (nm,function nm -> Ast.MetaFieldDecl(ar,nm))
2155 | Ast.MetaStmDecl(ar,nm) ->
2156 (nm,function nm -> Ast.MetaStmDecl(ar,nm))
2157 | Ast.MetaStmListDecl(ar,nm) ->
2158 (nm,function nm -> Ast.MetaStmListDecl(ar,nm))
2159 | Ast.MetaFuncDecl(ar,nm) ->
2160 (nm,function nm -> Ast.MetaFuncDecl(ar,nm))
2161 | Ast.MetaLocalFuncDecl(ar,nm) ->
2162 (nm,function nm -> Ast.MetaLocalFuncDecl(ar,nm))
2163 | Ast.MetaPosDecl(ar,nm) ->
2164 (nm,function nm -> Ast.MetaPosDecl(ar,nm))
2165 | Ast.MetaDeclarerDecl(ar,nm) ->
2166 (nm,function nm -> Ast.MetaDeclarerDecl(ar,nm))
2167 | Ast.MetaIteratorDecl(ar,nm) ->
2168 (nm,function nm -> Ast.MetaIteratorDecl(ar,nm))
2169
2170 let make_new_metavars metavars bindings =
2171 let new_metavars =
2172 List.filter
2173 (function mv ->
2174 let (s,_) = get_name mv in
2175 try let _ = List.assoc s bindings in false with Not_found -> true)
2176 metavars in
2177 List.split
2178 (List.map
2179 (function mv ->
2180 let (s,rebuild) = get_name mv in
2181 let new_s = (!current_rule,new_mv s) in
2182 (rebuild new_s, (s,new_s)))
2183 new_metavars)
2184
2185 (* --------------------------------------------------------------------- *)
2186
2187 let do_nothing x = x
2188
2189 let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify
2190 rebuild_mcodes name printer extra_plus update_others has_context =
2191 let call_instantiate bindings mv_bindings alts pattern has_context =
2192 List.concat
2193 (List.map
2194 (function (a,_,_,_) ->
2195 nub
2196 (* no need to create duplicates when the bindings have no effect *)
2197 (List.map
2198 (function bindings ->
2199 let instantiated =
2200 instantiater bindings mv_bindings (rebuild_mcodes a) in
2201 let plus_added =
2202 if has_context (* ie if pat is not just a metavara *)
2203 then
2204 copy_plus printer minusify e (extra_plus e instantiated)
2205 else instantiated in
2206 if pattern = a
2207 then plus_added
2208 else (* iso tracking *)
2209 Ast0.set_iso plus_added
2210 ((name,mkiso a)::(Ast0.get_iso e))) (* keep count, not U *)
2211 bindings))
2212 alts) in
2213 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function
2214 [] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
2215 | ((pattern,ecount,icount,dcount)::rest) ->
2216 let wc =
2217 whencode_allowed prev_ecount prev_icount prev_dcount
2218 ecount dcount icount rest in
2219 (match matcher true (context_required e) wc pattern e init_env with
2220 Fail(reason) ->
2221 if reason = NonMatch || not !Flag_parsing_cocci.show_iso_failures
2222 then ()
2223 else
2224 (match matcher false false wc pattern e init_env with
2225 OK _ ->
2226 interpret_reason name (Ast0.get_line e) reason
2227 (function () -> printer e)
2228 | _ -> ());
2229 inner_loop all_alts (prev_ecount + ecount) (prev_icount + icount)
2230 (prev_dcount + dcount) rest
2231 | OK (bindings : ((Ast.meta_name * 'a) list list)) ->
2232 let all_alts =
2233 (* apply update_others to all patterns other than the matched
2234 one. This is used to desigate the others as test
2235 expressions in the TestExpression case *)
2236 (List.map
2237 (function (x,e,i,d) as all ->
2238 if x = pattern
2239 then all
2240 else (update_others x,e,i,d))
2241 (List.hd all_alts)) ::
2242 (List.map
2243 (List.map (function (x,e,i,d) -> (update_others x,e,i,d)))
2244 (List.tl all_alts)) in
2245 (match List.concat all_alts with
2246 [x] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
2247 | all_alts ->
2248 let (new_metavars,mv_bindings) =
2249 make_new_metavars metavars (nub(List.concat bindings)) in
2250 Common.Right
2251 (new_metavars,
2252 call_instantiate bindings mv_bindings all_alts pattern
2253 (has_context pattern)))) in
2254 let rec outer_loop prev_ecount prev_icount prev_dcount = function
2255 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2256 | (alts::rest) as all_alts ->
2257 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with
2258 Common.Left(prev_ecount, prev_icount, prev_dcount) ->
2259 outer_loop prev_ecount prev_icount prev_dcount rest
2260 | Common.Right (new_metavars,res) ->
2261 (1,new_metavars,
2262 copy_minus printer minusify e (disj_maker res)) in
2263 let (count,metavars,e) = outer_loop 0 0 0 alts in
2264 (count, metavars, e)
2265
2266 (* no one should ever look at the information stored in these mcodes *)
2267 let disj_starter lst =
2268 let old_info = Ast0.get_info(List.hd lst) in
2269 let new_pos_info =
2270 { old_info.Ast0.pos_info with
2271 Ast0.line_end = old_info.Ast0.pos_info.Ast0.line_start;
2272 Ast0.logical_end = old_info.Ast0.pos_info.Ast0.logical_start; } in
2273 let info =
2274 { Ast0.pos_info = new_pos_info;
2275 Ast0.attachable_start = false; Ast0.attachable_end = false;
2276 Ast0.mcode_start = []; Ast0.mcode_end = [];
2277 Ast0.strings_before = []; Ast0.strings_after = [];
2278 Ast0.isSymbolIdent = false; } in
2279 Ast0.make_mcode_info "(" info
2280
2281 let disj_ender lst =
2282 let old_info = Ast0.get_info(List.hd lst) in
2283 let new_pos_info =
2284 { old_info.Ast0.pos_info with
2285 Ast0.line_start = old_info.Ast0.pos_info.Ast0.line_end;
2286 Ast0.logical_start = old_info.Ast0.pos_info.Ast0.logical_end; } in
2287 let info =
2288 { Ast0.pos_info = new_pos_info;
2289 Ast0.attachable_start = false; Ast0.attachable_end = false;
2290 Ast0.mcode_start = []; Ast0.mcode_end = [];
2291 Ast0.strings_before = []; Ast0.strings_after = [];
2292 Ast0.isSymbolIdent = false; } in
2293 Ast0.make_mcode_info ")" info
2294
2295 let disj_mid _ = Ast0.make_mcode "|"
2296
2297 let make_disj_type tl =
2298 let mids =
2299 match tl with
2300 [] -> failwith "bad disjunction"
2301 | x::xs -> List.map disj_mid xs in
2302 Ast0.context_wrap (Ast0.DisjType(disj_starter tl,tl,mids,disj_ender tl))
2303 let make_disj_stmt_list tl =
2304 let mids =
2305 match tl with
2306 [] -> failwith "bad disjunction"
2307 | x::xs -> List.map disj_mid xs in
2308 Ast0.context_wrap (Ast0.Disj(disj_starter tl,tl,mids,disj_ender tl))
2309 let make_disj_expr model el =
2310 let mids =
2311 match el with
2312 [] -> failwith "bad disjunction"
2313 | x::xs -> List.map disj_mid xs in
2314 let update_arg x =
2315 if Ast0.get_arg_exp model then Ast0.set_arg_exp x else x in
2316 let update_test x =
2317 let x = if Ast0.get_test_pos model then Ast0.set_test_pos x else x in
2318 if Ast0.get_test_exp model then Ast0.set_test_exp x else x in
2319 let el = List.map update_arg (List.map update_test el) in
2320 Ast0.context_wrap (Ast0.DisjExpr(disj_starter el,el,mids,disj_ender el))
2321 let make_disj_decl dl =
2322 let mids =
2323 match dl with
2324 [] -> failwith "bad disjunction"
2325 | x::xs -> List.map disj_mid xs in
2326 Ast0.context_wrap (Ast0.DisjDecl(disj_starter dl,dl,mids,disj_ender dl))
2327 let make_disj_stmt sl =
2328 let dotify x = Ast0.context_wrap (Ast0.DOTS[x]) in
2329 let mids =
2330 match sl with
2331 [] -> failwith "bad disjunction"
2332 | x::xs -> List.map disj_mid xs in
2333 Ast0.context_wrap
2334 (Ast0.Disj(disj_starter sl,List.map dotify sl,mids,disj_ender sl))
2335
2336 let transform_type (metavars,alts,name) e =
2337 match alts with
2338 (Ast0.TypeCTag(_)::_)::_ ->
2339 (* start line is given to any leaves in the iso code *)
2340 let start_line =
2341 Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
2342 let alts =
2343 List.map
2344 (List.map
2345 (function
2346 Ast0.TypeCTag(p) ->
2347 (p,count_edots.VT0.combiner_rec_typeC p,
2348 count_idots.VT0.combiner_rec_typeC p,
2349 count_dots.VT0.combiner_rec_typeC p)
2350 | _ -> failwith "invalid alt"))
2351 alts in
2352 mkdisj match_typeC metavars alts e
2353 (function b -> function mv_b ->
2354 (instantiate b mv_b).VT0.rebuilder_rec_typeC)
2355 (function t -> Ast0.TypeCTag t)
2356 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2357 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2358 name Unparse_ast0.typeC extra_copy_other_plus do_nothing
2359 (function x ->
2360 match Ast0.unwrap x with Ast0.MetaType _ -> false | _ -> true)
2361 | _ -> (0,[],e)
2362
2363
2364 let transform_expr (metavars,alts,name) e =
2365 let process update_others =
2366 (* start line is given to any leaves in the iso code *)
2367 let start_line =
2368 Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
2369 let alts =
2370 List.map
2371 (List.map
2372 (function
2373 Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) ->
2374 (p,count_edots.VT0.combiner_rec_expression p,
2375 count_idots.VT0.combiner_rec_expression p,
2376 count_dots.VT0.combiner_rec_expression p)
2377 | _ -> failwith "invalid alt"))
2378 alts in
2379 mkdisj match_expr metavars alts e
2380 (function b -> function mv_b ->
2381 (instantiate b mv_b).VT0.rebuilder_rec_expression)
2382 (function e -> Ast0.ExprTag e)
2383 (make_disj_expr e)
2384 make_minus.VT0.rebuilder_rec_expression
2385 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2386 name Unparse_ast0.expression extra_copy_other_plus update_others
2387 (function x ->
2388 match Ast0.unwrap x with
2389 Ast0.MetaExpr _ | Ast0.MetaExprList _ | Ast0.MetaErr _ -> false
2390 | _ -> true)
2391 in
2392 match alts with
2393 (Ast0.ExprTag(_)::r)::rs ->
2394 (* hack to accomodate ToTestExpression case, where the first pattern is
2395 a normal expression, but the others are test expressions *)
2396 let others = r @ (List.concat rs) in
2397 let is_test = function Ast0.TestExprTag(_) -> true | _ -> false in
2398 if List.for_all is_test others then process Ast0.set_test_exp
2399 else if List.exists is_test others then failwith "inconsistent iso"
2400 else process do_nothing
2401 | (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing
2402 | (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e ->
2403 process Ast0.set_test_exp
2404 | _ -> (0,[],e)
2405
2406 let transform_decl (metavars,alts,name) e =
2407 match alts with
2408 (Ast0.DeclTag(_)::_)::_ ->
2409 (* start line is given to any leaves in the iso code *)
2410 let start_line =
2411 Some (Ast0.get_info e).Ast0.pos_info.Ast0.line_start in
2412 let alts =
2413 List.map
2414 (List.map
2415 (function
2416 Ast0.DeclTag(p) ->
2417 (p,count_edots.VT0.combiner_rec_declaration p,
2418 count_idots.VT0.combiner_rec_declaration p,
2419 count_dots.VT0.combiner_rec_declaration p)
2420 | _ -> failwith "invalid alt"))
2421 alts in
2422 mkdisj match_decl metavars alts e
2423 (function b -> function mv_b ->
2424 (instantiate b mv_b).VT0.rebuilder_rec_declaration)
2425 (function d -> Ast0.DeclTag d)
2426 make_disj_decl
2427 make_minus.VT0.rebuilder_rec_declaration
2428 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2429 name Unparse_ast0.declaration extra_copy_other_plus do_nothing
2430 (function _ -> true (* no metavars *))
2431 | _ -> (0,[],e)
2432
2433 let transform_stmt (metavars,alts,name) e =
2434 match alts with
2435 (Ast0.StmtTag(_)::_)::_ ->
2436 (* start line is given to any leaves in the iso code *)
2437 let start_line =
2438 Some (Ast0.get_info e).Ast0.pos_info.Ast0.line_start in
2439 let alts =
2440 List.map
2441 (List.map
2442 (function
2443 Ast0.StmtTag(p) ->
2444 (p,count_edots.VT0.combiner_rec_statement p,
2445 count_idots.VT0.combiner_rec_statement p,
2446 count_dots.VT0.combiner_rec_statement p)
2447 | _ -> failwith "invalid alt"))
2448 alts in
2449 mkdisj match_statement metavars alts e
2450 (function b -> function mv_b ->
2451 (instantiate b mv_b).VT0.rebuilder_rec_statement)
2452 (function s -> Ast0.StmtTag s)
2453 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2454 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2455 name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2456 (function x ->
2457 match Ast0.unwrap x with
2458 Ast0.MetaStmt _ | Ast0.MetaStmtList _ -> false
2459 | _ -> true)
2460 | _ -> (0,[],e)
2461
2462 (* sort of a hack, because there is no disj at top level *)
2463 let transform_top (metavars,alts,name) e =
2464 match Ast0.unwrap e with
2465 Ast0.NONDECL(declstm) ->
2466 (try
2467 let strip alts =
2468 List.map
2469 (List.map
2470 (function
2471 Ast0.DotsStmtTag(d) ->
2472 (match Ast0.unwrap d with
2473 Ast0.DOTS([s]) -> Ast0.StmtTag(s)
2474 | _ -> raise (Failure ""))
2475 | _ -> raise (Failure "")))
2476 alts in
2477 let (count,mv,s) = transform_stmt (metavars,strip alts,name) declstm in
2478 (count,mv,Ast0.rewrap e (Ast0.NONDECL(s)))
2479 with Failure _ -> (0,[],e))
2480 | Ast0.CODE(stmts) ->
2481 let (count,mv,res) =
2482 match alts with
2483 (Ast0.DotsStmtTag(_)::_)::_ ->
2484 (* start line is given to any leaves in the iso code *)
2485 let start_line =
2486 Some ((Ast0.get_info e).Ast0.pos_info.Ast0.line_start) in
2487 let alts =
2488 List.map
2489 (List.map
2490 (function
2491 Ast0.DotsStmtTag(p) ->
2492 (p,count_edots.VT0.combiner_rec_statement_dots p,
2493 count_idots.VT0.combiner_rec_statement_dots p,
2494 count_dots.VT0.combiner_rec_statement_dots p)
2495 | _ -> failwith "invalid alt"))
2496 alts in
2497 mkdisj match_statement_dots metavars alts stmts
2498 (function b -> function mv_b ->
2499 (instantiate b mv_b).VT0.rebuilder_rec_statement_dots)
2500 (function s -> Ast0.DotsStmtTag s)
2501 (function x ->
2502 Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x])))
2503 (function x ->
2504 make_minus.VT0.rebuilder_rec_statement_dots x)
2505 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2506 name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing
2507 (function _ -> true)
2508 | _ -> (0,[],stmts) in
2509 (count,mv,Ast0.rewrap e (Ast0.CODE res))
2510 | _ -> (0,[],e)
2511
2512 (* --------------------------------------------------------------------- *)
2513
2514 let transform (alts : isomorphism) t =
2515 (* the following ugliness is because rebuilder only returns a new term *)
2516 let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in
2517 let in_limit n = function
2518 None -> true
2519 | Some n1 ->
2520 n < n1 or
2521 ((if !Flag_parsing_cocci.show_iso_failures
2522 then Common.pr2_once "execeeded iso threshold, see -iso_limit option");
2523 false) in
2524 let bind x y = x + y in
2525 let option_default = 0 in
2526 let exprfn r k e =
2527 let (e_count,e) = k e in
2528 if in_limit e_count !Flag_parsing_cocci.iso_limit
2529 then
2530 let (count,extra_meta,exp) = transform_expr alts e in
2531 extra_meta_decls := extra_meta @ !extra_meta_decls;
2532 (bind count e_count,exp)
2533 else (e_count,e) in
2534
2535 let declfn r k e =
2536 let (e_count,e) = k e in
2537 if in_limit e_count !Flag_parsing_cocci.iso_limit
2538 then
2539 let (count,extra_meta,dec) = transform_decl alts e in
2540 extra_meta_decls := extra_meta @ !extra_meta_decls;
2541 (bind count e_count,dec)
2542 else (e_count,e) in
2543
2544 let stmtfn r k e =
2545 let (e_count,e) = k e in
2546 if in_limit e_count !Flag_parsing_cocci.iso_limit
2547 then
2548 let (count,extra_meta,stm) = transform_stmt alts e in
2549 extra_meta_decls := extra_meta @ !extra_meta_decls;
2550 (bind count e_count,stm)
2551 else (e_count,e) in
2552
2553 let typefn r k e =
2554 let (continue,e_count,e) =
2555 match Ast0.unwrap e with
2556 Ast0.Signed(signb,tyb) ->
2557 (* Hack! How else to prevent iso from applying under an
2558 unsigned??? *)
2559 (true,0,e)
2560 | _ ->
2561 let (e_count,e) = k e in
2562 if in_limit e_count !Flag_parsing_cocci.iso_limit
2563 then (true,e_count,e)
2564 else (false,e_count,e) in
2565 if continue
2566 then
2567 let (count,extra_meta,ty) = transform_type alts e in
2568 extra_meta_decls := extra_meta @ !extra_meta_decls;
2569 (bind count e_count,ty)
2570 else (e_count,e) in
2571
2572 let topfn r k e =
2573 let (e_count,e) = k e in
2574 if in_limit e_count !Flag_parsing_cocci.iso_limit
2575 then
2576 let (count,extra_meta,ty) = transform_top alts e in
2577 extra_meta_decls := extra_meta @ !extra_meta_decls;
2578 (bind count e_count,ty)
2579 else (e_count,e) in
2580
2581 let res =
2582 V0.combiner_rebuilder bind option_default
2583 {V0.combiner_rebuilder_functions with
2584 VT0.combiner_rebuilder_exprfn = exprfn;
2585 VT0.combiner_rebuilder_tyfn = typefn;
2586 VT0.combiner_rebuilder_declfn = declfn;
2587 VT0.combiner_rebuilder_stmtfn = stmtfn;
2588 VT0.combiner_rebuilder_topfn = topfn} in
2589 let (_,res) = res.VT0.top_level t in
2590 (!extra_meta_decls,res)
2591
2592 (* --------------------------------------------------------------------- *)
2593
2594 (* should be done by functorizing the parser to use wrap or context_wrap *)
2595 let rewrap =
2596 let mcode (x,a,i,mc,pos,adj) = (x,a,i,Ast0.context_befaft(),pos,adj) in
2597 let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in
2598 V0.flat_rebuilder
2599 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2600 donothing donothing donothing donothing donothing donothing
2601 donothing donothing donothing donothing donothing donothing donothing
2602 donothing donothing donothing
2603
2604 let rewrap_anything = function
2605 Ast0.DotsExprTag(d) ->
2606 Ast0.DotsExprTag(rewrap.VT0.rebuilder_rec_expression_dots d)
2607 | Ast0.DotsInitTag(d) ->
2608 Ast0.DotsInitTag(rewrap.VT0.rebuilder_rec_initialiser_list d)
2609 | Ast0.DotsParamTag(d) ->
2610 Ast0.DotsParamTag(rewrap.VT0.rebuilder_rec_parameter_list d)
2611 | Ast0.DotsStmtTag(d) ->
2612 Ast0.DotsStmtTag(rewrap.VT0.rebuilder_rec_statement_dots d)
2613 | Ast0.DotsDeclTag(d) ->
2614 Ast0.DotsDeclTag(rewrap.VT0.rebuilder_rec_declaration_dots d)
2615 | Ast0.DotsCaseTag(d) ->
2616 Ast0.DotsCaseTag(rewrap.VT0.rebuilder_rec_case_line_dots d)
2617 | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.VT0.rebuilder_rec_ident d)
2618 | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.VT0.rebuilder_rec_expression d)
2619 | Ast0.ArgExprTag(d) ->
2620 Ast0.ArgExprTag(rewrap.VT0.rebuilder_rec_expression d)
2621 | Ast0.TestExprTag(d) ->
2622 Ast0.TestExprTag(rewrap.VT0.rebuilder_rec_expression d)
2623 | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.VT0.rebuilder_rec_typeC d)
2624 | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.VT0.rebuilder_rec_initialiser d)
2625 | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.VT0.rebuilder_rec_parameter d)
2626 | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.VT0.rebuilder_rec_declaration d)
2627 | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.VT0.rebuilder_rec_statement d)
2628 | Ast0.ForInfoTag(d) -> Ast0.ForInfoTag(rewrap.VT0.rebuilder_rec_forinfo d)
2629 | Ast0.CaseLineTag(d) ->
2630 Ast0.CaseLineTag(rewrap.VT0.rebuilder_rec_case_line d)
2631 | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.VT0.rebuilder_rec_top_level d)
2632 | Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
2633 failwith "only for isos within iso phase"
2634 | Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
2635 | Ast0.HiddenVarTag(p) -> Ast0.HiddenVarTag(p) (* not sure it is possible *)
2636
2637 (* --------------------------------------------------------------------- *)
2638
2639 let apply_isos isos rule rule_name =
2640 if isos = []
2641 then ([],rule)
2642 else
2643 begin
2644 current_rule := rule_name;
2645 let isos =
2646 List.map
2647 (function (metavars,iso,name) ->
2648 (metavars,List.map (List.map rewrap_anything) iso,name))
2649 isos in
2650 let (extra_meta,rule) =
2651 List.split
2652 (List.map
2653 (function t ->
2654 List.fold_left
2655 (function (extra_meta,t) -> function iso ->
2656 let (new_extra_meta,t) = transform iso t in
2657 (new_extra_meta@extra_meta,t))
2658 ([],t) isos)
2659 rule) in
2660 (List.concat extra_meta, (Compute_lines.compute_lines true) rule)
2661 end