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