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