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