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