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