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