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