2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
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.
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.
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/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
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. *)
29 (* --------------------------------------------------------------------- *)
30 (* match a SmPL expression against a SmPL abstract syntax tree,
33 module Ast = Ast_cocci
34 module Ast0 = Ast0_cocci
35 module V0 = Visitor_ast0
37 let current_rule = ref ""
39 (* --------------------------------------------------------------------- *)
42 Ast_cocci.metavar list * Ast0_cocci.anything list list * string (* name *)
45 let mcode (term,_,_,_,_) =
46 (term,Ast0.NONE,Ast0.default_info(),Ast0.PLUS,ref Ast0.NoMetaPos) 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
53 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
54 donothing donothing donothing donothing donothing donothing
55 donothing donothing donothing donothing donothing donothing donothing
58 let anything_equal = function
59 (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) ->
60 failwith "not a possible variable binding" (*not sure why these are pbs*)
61 | (Ast0.DotsInitTag(d1),Ast0.DotsInitTag(d2)) ->
62 failwith "not a possible variable binding"
63 | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
64 failwith "not a possible variable binding"
65 | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) ->
66 (strip_info.V0.rebuilder_statement_dots d1) =
67 (strip_info.V0.rebuilder_statement_dots d2)
68 | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) ->
69 failwith "not a possible variable binding"
70 | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) ->
71 failwith "not a possible variable binding"
72 | (Ast0.IdentTag(d1),Ast0.IdentTag(d2)) ->
73 (strip_info.V0.rebuilder_ident d1) = (strip_info.V0.rebuilder_ident d2)
74 | (Ast0.ExprTag(d1),Ast0.ExprTag(d2)) ->
75 (strip_info.V0.rebuilder_expression d1) =
76 (strip_info.V0.rebuilder_expression d2)
77 | (Ast0.ArgExprTag(_),_) | (_,Ast0.ArgExprTag(_)) ->
78 failwith "not possible - only in isos1"
79 | (Ast0.TestExprTag(_),_) | (_,Ast0.TestExprTag(_)) ->
80 failwith "not possible - only in isos1"
81 | (Ast0.TypeCTag(d1),Ast0.TypeCTag(d2)) ->
82 (strip_info.V0.rebuilder_typeC d1) =
83 (strip_info.V0.rebuilder_typeC d2)
84 | (Ast0.InitTag(d1),Ast0.InitTag(d2)) ->
85 (strip_info.V0.rebuilder_initialiser d1) =
86 (strip_info.V0.rebuilder_initialiser d2)
87 | (Ast0.ParamTag(d1),Ast0.ParamTag(d2)) ->
88 (strip_info.V0.rebuilder_parameter d1) =
89 (strip_info.V0.rebuilder_parameter d2)
90 | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) ->
91 (strip_info.V0.rebuilder_declaration d1) =
92 (strip_info.V0.rebuilder_declaration d2)
93 | (Ast0.StmtTag(d1),Ast0.StmtTag(d2)) ->
94 (strip_info.V0.rebuilder_statement d1) =
95 (strip_info.V0.rebuilder_statement d2)
96 | (Ast0.CaseLineTag(d1),Ast0.CaseLineTag(d2)) ->
97 (strip_info.V0.rebuilder_case_line d1) =
98 (strip_info.V0.rebuilder_case_line d2)
99 | (Ast0.TopTag(d1),Ast0.TopTag(d2)) ->
100 (strip_info.V0.rebuilder_top_level d1) =
101 (strip_info.V0.rebuilder_top_level d2)
102 | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_)) ->
103 failwith "only for isos within iso phase"
104 | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
105 failwith "only for isos within iso phase"
106 | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_)) ->
107 failwith "only for isos within iso phase"
110 let term (var1,_,_,_,_) = var1
111 let dot_term (var1,_,info,_,_) = ("", var1 ^ (string_of_int info.Ast0.offset))
115 NotPure of Ast0.pure * (string * string) * Ast0.anything
116 | NotPureLength of (string * string)
117 | ContextRequired of Ast0.anything
119 | Braces of Ast0.statement
120 | Position of string * string
121 | TypeMatch of reason list
123 let rec interpret_reason name line reason printer =
125 "warning: iso %s does not match the code below on line %d\n" name line;
126 printer(); Format.print_newline();
128 NotPure(Ast0.Pure,(_,var),nonpure) ->
130 "pure metavariable %s is matched against the following nonpure code:\n"
132 Unparse_ast0.unparse_anything nonpure
133 | NotPure(Ast0.Context,(_,var),nonpure) ->
135 "context metavariable %s is matched against the following\nnoncontext code:\n"
137 Unparse_ast0.unparse_anything nonpure
138 | NotPure(Ast0.PureContext,(_,var),nonpure) ->
140 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
142 Unparse_ast0.unparse_anything nonpure
143 | NotPureLength((_,var)) ->
145 "pure metavariable %s is matched against too much or too little code\n"
147 | ContextRequired(term) ->
149 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
150 Unparse_ast0.unparse_anything term
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"
158 | TypeMatch reason_list ->
159 List.iter (function r -> interpret_reason name line r printer)
161 | _ -> failwith "not possible"
163 type 'a either = OK of 'a | Fail of reason
165 let add_binding var exp bindings =
166 let var = term var in
167 let attempt bindings =
169 let cur = List.assoc var bindings in
170 if anything_equal(exp,cur) then [bindings] else []
171 with Not_found -> [((var,exp)::bindings)] in
172 match List.concat(List.map attempt bindings) with
176 let add_dot_binding var exp bindings =
177 let var = dot_term var in
178 let attempt bindings =
180 let cur = List.assoc var bindings in
181 if anything_equal(exp,cur) then [bindings] else []
182 with Not_found -> [((var,exp)::bindings)] in
183 match List.concat(List.map attempt bindings) with
188 let add_multi_dot_binding var exp bindings =
189 let var = dot_term var in
190 let attempt bindings = [((var,exp)::bindings)] in
191 match List.concat(List.map attempt bindings) with
198 | (x::xs) when (List.mem x xs) -> nub xs
199 | (x::xs) -> x::(nub xs)
201 (* --------------------------------------------------------------------- *)
205 let debug str m binding =
206 let res = m binding in
208 None -> Printf.printf "%s: failed\n" str
212 Printf.printf "%s: %s\n" str
213 (String.concat " " (List.map (function (x,_) -> x) binding)))
217 let conjunct_bindings
218 (m1 : 'binding -> 'binding either)
219 (m2 : 'binding -> 'binding either)
220 (binding : 'binding) : 'binding either =
221 match m1 binding with Fail(reason) -> Fail(reason) | OK binding -> m2 binding
223 let rec conjunct_many_bindings = function
224 [] -> failwith "not possible"
226 | x::xs -> conjunct_bindings x (conjunct_many_bindings xs)
228 let mcode_equal (x,_,_,_,_) (y,_,_,_,_) = x = y
230 let return b binding = if b then OK binding else Fail NonMatch
231 let return_false reason binding = Fail reason
233 let match_option f t1 t2 =
235 (Some t1, Some t2) -> f t1 t2
236 | (None, None) -> return true
239 let bool_match_option f t1 t2 =
241 (Some t1, Some t2) -> f t1 t2
242 | (None, None) -> true
245 (* context_required is for the example
249 where we can't change x == NULL to eg NULL == x. So there can either be
250 nothing attached to the root or the term has to be all removed.
251 if would be nice if we knew more about the relationship between the - and +
252 code, because in the case where the + code is a separate statement in a
253 sequence, this is not a problem. Perhaps something could be done in
256 The example seems strange. Why isn't the cast attached to x?
259 !Flag.sgrep_mode2 or (* everything is context for sgrep *)
260 (match Ast0.get_mcodekind e with
261 Ast0.CONTEXT(cell) -> true
264 (* needs a special case when there is a Disj or an empty DOTS
265 the following stops at the statement level, and gives true if one
266 statement is replaced by another *)
267 let rec is_pure_context s =
268 !Flag.sgrep_mode2 or (* everything is context for sgrep *)
269 (match Ast0.unwrap s with
270 Ast0.Disj(starter,statement_dots_list,mids,ender) ->
273 match Ast0.undots x with
274 [s] -> is_pure_context s
275 | _ -> false (* could we do better? *))
278 (match Ast0.get_mcodekind s with
281 (Ast.NOTHING,_,_) -> true
285 (* do better for the common case of replacing a stmt by another one *)
286 ([[Ast.StatementTag(s)]],_) ->
287 (match Ast.unwrap s with
288 Ast.IfThen(_,_,_) -> false (* potentially dangerous *)
294 match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
296 let match_list matcher is_list_matcher do_list_match la lb =
297 let rec loop = function
298 ([],[]) -> return true
299 | ([x],lb) when is_list_matcher x -> do_list_match x lb
300 | (x::xs,y::ys) -> conjunct_bindings (matcher x y) (loop (xs,ys))
301 | _ -> return false in
304 let match_maker checks_needed context_required whencode_allowed =
306 let check_mcode pmc cmc binding =
309 match Ast0.get_pos cmc with
310 (Ast0.MetaPos (name,_,_)) as x ->
311 (match Ast0.get_pos pmc with
312 Ast0.MetaPos (name1,_,_) ->
313 add_binding name1 (Ast0.MetaPosTag x) binding
315 let (rule,name) = Ast0.unwrap_mcode name in
316 Fail (Position(rule,name)))
317 | Ast0.NoMetaPos -> OK binding
320 let match_dots matcher is_list_matcher do_list_match d1 d2 =
321 match (Ast0.unwrap d1, Ast0.unwrap d2) with
322 (Ast0.DOTS(la),Ast0.DOTS(lb))
323 | (Ast0.CIRCLES(la),Ast0.CIRCLES(lb))
324 | (Ast0.STARS(la),Ast0.STARS(lb)) ->
325 match_list matcher is_list_matcher (do_list_match d2) la lb
326 | _ -> return false in
328 let is_elist_matcher el =
329 match Ast0.unwrap el with Ast0.MetaExprList(_,_,_) -> true | _ -> false in
331 let is_plist_matcher pl =
332 match Ast0.unwrap pl with Ast0.MetaParamList(_,_,_) -> true | _ -> false in
334 let is_slist_matcher pl =
335 match Ast0.unwrap pl with Ast0.MetaStmtList(_,_) -> true | _ -> false in
337 let no_list _ = false in
339 let build_dots pattern data =
340 match Ast0.unwrap pattern with
341 Ast0.DOTS(_) -> Ast0.rewrap pattern (Ast0.DOTS(data))
342 | Ast0.CIRCLES(_) -> Ast0.rewrap pattern (Ast0.CIRCLES(data))
343 | Ast0.STARS(_) -> Ast0.rewrap pattern (Ast0.STARS(data)) in
346 let bind = Ast0.lub_pure in
347 let option_default = Ast0.Context in
348 let pure_mcodekind mc =
350 then Ast0.PureContext
355 (Ast.NOTHING,_,_) -> Ast0.PureContext
358 (match !mc with ([],_) -> Ast0.Pure | _ -> Ast0.Impure)
359 | _ -> Ast0.Impure in
360 let donothing r k e =
361 bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e) in
363 let mcode m = pure_mcodekind (Ast0.get_mcode_mcodekind m) in
365 (* a case for everything that has a metavariable *)
366 (* pure is supposed to match only unitary metavars, not anything that
367 contains only unitary metavars *)
369 bind (bind (pure_mcodekind (Ast0.get_mcodekind i)) (k i))
370 (match Ast0.unwrap i with
371 Ast0.MetaId(name,_,pure) | Ast0.MetaFunc(name,_,pure)
372 | Ast0.MetaLocalFunc(name,_,pure) -> pure
373 | _ -> Ast0.Impure) in
375 let expression r k e =
376 bind (bind (pure_mcodekind (Ast0.get_mcodekind e)) (k e))
377 (match Ast0.unwrap e with
378 Ast0.MetaErr(name,_,pure)
379 | Ast0.MetaExpr(name,_,_,_,pure) | Ast0.MetaExprList(name,_,pure) ->
381 | _ -> Ast0.Impure) in
384 bind (bind (pure_mcodekind (Ast0.get_mcodekind t)) (k t))
385 (match Ast0.unwrap t with
386 Ast0.MetaType(name,pure) -> pure
387 | _ -> Ast0.Impure) in
390 bind (bind (pure_mcodekind (Ast0.get_mcodekind p)) (k p))
391 (match Ast0.unwrap p with
392 Ast0.MetaParam(name,pure) | Ast0.MetaParamList(name,_,pure) -> pure
393 | _ -> Ast0.Impure) in
396 bind (bind (pure_mcodekind (Ast0.get_mcodekind s)) (k s))
397 (match Ast0.unwrap s with
398 Ast0.MetaStmt(name,pure) | Ast0.MetaStmtList(name,pure) -> pure
399 | _ -> Ast0.Impure) in
401 V0.combiner bind option_default
402 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
403 donothing donothing donothing donothing donothing donothing
404 ident expression typeC donothing param donothing stmt donothing
407 let add_pure_list_binding name pure is_pure builder1 builder2 lst =
408 match (checks_needed,pure) with
409 (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
412 if (Ast0.lub_pure (is_pure x) pure) = pure
413 then add_binding name (builder1 lst)
414 else return_false (NotPure (pure,term name,builder1 lst))
415 | _ -> return_false (NotPureLength (term name)))
416 | (false,_) | (_,Ast0.Impure) -> add_binding name (builder2 lst) in
418 let add_pure_binding name pure is_pure builder x =
419 match (checks_needed,pure) with
420 (true,Ast0.Pure) | (true,Ast0.Context) | (true,Ast0.PureContext) ->
421 if (Ast0.lub_pure (is_pure x) pure) = pure
422 then add_binding name (builder x)
423 else return_false (NotPure (pure,term name, builder x))
424 | (false,_) | (_,Ast0.Impure) -> add_binding name (builder x) in
426 let do_elist_match builder el lst =
427 match Ast0.unwrap el with
428 Ast0.MetaExprList(name,lenname,pure) ->
429 (*how to handle lenname? should it be an option type and always None?*)
430 failwith "expr list pattern not supported in iso"
431 (*add_pure_list_binding name pure
432 pure_sp_code.V0.combiner_expression
433 (function lst -> Ast0.ExprTag(List.hd lst))
434 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
436 | _ -> failwith "not possible" in
438 let do_plist_match builder pl lst =
439 match Ast0.unwrap pl with
440 Ast0.MetaParamList(name,lename,pure) ->
441 failwith "param list pattern not supported in iso"
442 (*add_pure_list_binding name pure
443 pure_sp_code.V0.combiner_parameter
444 (function lst -> Ast0.ParamTag(List.hd lst))
445 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
447 | _ -> failwith "not possible" in
449 let do_slist_match builder sl lst =
450 match Ast0.unwrap sl with
451 Ast0.MetaStmtList(name,pure) ->
452 add_pure_list_binding name pure
453 pure_sp_code.V0.combiner_statement
454 (function lst -> Ast0.StmtTag(List.hd lst))
455 (function lst -> Ast0.DotsStmtTag(build_dots builder lst))
457 | _ -> failwith "not possible" in
459 let do_nolist_match _ _ = failwith "not possible" in
461 let rec match_ident pattern id =
462 match Ast0.unwrap pattern with
463 Ast0.MetaId(name,_,pure) ->
464 (add_pure_binding name pure pure_sp_code.V0.combiner_ident
465 (function id -> Ast0.IdentTag id) id)
466 | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
467 | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
469 if not(checks_needed) or not(context_required) or is_context id
471 match (up,Ast0.unwrap id) with
472 (Ast0.Id(namea),Ast0.Id(nameb)) ->
473 if mcode_equal namea nameb
474 then check_mcode namea nameb
476 | (Ast0.OptIdent(ida),Ast0.OptIdent(idb))
477 | (Ast0.UniqueIdent(ida),Ast0.UniqueIdent(idb)) ->
479 | (_,Ast0.OptIdent(idb))
480 | (_,Ast0.UniqueIdent(idb)) -> match_ident pattern idb
482 else return_false (ContextRequired (Ast0.IdentTag id)) in
484 (* should we do something about matching metavars against ...? *)
485 let rec match_expr pattern expr =
486 match Ast0.unwrap pattern with
487 Ast0.MetaExpr(name,_,ty,form,pure) ->
489 match (form,expr) with
493 match Ast0.unwrap e with
494 Ast0.Constant(c) -> true
495 | Ast0.Cast(lp,ty,rp,e) -> matches e
496 | Ast0.SizeOfExpr(se,exp) -> true
497 | Ast0.SizeOfType(se,lp,ty,rp) -> true
498 | Ast0.MetaExpr(nm,_,_,Ast.CONST,p) ->
499 (Ast0.lub_pure p pure) = pure
502 | (Ast.ID,e) | (Ast.LocalID,e) ->
504 match Ast0.unwrap e with
505 Ast0.Ident(c) -> true
506 | Ast0.Cast(lp,ty,rp,e) -> matches e
507 | Ast0.MetaExpr(nm,_,_,Ast.ID,p) ->
508 (Ast0.lub_pure p pure) = pure
516 (function Type_cocci.MetaType(_,_,_) -> true | _ -> false)
520 [Type_cocci.MetaType(tyname,_,_)] ->
522 match (Ast0.unwrap expr,Ast0.get_type expr) with
523 (* easier than updating type inferencer to manage multiple
525 (Ast0.MetaExpr(_,_,Some tts,_,_),_) -> Some tts
526 | (_,Some ty) -> Some [ty]
530 let tyname = Ast0.rewrap_mcode name tyname in
532 (add_pure_binding name pure
533 pure_sp_code.V0.combiner_expression
534 (function expr -> Ast0.ExprTag expr)
536 (function bindings ->
541 add_pure_binding tyname Ast0.Impure
542 (function _ -> Ast0.Impure)
543 (function ty -> Ast0.TypeCTag ty)
545 (Ast0.reverse_type expty))
549 "warning: unconvertible type";
550 return false bindings))
553 (function Fail _ -> false | OK x -> true)
556 (* not sure why this is ok. can there be more
560 (function Fail _ -> [] | OK x -> x)
568 | OK x -> failwith "not possible")
572 "warning: type metavar can only match one type";*)
576 "mixture of metatype and other types not supported")
578 let expty = Ast0.get_type expr in
579 if List.exists (function t -> Type_cocci.compatible t expty) ts
581 add_pure_binding name pure
582 pure_sp_code.V0.combiner_expression
583 (function expr -> Ast0.ExprTag expr)
587 add_pure_binding name pure pure_sp_code.V0.combiner_expression
588 (function expr -> Ast0.ExprTag expr)
591 | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
592 | Ast0.MetaExprList(_,_,_) -> failwith "metaexprlist not supported"
594 if not(checks_needed) or not(context_required) or is_context expr
596 match (up,Ast0.unwrap expr) with
597 (Ast0.Ident(ida),Ast0.Ident(idb)) ->
599 | (Ast0.Constant(consta),Ast0.Constant(constb)) ->
600 if mcode_equal consta constb
601 then check_mcode consta constb
603 | (Ast0.FunCall(fna,lp1,argsa,rp1),Ast0.FunCall(fnb,lp,argsb,rp)) ->
604 conjunct_many_bindings
605 [check_mcode lp1 lp; check_mcode rp1 rp; match_expr fna fnb;
606 match_dots match_expr is_elist_matcher do_elist_match
608 | (Ast0.Assignment(lefta,opa,righta,_),
609 Ast0.Assignment(leftb,opb,rightb,_)) ->
610 if mcode_equal opa opb
612 conjunct_many_bindings
613 [check_mcode opa opb; match_expr lefta leftb;
614 match_expr righta rightb]
616 | (Ast0.CondExpr(exp1a,lp1,exp2a,rp1,exp3a),
617 Ast0.CondExpr(exp1b,lp,exp2b,rp,exp3b)) ->
618 conjunct_many_bindings
619 [check_mcode lp1 lp; check_mcode rp1 rp;
620 match_expr exp1a exp1b; match_option match_expr exp2a exp2b;
621 match_expr exp3a exp3b]
622 | (Ast0.Postfix(expa,opa),Ast0.Postfix(expb,opb)) ->
623 if mcode_equal opa opb
625 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
627 | (Ast0.Infix(expa,opa),Ast0.Infix(expb,opb)) ->
628 if mcode_equal opa opb
630 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
632 | (Ast0.Unary(expa,opa),Ast0.Unary(expb,opb)) ->
633 if mcode_equal opa opb
635 conjunct_bindings (check_mcode opa opb) (match_expr expa expb)
637 | (Ast0.Binary(lefta,opa,righta),Ast0.Binary(leftb,opb,rightb)) ->
638 if mcode_equal opa opb
640 conjunct_many_bindings
641 [check_mcode opa opb; match_expr lefta leftb;
642 match_expr righta rightb]
644 | (Ast0.Paren(lp1,expa,rp1),Ast0.Paren(lp,expb,rp)) ->
645 conjunct_many_bindings
646 [check_mcode lp1 lp; check_mcode rp1 rp; match_expr expa expb]
647 | (Ast0.ArrayAccess(exp1a,lb1,exp2a,rb1),
648 Ast0.ArrayAccess(exp1b,lb,exp2b,rb)) ->
649 conjunct_many_bindings
650 [check_mcode lb1 lb; check_mcode rb1 rb;
651 match_expr exp1a exp1b; match_expr exp2a exp2b]
652 | (Ast0.RecordAccess(expa,opa,fielda),
653 Ast0.RecordAccess(expb,op,fieldb))
654 | (Ast0.RecordPtAccess(expa,opa,fielda),
655 Ast0.RecordPtAccess(expb,op,fieldb)) ->
656 conjunct_many_bindings
657 [check_mcode opa op; match_expr expa expb;
658 match_ident fielda fieldb]
659 | (Ast0.Cast(lp1,tya,rp1,expa),Ast0.Cast(lp,tyb,rp,expb)) ->
660 conjunct_many_bindings
661 [check_mcode lp1 lp; check_mcode rp1 rp;
662 match_typeC tya tyb; match_expr expa expb]
663 | (Ast0.SizeOfExpr(szf1,expa),Ast0.SizeOfExpr(szf,expb)) ->
664 conjunct_bindings (check_mcode szf1 szf) (match_expr expa expb)
665 | (Ast0.SizeOfType(szf1,lp1,tya,rp1),
666 Ast0.SizeOfType(szf,lp,tyb,rp)) ->
667 conjunct_many_bindings
668 [check_mcode lp1 lp; check_mcode rp1 rp;
669 check_mcode szf1 szf; match_typeC tya tyb]
670 | (Ast0.TypeExp(tya),Ast0.TypeExp(tyb)) ->
672 | (Ast0.EComma(cm1),Ast0.EComma(cm)) -> check_mcode cm1 cm
673 | (Ast0.DisjExpr(_,expsa,_,_),_) ->
674 failwith "not allowed in the pattern of an isomorphism"
675 | (Ast0.NestExpr(_,exp_dotsa,_,_,_),_) ->
676 failwith "not allowed in the pattern of an isomorphism"
677 | (Ast0.Edots(d,None),Ast0.Edots(d1,None))
678 | (Ast0.Ecircles(d,None),Ast0.Ecircles(d1,None))
679 | (Ast0.Estars(d,None),Ast0.Estars(d1,None)) -> check_mcode d d1
680 | (Ast0.Edots(ed,None),Ast0.Edots(ed1,Some wc))
681 | (Ast0.Ecircles(ed,None),Ast0.Ecircles(ed1,Some wc))
682 | (Ast0.Estars(ed,None),Ast0.Estars(ed1,Some wc)) ->
683 (* hope that mcode of edots is unique somehow *)
684 conjunct_bindings (check_mcode ed ed1)
685 (let (edots_whencode_allowed,_,_) = whencode_allowed in
686 if edots_whencode_allowed
687 then add_dot_binding ed (Ast0.ExprTag wc)
690 "warning: not applying iso because of whencode";
692 | (Ast0.Edots(_,Some _),_) | (Ast0.Ecircles(_,Some _),_)
693 | (Ast0.Estars(_,Some _),_) ->
694 failwith "whencode not allowed in a pattern1"
695 | (Ast0.OptExp(expa),Ast0.OptExp(expb))
696 | (Ast0.UniqueExp(expa),Ast0.UniqueExp(expb)) -> match_expr expa expb
697 | (_,Ast0.OptExp(expb))
698 | (_,Ast0.UniqueExp(expb)) -> match_expr pattern expb
700 else return_false (ContextRequired (Ast0.ExprTag expr))
702 (* the special case for function types prevents the eg T X; -> T X = E; iso
703 from applying, which doesn't seem very relevant, but it also avoids a
704 mysterious bug that is obtained with eg int attach(...); *)
705 and match_typeC pattern t =
706 match Ast0.unwrap pattern with
707 Ast0.MetaType(name,pure) ->
708 (match Ast0.unwrap t with
709 Ast0.FunctionType(tya,lp1a,paramsa,rp1a) -> return false
711 add_pure_binding name pure pure_sp_code.V0.combiner_typeC
712 (function ty -> Ast0.TypeCTag ty)
715 if not(checks_needed) or not(context_required) or is_context t
717 match (up,Ast0.unwrap t) with
718 (Ast0.ConstVol(cva,tya),Ast0.ConstVol(cvb,tyb)) ->
719 if mcode_equal cva cvb
721 conjunct_bindings (check_mcode cva cvb) (match_typeC tya tyb)
723 | (Ast0.BaseType(tya,stringsa),Ast0.BaseType(tyb,stringsb)) ->
726 match_list check_mcode
727 (function _ -> false) (function _ -> failwith "")
730 | (Ast0.Signed(signa,tya),Ast0.Signed(signb,tyb)) ->
731 if mcode_equal signa signb
733 conjunct_bindings (check_mcode signa signb)
734 (match_option match_typeC tya tyb)
736 | (Ast0.Pointer(tya,star1),Ast0.Pointer(tyb,star)) ->
737 conjunct_bindings (check_mcode star1 star) (match_typeC tya tyb)
738 | (Ast0.FunctionPointer(tya,lp1a,stara,rp1a,lp2a,paramsa,rp2a),
739 Ast0.FunctionPointer(tyb,lp1b,starb,rp1b,lp2b,paramsb,rp2b)) ->
740 conjunct_many_bindings
741 [check_mcode stara starb; check_mcode lp1a lp1b;
742 check_mcode rp1a rp1b; check_mcode lp2a lp2b;
743 check_mcode rp2a rp2b; match_typeC tya tyb;
744 match_dots match_param is_plist_matcher
745 do_plist_match paramsa paramsb]
746 | (Ast0.FunctionType(tya,lp1a,paramsa,rp1a),
747 Ast0.FunctionType(tyb,lp1b,paramsb,rp1b)) ->
748 conjunct_many_bindings
749 [check_mcode lp1a lp1b; check_mcode rp1a rp1b;
750 match_option match_typeC tya tyb;
751 match_dots match_param is_plist_matcher do_plist_match
753 | (Ast0.Array(tya,lb1,sizea,rb1),Ast0.Array(tyb,lb,sizeb,rb)) ->
754 conjunct_many_bindings
755 [check_mcode lb1 lb; check_mcode rb1 rb;
756 match_typeC tya tyb; match_option match_expr sizea sizeb]
757 | (Ast0.EnumName(kinda,namea),Ast0.EnumName(kindb,nameb)) ->
758 conjunct_bindings (check_mcode kinda kindb)
759 (match_ident namea nameb)
760 | (Ast0.StructUnionName(kinda,Some namea),
761 Ast0.StructUnionName(kindb,Some nameb)) ->
762 if mcode_equal kinda kindb
764 conjunct_bindings (check_mcode kinda kindb)
765 (match_ident namea nameb)
767 | (Ast0.StructUnionDef(tya,lb1,declsa,rb1),
768 Ast0.StructUnionDef(tyb,lb,declsb,rb)) ->
769 conjunct_many_bindings
770 [check_mcode lb1 lb; check_mcode rb1 rb;
772 match_dots match_decl no_list do_nolist_match declsa declsb]
773 | (Ast0.TypeName(namea),Ast0.TypeName(nameb)) ->
774 if mcode_equal namea nameb
775 then check_mcode namea nameb
777 | (Ast0.DisjType(_,typesa,_,_),Ast0.DisjType(_,typesb,_,_)) ->
778 failwith "not allowed in the pattern of an isomorphism"
779 | (Ast0.OptType(tya),Ast0.OptType(tyb))
780 | (Ast0.UniqueType(tya),Ast0.UniqueType(tyb)) -> match_typeC tya tyb
781 | (_,Ast0.OptType(tyb))
782 | (_,Ast0.UniqueType(tyb)) -> match_typeC pattern tyb
784 else return_false (ContextRequired (Ast0.TypeCTag t))
786 and match_decl pattern d =
787 if not(checks_needed) or not(context_required) or is_context d
789 match (Ast0.unwrap pattern,Ast0.unwrap d) with
790 (Ast0.Init(stga,tya,ida,eq1,inia,sc1),
791 Ast0.Init(stgb,tyb,idb,eq,inib,sc)) ->
792 if bool_match_option mcode_equal stga stgb
794 conjunct_many_bindings
795 [check_mcode eq1 eq; check_mcode sc1 sc;
796 match_option check_mcode stga stgb;
797 match_typeC tya tyb; match_ident ida idb;
798 match_init inia inib]
800 | (Ast0.UnInit(stga,tya,ida,sc1),Ast0.UnInit(stgb,tyb,idb,sc)) ->
801 if bool_match_option mcode_equal stga stgb
803 conjunct_many_bindings
804 [check_mcode sc1 sc; match_option check_mcode stga stgb;
805 match_typeC tya tyb; match_ident ida idb]
807 | (Ast0.MacroDecl(namea,lp1,argsa,rp1,sc1),
808 Ast0.MacroDecl(nameb,lp,argsb,rp,sc)) ->
809 conjunct_many_bindings
810 [match_ident namea nameb;
811 check_mcode lp1 lp; check_mcode rp1 rp;
813 match_dots match_expr is_elist_matcher do_elist_match
815 | (Ast0.TyDecl(tya,sc1),Ast0.TyDecl(tyb,sc)) ->
816 conjunct_bindings (check_mcode sc1 sc) (match_typeC tya tyb)
817 | (Ast0.Typedef(stga,tya,ida,sc1),Ast0.Typedef(stgb,tyb,idb,sc)) ->
818 conjunct_bindings (check_mcode sc1 sc)
819 (conjunct_bindings (match_typeC tya tyb) (match_typeC ida idb))
820 | (Ast0.DisjDecl(_,declsa,_,_),Ast0.DisjDecl(_,declsb,_,_)) ->
821 failwith "not allowed in the pattern of an isomorphism"
822 | (Ast0.Ddots(d1,None),Ast0.Ddots(d,None)) -> check_mcode d1 d
823 | (Ast0.Ddots(dd,None),Ast0.Ddots(d,Some wc)) ->
824 conjunct_bindings (check_mcode dd d)
825 (* hope that mcode of ddots is unique somehow *)
826 (let (ddots_whencode_allowed,_,_) = whencode_allowed in
827 if ddots_whencode_allowed
828 then add_dot_binding dd (Ast0.DeclTag wc)
830 (Printf.printf "warning: not applying iso because of whencode";
832 | (Ast0.Ddots(_,Some _),_) ->
833 failwith "whencode not allowed in a pattern1"
835 | (Ast0.OptDecl(decla),Ast0.OptDecl(declb))
836 | (Ast0.UniqueDecl(decla),Ast0.UniqueDecl(declb)) ->
837 match_decl decla declb
838 | (_,Ast0.OptDecl(declb))
839 | (_,Ast0.UniqueDecl(declb)) ->
840 match_decl pattern declb
842 else return_false (ContextRequired (Ast0.DeclTag d))
844 and match_init pattern i =
845 if not(checks_needed) or not(context_required) or is_context i
847 match (Ast0.unwrap pattern,Ast0.unwrap i) with
848 (Ast0.InitExpr(expa),Ast0.InitExpr(expb)) ->
850 | (Ast0.InitList(lb1,initlista,rb1),Ast0.InitList(lb,initlistb,rb)) ->
851 conjunct_many_bindings
852 [check_mcode lb1 lb; check_mcode rb1 rb;
853 match_dots match_init no_list do_nolist_match
855 | (Ast0.InitGccDotName(d1,namea,e1,inia),
856 Ast0.InitGccDotName(d,nameb,e,inib)) ->
857 conjunct_many_bindings
858 [check_mcode d1 d; check_mcode e1 e;
859 match_ident namea nameb; match_init inia inib]
860 | (Ast0.InitGccName(namea,c1,inia),Ast0.InitGccName(nameb,c,inib)) ->
861 conjunct_many_bindings
862 [check_mcode c1 c; match_ident namea nameb;
863 match_init inia inib]
864 | (Ast0.InitGccIndex(lb1,expa,rb1,e1,inia),
865 Ast0.InitGccIndex(lb2,expb,rb2,e2,inib)) ->
866 conjunct_many_bindings
867 [check_mcode lb1 lb2; check_mcode rb1 rb2; check_mcode e1 e2;
868 match_expr expa expb; match_init inia inib]
869 | (Ast0.InitGccRange(lb1,exp1a,d1,exp2a,rb1,e1,inia),
870 Ast0.InitGccRange(lb2,exp1b,d2,exp2b,rb2,e2,inib)) ->
871 conjunct_many_bindings
872 [check_mcode lb1 lb2; check_mcode d1 d2;
873 check_mcode rb1 rb2; check_mcode e1 e2;
874 match_expr exp1a exp1b; match_expr exp2a exp2b;
875 match_init inia inib]
876 | (Ast0.IComma(c1),Ast0.IComma(c)) -> check_mcode c1 c
877 | (Ast0.Idots(d1,None),Ast0.Idots(d,None)) -> check_mcode d1 d
878 | (Ast0.Idots(id,None),Ast0.Idots(d,Some wc)) ->
879 conjunct_bindings (check_mcode id d)
880 (* hope that mcode of edots is unique somehow *)
881 (let (_,idots_whencode_allowed,_) = whencode_allowed in
882 if idots_whencode_allowed
883 then add_dot_binding id (Ast0.InitTag wc)
885 (Printf.printf "warning: not applying iso because of whencode";
887 | (Ast0.Idots(_,Some _),_) ->
888 failwith "whencode not allowed in a pattern2"
889 | (Ast0.OptIni(ia),Ast0.OptIni(ib))
890 | (Ast0.UniqueIni(ia),Ast0.UniqueIni(ib)) -> match_init ia ib
891 | (_,Ast0.OptIni(ib))
892 | (_,Ast0.UniqueIni(ib)) -> match_init pattern ib
894 else return_false (ContextRequired (Ast0.InitTag i))
896 and match_param pattern p =
897 match Ast0.unwrap pattern with
898 Ast0.MetaParam(name,pure) ->
899 add_pure_binding name pure pure_sp_code.V0.combiner_parameter
900 (function p -> Ast0.ParamTag p)
902 | Ast0.MetaParamList(name,_,pure) -> failwith "metaparamlist not supported"
904 if not(checks_needed) or not(context_required) or is_context p
906 match (up,Ast0.unwrap p) with
907 (Ast0.VoidParam(tya),Ast0.VoidParam(tyb)) -> match_typeC tya tyb
908 | (Ast0.Param(tya,ida),Ast0.Param(tyb,idb)) ->
909 conjunct_bindings (match_typeC tya tyb)
910 (match_option match_ident ida idb)
911 | (Ast0.PComma(c1),Ast0.PComma(c)) -> check_mcode c1 c
912 | (Ast0.Pdots(d1),Ast0.Pdots(d))
913 | (Ast0.Pcircles(d1),Ast0.Pcircles(d)) -> check_mcode d1 d
914 | (Ast0.OptParam(parama),Ast0.OptParam(paramb))
915 | (Ast0.UniqueParam(parama),Ast0.UniqueParam(paramb)) ->
916 match_param parama paramb
917 | (_,Ast0.OptParam(paramb))
918 | (_,Ast0.UniqueParam(paramb)) -> match_param pattern paramb
920 else return_false (ContextRequired (Ast0.ParamTag p))
922 and match_statement pattern s =
923 match Ast0.unwrap pattern with
924 Ast0.MetaStmt(name,pure) ->
925 (match Ast0.unwrap s with
926 Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) ->
927 return false (* ... is not a single statement *)
929 add_pure_binding name pure pure_sp_code.V0.combiner_statement
930 (function ty -> Ast0.StmtTag ty)
932 | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
934 if not(checks_needed) or not(context_required) or is_context s
936 match (up,Ast0.unwrap s) with
937 (Ast0.FunDecl(_,fninfoa,namea,lp1,paramsa,rp1,lb1,bodya,rb1),
938 Ast0.FunDecl(_,fninfob,nameb,lp,paramsb,rp,lb,bodyb,rb)) ->
939 conjunct_many_bindings
940 [check_mcode lp1 lp; check_mcode rp1 rp;
941 check_mcode lb1 lb; check_mcode rb1 rb;
942 match_fninfo fninfoa fninfob; match_ident namea nameb;
943 match_dots match_param is_plist_matcher do_plist_match
945 match_dots match_statement is_slist_matcher do_slist_match
947 | (Ast0.Decl(_,decla),Ast0.Decl(_,declb)) ->
948 match_decl decla declb
949 | (Ast0.Seq(lb1,bodya,rb1),Ast0.Seq(lb,bodyb,rb)) ->
950 (* seqs can only match if they are all minus (plus code
951 allowed) or all context (plus code not allowed in the body).
952 we could be more permissive if the expansions of the isos are
953 also all seqs, but this would be hard to check except at top
954 level, and perhaps not worth checking even in that case.
955 Overall, the issue is that braces are used where single
956 statements are required, and something not satisfying these
957 conditions can cause a single statement to become a
958 non-single statement after the transformation.
960 example: if { ... -foo(); ... }
961 if we let the sequence convert to just -foo();
962 then we produce invalid code. For some reason,
963 single_statement can't deal with this case, perhaps because
964 it starts introducing too many braces? don't remember the
967 conjunct_bindings (check_mcode lb1 lb)
968 (conjunct_bindings (check_mcode rb1 rb)
969 (if not(checks_needed) or is_minus s or
971 List.for_all is_pure_context (Ast0.undots bodyb))
973 match_dots match_statement is_slist_matcher do_slist_match
975 else return_false (Braces(s))))
976 | (Ast0.ExprStatement(expa,sc1),Ast0.ExprStatement(expb,sc)) ->
977 conjunct_bindings (check_mcode sc1 sc) (match_expr expa expb)
978 | (Ast0.IfThen(if1,lp1,expa,rp1,branch1a,_),
979 Ast0.IfThen(if2,lp2,expb,rp2,branch1b,_)) ->
980 conjunct_many_bindings
981 [check_mcode if1 if2; check_mcode lp1 lp2;
983 match_expr expa expb;
984 match_statement branch1a branch1b]
985 | (Ast0.IfThenElse(if1,lp1,expa,rp1,branch1a,e1,branch2a,_),
986 Ast0.IfThenElse(if2,lp2,expb,rp2,branch1b,e2,branch2b,_)) ->
987 conjunct_many_bindings
988 [check_mcode if1 if2; check_mcode lp1 lp2;
989 check_mcode rp1 rp2; check_mcode e1 e2;
990 match_expr expa expb;
991 match_statement branch1a branch1b;
992 match_statement branch2a branch2b]
993 | (Ast0.While(w1,lp1,expa,rp1,bodya,_),
994 Ast0.While(w,lp,expb,rp,bodyb,_)) ->
995 conjunct_many_bindings
996 [check_mcode w1 w; check_mcode lp1 lp;
997 check_mcode rp1 rp; match_expr expa expb;
998 match_statement bodya bodyb]
999 | (Ast0.Do(d1,bodya,w1,lp1,expa,rp1,_),
1000 Ast0.Do(d,bodyb,w,lp,expb,rp,_)) ->
1001 conjunct_many_bindings
1002 [check_mcode d1 d; check_mcode w1 w; check_mcode lp1 lp;
1003 check_mcode rp1 rp; match_statement bodya bodyb;
1004 match_expr expa expb]
1005 | (Ast0.For(f1,lp1,e1a,sc1a,e2a,sc2a,e3a,rp1,bodya,_),
1006 Ast0.For(f,lp,e1b,sc1b,e2b,sc2b,e3b,rp,bodyb,_)) ->
1007 conjunct_many_bindings
1008 [check_mcode f1 f; check_mcode lp1 lp; check_mcode sc1a sc1b;
1009 check_mcode sc2a sc2b; check_mcode rp1 rp;
1010 match_option match_expr e1a e1b;
1011 match_option match_expr e2a e2b;
1012 match_option match_expr e3a e3b;
1013 match_statement bodya bodyb]
1014 | (Ast0.Iterator(nma,lp1,argsa,rp1,bodya,_),
1015 Ast0.Iterator(nmb,lp,argsb,rp,bodyb,_)) ->
1016 conjunct_many_bindings
1017 [match_ident nma nmb;
1018 check_mcode lp1 lp; check_mcode rp1 rp;
1019 match_dots match_expr is_elist_matcher do_elist_match
1021 match_statement bodya bodyb]
1022 | (Ast0.Switch(s1,lp1,expa,rp1,lb1,casesa,rb1),
1023 Ast0.Switch(s,lp,expb,rp,lb,casesb,rb)) ->
1024 conjunct_many_bindings
1025 [check_mcode s1 s; check_mcode lp1 lp; check_mcode rp1 rp;
1026 check_mcode lb1 lb; check_mcode rb1 rb;
1027 match_expr expa expb;
1028 match_dots match_case_line no_list do_nolist_match
1030 | (Ast0.Break(b1,sc1),Ast0.Break(b,sc))
1031 | (Ast0.Continue(b1,sc1),Ast0.Continue(b,sc)) ->
1032 conjunct_bindings (check_mcode b1 b) (check_mcode sc1 sc)
1033 | (Ast0.Label(l1,c1),Ast0.Label(l2,c)) ->
1034 conjunct_bindings (match_ident l1 l2) (check_mcode c1 c)
1035 | (Ast0.Goto(g1,l1,sc1),Ast0.Goto(g,l2,sc)) ->
1036 conjunct_many_bindings
1037 [check_mcode g1 g; check_mcode sc1 sc; match_ident l1 l2]
1038 | (Ast0.Return(r1,sc1),Ast0.Return(r,sc)) ->
1039 conjunct_bindings (check_mcode r1 r) (check_mcode sc1 sc)
1040 | (Ast0.ReturnExpr(r1,expa,sc1),Ast0.ReturnExpr(r,expb,sc)) ->
1041 conjunct_many_bindings
1042 [check_mcode r1 r; check_mcode sc1 sc; match_expr expa expb]
1043 | (Ast0.Disj(_,statement_dots_lista,_,_),_) ->
1044 failwith "disj not supported in patterns"
1045 | (Ast0.Nest(_,stmt_dotsa,_,_,_),_) ->
1046 failwith "nest not supported in patterns"
1047 | (Ast0.Exp(expa),Ast0.Exp(expb)) -> match_expr expa expb
1048 | (Ast0.TopExp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
1049 | (Ast0.Exp(expa),Ast0.TopExp(expb)) -> match_expr expa expb
1050 | (Ast0.TopInit(inita),Ast0.TopInit(initb)) -> match_init inita initb
1051 | (Ast0.Ty(tya),Ast0.Ty(tyb)) -> match_typeC tya tyb
1052 | (Ast0.Dots(d,[]),Ast0.Dots(d1,wc))
1053 | (Ast0.Circles(d,[]),Ast0.Circles(d1,wc))
1054 | (Ast0.Stars(d,[]),Ast0.Stars(d1,wc)) ->
1056 [] -> check_mcode d d1
1058 let (_,_,dots_whencode_allowed) = whencode_allowed in
1059 if dots_whencode_allowed
1061 conjunct_bindings (check_mcode d d1)
1065 | Ast0.WhenNot wc ->
1066 conjunct_bindings prev
1067 (add_multi_dot_binding d
1068 (Ast0.DotsStmtTag wc))
1069 | Ast0.WhenAlways wc ->
1070 conjunct_bindings prev
1071 (add_multi_dot_binding d (Ast0.StmtTag wc))
1072 | Ast0.WhenNotTrue wc ->
1073 conjunct_bindings prev
1074 (add_multi_dot_binding d
1075 (Ast0.IsoWhenTTag wc))
1076 | Ast0.WhenNotFalse wc ->
1077 conjunct_bindings prev
1078 (add_multi_dot_binding d
1079 (Ast0.IsoWhenFTag wc))
1080 | Ast0.WhenModifier(x) ->
1081 conjunct_bindings prev
1082 (add_multi_dot_binding d
1083 (Ast0.IsoWhenTag x)))
1087 "warning: not applying iso because of whencode";
1089 | (Ast0.Dots(_,_::_),_) | (Ast0.Circles(_,_::_),_)
1090 | (Ast0.Stars(_,_::_),_) ->
1091 failwith "whencode not allowed in a pattern3"
1092 | (Ast0.OptStm(rea),Ast0.OptStm(reb))
1093 | (Ast0.UniqueStm(rea),Ast0.UniqueStm(reb)) ->
1094 match_statement rea reb
1095 | (_,Ast0.OptStm(reb))
1096 | (_,Ast0.UniqueStm(reb)) -> match_statement pattern reb
1098 else return_false (ContextRequired (Ast0.StmtTag s))
1100 (* first should provide a subset of the information in the second *)
1101 and match_fninfo patterninfo cinfo =
1102 let patterninfo = List.sort compare patterninfo in
1103 let cinfo = List.sort compare cinfo in
1104 let rec loop = function
1105 (Ast0.FStorage(sta)::resta,Ast0.FStorage(stb)::restb) ->
1106 if mcode_equal sta stb
1107 then conjunct_bindings (check_mcode sta stb) (loop (resta,restb))
1109 | (Ast0.FType(tya)::resta,Ast0.FType(tyb)::restb) ->
1110 conjunct_bindings (match_typeC tya tyb) (loop (resta,restb))
1111 | (Ast0.FInline(ia)::resta,Ast0.FInline(ib)::restb) ->
1112 if mcode_equal ia ib
1113 then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
1115 | (Ast0.FAttr(ia)::resta,Ast0.FAttr(ib)::restb) ->
1116 if mcode_equal ia ib
1117 then conjunct_bindings (check_mcode ia ib) (loop (resta,restb))
1119 | (x::resta,((y::_) as restb)) ->
1120 (match compare x y with
1122 | 1 -> loop (resta,restb)
1123 | _ -> failwith "not possible")
1124 | _ -> return false in
1125 loop (patterninfo,cinfo)
1127 and match_case_line pattern c =
1128 if not(checks_needed) or not(context_required) or is_context c
1130 match (Ast0.unwrap pattern,Ast0.unwrap c) with
1131 (Ast0.Default(d1,c1,codea),Ast0.Default(d,c,codeb)) ->
1132 conjunct_many_bindings
1133 [check_mcode d1 d; check_mcode c1 c;
1134 match_dots match_statement is_slist_matcher do_slist_match
1136 | (Ast0.Case(ca1,expa,c1,codea),Ast0.Case(ca,expb,c,codeb)) ->
1137 conjunct_many_bindings
1138 [check_mcode ca1 ca; check_mcode c1 c; match_expr expa expb;
1139 match_dots match_statement is_slist_matcher do_slist_match
1141 | (Ast0.OptCase(ca),Ast0.OptCase(cb)) -> match_case_line ca cb
1142 | (_,Ast0.OptCase(cb)) -> match_case_line pattern cb
1144 else return_false (ContextRequired (Ast0.CaseLineTag c)) in
1146 let match_statement_dots x y =
1147 match_dots match_statement is_slist_matcher do_slist_match x y in
1149 (match_expr, match_decl, match_statement, match_typeC,
1150 match_statement_dots)
1152 let match_expr dochecks context_required whencode_allowed =
1153 let (fn,_,_,_,_) = match_maker dochecks context_required whencode_allowed in
1156 let match_decl dochecks context_required whencode_allowed =
1157 let (_,fn,_,_,_) = match_maker dochecks context_required whencode_allowed in
1160 let match_statement dochecks context_required whencode_allowed =
1161 let (_,_,fn,_,_) = match_maker dochecks context_required whencode_allowed in
1164 let match_typeC dochecks context_required whencode_allowed =
1165 let (_,_,_,fn,_) = match_maker dochecks context_required whencode_allowed in
1168 let match_statement_dots dochecks context_required whencode_allowed =
1169 let (_,_,_,_,fn) = match_maker dochecks context_required whencode_allowed in
1172 (* --------------------------------------------------------------------- *)
1173 (* make an entire tree MINUS *)
1176 let mcode (term,arity,info,mcodekind,pos) =
1178 match mcodekind with
1181 (Ast.NOTHING,_,_) -> Ast0.MINUS(ref([],Ast0.default_token_info))
1182 | _ -> failwith "make_minus: unexpected befaft")
1183 | Ast0.MINUS(mc) -> mcodekind (* in the part copied from the src term *)
1184 | _ -> failwith "make_minus mcode: unexpected mcodekind" in
1185 (term,arity,info,new_mcodekind,pos) in
1187 let update_mc mcodekind e =
1188 match !mcodekind with
1191 (Ast.NOTHING,_,_) ->
1192 mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info))
1193 | _ -> failwith "make_minus: unexpected befaft")
1194 | Ast0.MINUS(_mc) -> () (* in the part copied from the src term *)
1195 | Ast0.PLUS -> failwith "make_minus donothing: unexpected plus mcodekind"
1196 | _ -> failwith "make_minus donothing: unexpected mcodekind" in
1198 let donothing r k e =
1199 let mcodekind = Ast0.get_mcodekind_ref e in
1200 let e = k e in update_mc mcodekind e; e in
1202 (* special case for whencode, because it isn't processed by contextneg,
1203 since it doesn't appear in the + code *)
1204 (* cases for dots and nests *)
1205 let expression r k e =
1206 let mcodekind = Ast0.get_mcodekind_ref e in
1207 match Ast0.unwrap e with
1208 Ast0.Edots(d,whencode) ->
1209 (*don't recurse because whencode hasn't been processed by context_neg*)
1210 update_mc mcodekind e; Ast0.rewrap e (Ast0.Edots(mcode d,whencode))
1211 | Ast0.Ecircles(d,whencode) ->
1212 (*don't recurse because whencode hasn't been processed by context_neg*)
1213 update_mc mcodekind e; Ast0.rewrap e (Ast0.Ecircles(mcode d,whencode))
1214 | Ast0.Estars(d,whencode) ->
1215 (*don't recurse because whencode hasn't been processed by context_neg*)
1216 update_mc mcodekind e; Ast0.rewrap e (Ast0.Estars(mcode d,whencode))
1217 | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) ->
1218 update_mc mcodekind e;
1220 (Ast0.NestExpr(mcode starter,
1221 r.V0.rebuilder_expression_dots expr_dots,
1222 mcode ender,whencode,multi))
1223 | _ -> donothing r k e in
1225 let declaration r k e =
1226 let mcodekind = Ast0.get_mcodekind_ref e in
1227 match Ast0.unwrap e with
1228 Ast0.Ddots(d,whencode) ->
1229 (*don't recurse because whencode hasn't been processed by context_neg*)
1230 update_mc mcodekind e; Ast0.rewrap e (Ast0.Ddots(mcode d,whencode))
1231 | _ -> donothing r k e in
1233 let statement r k e =
1234 let mcodekind = Ast0.get_mcodekind_ref e in
1235 match Ast0.unwrap e with
1236 Ast0.Dots(d,whencode) ->
1237 (*don't recurse because whencode hasn't been processed by context_neg*)
1238 update_mc mcodekind e; Ast0.rewrap e (Ast0.Dots(mcode d,whencode))
1239 | Ast0.Circles(d,whencode) ->
1240 update_mc mcodekind e; Ast0.rewrap e (Ast0.Circles(mcode d,whencode))
1241 | Ast0.Stars(d,whencode) ->
1242 update_mc mcodekind e; Ast0.rewrap e (Ast0.Stars(mcode d,whencode))
1243 | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) ->
1244 update_mc mcodekind e;
1246 (Ast0.Nest(mcode starter,r.V0.rebuilder_statement_dots stmt_dots,
1247 mcode ender,whencode,multi))
1248 | _ -> donothing r k e in
1250 let initialiser r k e =
1251 let mcodekind = Ast0.get_mcodekind_ref e in
1252 match Ast0.unwrap e with
1253 Ast0.Idots(d,whencode) ->
1254 (*don't recurse because whencode hasn't been processed by context_neg*)
1255 update_mc mcodekind e; Ast0.rewrap e (Ast0.Idots(mcode d,whencode))
1256 | _ -> donothing r k e in
1259 let info = Ast0.get_info e in
1260 let mcodekind = Ast0.get_mcodekind_ref e in
1261 match Ast0.unwrap e with
1263 (* if context is - this should be - as well. There are no tokens
1264 here though, so the bottom-up minusifier in context_neg leaves it
1265 as mixed (or context for sgrep2). It would be better to fix
1266 context_neg, but that would
1267 require a special case for each term with a dots subterm. *)
1268 (match !mcodekind with
1269 Ast0.MIXED(mc) | Ast0.CONTEXT(mc) ->
1271 (Ast.NOTHING,_,_) ->
1272 mcodekind := Ast0.MINUS(ref([],Ast0.default_token_info));
1274 | _ -> failwith "make_minus: unexpected befaft")
1275 (* code already processed by an enclosing iso *)
1276 | Ast0.MINUS(mc) -> e
1280 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1281 info.Ast0.line_start (Dumper.dump e)))
1282 | _ -> donothing r k e in
1285 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1286 dots dots dots dots dots dots
1287 donothing expression donothing initialiser donothing declaration
1288 statement donothing donothing
1290 (* --------------------------------------------------------------------- *)
1291 (* rebuild mcode cells in an instantiated alt *)
1293 (* mcodes will be side effected later with plus code, so we have to copy
1294 them on instantiating an isomorphism. One could wonder whether it would
1295 be better not to use side-effects, but they are convenient for insert_plus
1296 where is it useful to manipulate a list of the mcodes but side-effect a
1298 (* hmm... Insert_plus is called before Iso_pattern... *)
1299 let rebuild_mcode start_line =
1300 let copy_mcodekind = function
1301 Ast0.CONTEXT(mc) -> Ast0.CONTEXT(ref (!mc))
1302 | Ast0.MINUS(mc) -> Ast0.MINUS(ref (!mc))
1303 | Ast0.MIXED(mc) -> Ast0.MIXED(ref (!mc))
1305 (* this function is used elsewhere where we need to rebuild the
1306 indices, and so we allow PLUS code as well *)
1309 let mcode (term,arity,info,mcodekind,pos) =
1311 match start_line with
1312 Some x -> {info with Ast0.line_start = x; Ast0.line_end = x}
1314 (term,arity,info,copy_mcodekind mcodekind,pos) in
1317 let old_info = Ast0.get_info x in
1319 match start_line with
1320 Some x -> {old_info with Ast0.line_start = x; Ast0.line_end = x}
1321 | None -> old_info in
1322 {x with Ast0.info = info; Ast0.index = ref(Ast0.get_index x);
1323 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind x))} in
1325 let donothing r k e = copy_one (k e) in
1327 (* case for control operators (if, etc) *)
1328 let statement r k e =
1333 (match Ast0.unwrap s with
1334 Ast0.Decl((info,mc),decl) ->
1335 Ast0.Decl((info,copy_mcodekind mc),decl)
1336 | Ast0.IfThen(iff,lp,tst,rp,branch,(info,mc)) ->
1337 Ast0.IfThen(iff,lp,tst,rp,branch,(info,copy_mcodekind mc))
1338 | Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,(info,mc)) ->
1339 Ast0.IfThenElse(iff,lp,tst,rp,branch1,els,branch2,
1340 (info,copy_mcodekind mc))
1341 | Ast0.While(whl,lp,exp,rp,body,(info,mc)) ->
1342 Ast0.While(whl,lp,exp,rp,body,(info,copy_mcodekind mc))
1343 | Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,(info,mc)) ->
1344 Ast0.For(fr,lp,e1,sem1,e2,sem2,e3,rp,body,
1345 (info,copy_mcodekind mc))
1346 | Ast0.Iterator(nm,lp,args,rp,body,(info,mc)) ->
1347 Ast0.Iterator(nm,lp,args,rp,body,(info,copy_mcodekind mc))
1349 ((info,mc),fninfo,name,lp,params,rp,lbrace,body,rbrace) ->
1351 ((info,copy_mcodekind mc),
1352 fninfo,name,lp,params,rp,lbrace,body,rbrace)
1354 Ast0.set_dots_bef_aft res
1355 (match Ast0.get_dots_bef_aft res with
1356 Ast0.NoDots -> Ast0.NoDots
1357 | Ast0.AddingBetweenDots s ->
1358 Ast0.AddingBetweenDots(r.V0.rebuilder_statement s)
1359 | Ast0.DroppingBetweenDots s ->
1360 Ast0.DroppingBetweenDots(r.V0.rebuilder_statement s)) in
1363 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1364 donothing donothing donothing donothing donothing donothing
1365 donothing donothing donothing donothing donothing
1366 donothing statement donothing donothing
1368 (* --------------------------------------------------------------------- *)
1369 (* The problem of whencode. If an isomorphism contains dots in multiple
1370 rules, then the code that is matched cannot contain whencode, because we
1371 won't know which dots it goes with. Should worry about nests, but they
1372 aren't allowed in isomorphisms for the moment. *)
1376 let option_default = 0 in
1377 let bind x y = x + y in
1378 let donothing r k e = k e in
1380 match Ast0.unwrap e with
1381 Ast0.Edots(_,_) | Ast0.Ecircles(_,_) | Ast0.Estars(_,_) -> 1
1384 V0.combiner bind option_default
1385 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1386 donothing donothing donothing donothing donothing donothing
1387 donothing exprfn donothing donothing donothing donothing donothing
1392 let option_default = 0 in
1393 let bind x y = x + y in
1394 let donothing r k e = k e in
1396 match Ast0.unwrap e with Ast0.Idots(_,_) -> 1 | _ -> 0 in
1398 V0.combiner bind option_default
1399 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1400 donothing donothing donothing donothing donothing donothing
1401 donothing donothing donothing initfn donothing donothing donothing
1406 let option_default = 0 in
1407 let bind x y = x + y in
1408 let donothing r k e = k e in
1410 match Ast0.unwrap e with
1411 Ast0.Dots(_,_) | Ast0.Circles(_,_) | Ast0.Stars(_,_) -> 1
1414 V0.combiner bind option_default
1415 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1416 donothing donothing donothing donothing donothing donothing
1417 donothing donothing donothing donothing donothing donothing stmtfn
1420 (* --------------------------------------------------------------------- *)
1422 let lookup name bindings mv_bindings =
1423 try Common.Left (List.assoc (term name) bindings)
1426 (* failure is not possible anymore *)
1427 Common.Right (List.assoc (term name) mv_bindings)
1429 (* mv_bindings is for the fresh metavariables that are introduced by the
1431 let instantiate bindings mv_bindings =
1433 match Ast0.get_pos x with
1434 Ast0.MetaPos(name,_,_) ->
1436 match lookup name bindings mv_bindings with
1437 Common.Left(Ast0.MetaPosTag(id)) -> Ast0.set_pos id x
1438 | _ -> failwith "not possible"
1439 with Not_found -> Ast0.set_pos Ast0.NoMetaPos x)
1441 let donothing r k e = k e in
1443 (* cases where metavariables can occur *)
1446 match Ast0.unwrap e with
1447 Ast0.MetaId(name,constraints,pure) ->
1448 (rebuild_mcode None).V0.rebuilder_ident
1449 (match lookup name bindings mv_bindings with
1450 Common.Left(Ast0.IdentTag(id)) -> id
1451 | Common.Left(_) -> failwith "not possible 1"
1452 | Common.Right(new_mv) ->
1455 (Ast0.set_mcode_data new_mv name,constraints,pure)))
1456 | Ast0.MetaFunc(name,_,pure) -> failwith "metafunc not supported"
1457 | Ast0.MetaLocalFunc(name,_,pure) -> failwith "metalocalfunc not supported"
1460 (* case for list metavariables *)
1461 let rec elist r same_dots = function
1464 (match Ast0.unwrap x with
1465 Ast0.MetaExprList(name,lenname,pure) ->
1466 failwith "meta_expr_list in iso not supported"
1467 (*match lookup name bindings mv_bindings with
1468 Common.Left(Ast0.DotsExprTag(exp)) ->
1469 (match same_dots exp with
1471 | None -> failwith "dots put in incompatible context")
1472 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1473 | Common.Left(_) -> failwith "not possible 1"
1474 | Common.Right(new_mv) ->
1475 failwith "MetaExprList in SP not supported"*)
1476 | _ -> [r.V0.rebuilder_expression x])
1477 | x::xs -> (r.V0.rebuilder_expression x)::(elist r same_dots xs) in
1479 let rec plist r same_dots = function
1482 (match Ast0.unwrap x with
1483 Ast0.MetaParamList(name,lenname,pure) ->
1484 failwith "meta_param_list in iso not supported"
1485 (*match lookup name bindings mv_bindings with
1486 Common.Left(Ast0.DotsParamTag(param)) ->
1487 (match same_dots param with
1489 | None -> failwith "dots put in incompatible context")
1490 | Common.Left(Ast0.ParamTag(param)) -> [param]
1491 | Common.Left(_) -> failwith "not possible 1"
1492 | Common.Right(new_mv) ->
1493 failwith "MetaExprList in SP not supported"*)
1494 | _ -> [r.V0.rebuilder_parameter x])
1495 | x::xs -> (r.V0.rebuilder_parameter x)::(plist r same_dots xs) in
1497 let rec slist r same_dots = function
1500 (match Ast0.unwrap x with
1501 Ast0.MetaStmtList(name,pure) ->
1502 (match lookup name bindings mv_bindings with
1503 Common.Left(Ast0.DotsStmtTag(stm)) ->
1504 (match same_dots stm with
1506 | None -> failwith "dots put in incompatible context")
1507 | Common.Left(Ast0.StmtTag(stm)) -> [stm]
1508 | Common.Left(_) -> failwith "not possible 1"
1509 | Common.Right(new_mv) ->
1510 failwith "MetaExprList in SP not supported")
1511 | _ -> [r.V0.rebuilder_statement x])
1512 | x::xs -> (r.V0.rebuilder_statement x)::(slist r same_dots xs) in
1515 match Ast0.unwrap d with Ast0.DOTS(l) -> Some l |_ -> None in
1516 let same_circles d =
1517 match Ast0.unwrap d with Ast0.CIRCLES(l) -> Some l |_ -> None in
1519 match Ast0.unwrap d with Ast0.STARS(l) -> Some l |_ -> None in
1521 let dots list_fn r k d =
1523 (match Ast0.unwrap d with
1524 Ast0.DOTS(l) -> Ast0.DOTS(list_fn r same_dots l)
1525 | Ast0.CIRCLES(l) -> Ast0.CIRCLES(list_fn r same_circles l)
1526 | Ast0.STARS(l) -> Ast0.STARS(list_fn r same_stars l)) in
1528 let exprfn r k old_e = (* need to keep the original code for ! optim *)
1531 match Ast0.unwrap e with
1532 Ast0.MetaExpr(name,constraints,x,form,pure) ->
1533 (rebuild_mcode None).V0.rebuilder_expression
1534 (match lookup name bindings mv_bindings with
1535 Common.Left(Ast0.ExprTag(exp)) -> exp
1536 | Common.Left(_) -> failwith "not possible 1"
1537 | Common.Right(new_mv) ->
1542 let rec renamer = function
1543 Type_cocci.MetaType(name,keep,inherited) ->
1545 lookup (name,(),(),(),None) bindings mv_bindings
1547 Common.Left(Ast0.TypeCTag(t)) ->
1548 Ast0.ast0_type_to_type t
1550 failwith "iso pattern: unexpected type"
1551 | Common.Right(new_mv) ->
1552 Type_cocci.MetaType(new_mv,keep,inherited))
1553 | Type_cocci.ConstVol(cv,ty) ->
1554 Type_cocci.ConstVol(cv,renamer ty)
1555 | Type_cocci.Pointer(ty) ->
1556 Type_cocci.Pointer(renamer ty)
1557 | Type_cocci.FunctionPointer(ty) ->
1558 Type_cocci.FunctionPointer(renamer ty)
1559 | Type_cocci.Array(ty) ->
1560 Type_cocci.Array(renamer ty)
1562 Some(List.map renamer types) in
1565 (Ast0.set_mcode_data new_mv name,constraints,
1566 new_types,form,pure)))
1567 | Ast0.MetaErr(namea,_,pure) -> failwith "metaerr not supported"
1568 | Ast0.MetaExprList(namea,lenname,pure) ->
1569 failwith "metaexprlist not supported"
1570 | Ast0.Unary(exp,unop) ->
1571 (match Ast0.unwrap_mcode unop with
1574 (* k e doesn't change the outer structure of the term,
1575 only the metavars *)
1576 match Ast0.unwrap old_e with
1577 Ast0.Unary(exp,_) ->
1578 (match Ast0.unwrap exp with
1579 Ast0.MetaExpr(name,constraints,x,form,pure) -> true
1581 | _ -> failwith "not possible" in
1583 let mc = Ast0.get_mcodekind exp in
1589 | Ast0.CONTEXT(x) | Ast0.MIXED(x) ->
1591 (Ast.NOTHING,_,_) -> true
1593 | _ -> failwith "plus not possible" in
1594 if was_meta && nomodif exp && nomodif e
1597 let rec negate e (*for rewrapping*) res (*code to process*) k =
1598 (* k accumulates parens, to keep negation outside if no
1599 propagation is possible *)
1600 match Ast0.unwrap res with
1601 Ast0.Unary(e1,op) when Ast0.unwrap_mcode op = Ast.Not ->
1602 k (Ast0.rewrap e (Ast0.unwrap e1))
1603 | Ast0.Edots(_,_) -> k (Ast0.rewrap e (Ast0.unwrap res))
1604 | Ast0.Paren(lp,e,rp) ->
1607 k (Ast0.rewrap res (Ast0.Paren(lp,x,rp))))
1608 | Ast0.Binary(e1,op,e2) ->
1609 let reb nop = Ast0.rewrap_mcode op (Ast.Logical(nop)) in
1610 let k1 x = k (Ast0.rewrap e x) in
1611 (match Ast0.unwrap_mcode op with
1612 Ast.Logical(Ast.Inf) ->
1613 k1 (Ast0.Binary(e1,reb Ast.SupEq,e2))
1614 | Ast.Logical(Ast.Sup) ->
1615 k1 (Ast0.Binary(e1,reb Ast.InfEq,e2))
1616 | Ast.Logical(Ast.InfEq) ->
1617 k1 (Ast0.Binary(e1,reb Ast.Sup,e2))
1618 | Ast.Logical(Ast.SupEq) ->
1619 k1 (Ast0.Binary(e1,reb Ast.Inf,e2))
1620 | Ast.Logical(Ast.Eq) ->
1621 k1 (Ast0.Binary(e1,reb Ast.NotEq,e2))
1622 | Ast.Logical(Ast.NotEq) ->
1623 k1 (Ast0.Binary(e1,reb Ast.Eq,e2))
1624 | Ast.Logical(Ast.AndLog) ->
1625 k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.OrLog,
1626 negate e2 e2 idcont))
1627 | Ast.Logical(Ast.OrLog) ->
1628 k1 (Ast0.Binary(negate e1 e1 idcont,reb Ast.AndLog,
1629 negate e2 e2 idcont))
1632 (Ast0.Unary(k res,Ast0.rewrap_mcode op Ast.Not)))
1633 | Ast0.DisjExpr(lp,exps,mids,rp) ->
1634 (* use res because it is the transformed argument *)
1635 let exps = List.map (function e -> negate e e k) exps in
1636 Ast0.rewrap res (Ast0.DisjExpr(lp,exps,mids,rp))
1638 (*use e, because this might be the toplevel expression*)
1640 (Ast0.Unary(k res,Ast0.rewrap_mcode unop Ast.Not)) in
1644 | Ast0.Edots(d,_) ->
1646 (match List.assoc (dot_term d) bindings with
1647 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Edots(d,Some exp))
1648 | _ -> failwith "unexpected binding")
1649 with Not_found -> e)
1650 | Ast0.Ecircles(d,_) ->
1652 (match List.assoc (dot_term d) bindings with
1653 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Ecircles(d,Some exp))
1654 | _ -> failwith "unexpected binding")
1655 with Not_found -> e)
1656 | Ast0.Estars(d,_) ->
1658 (match List.assoc (dot_term d) bindings with
1659 Ast0.ExprTag(exp) -> Ast0.rewrap e (Ast0.Estars(d,Some exp))
1660 | _ -> failwith "unexpected binding")
1661 with Not_found -> e)
1663 if Ast0.get_test_exp old_e then Ast0.set_test_exp e1 else e1 in
1667 match Ast0.unwrap e with
1668 Ast0.MetaType(name,pure) ->
1669 (rebuild_mcode None).V0.rebuilder_typeC
1670 (match lookup name bindings mv_bindings with
1671 Common.Left(Ast0.TypeCTag(ty)) -> ty
1672 | Common.Left(_) -> failwith "not possible 1"
1673 | Common.Right(new_mv) ->
1675 (Ast0.MetaType(Ast0.set_mcode_data new_mv name,pure)))
1680 match Ast0.unwrap e with
1683 (match List.assoc (dot_term d) bindings with
1684 Ast0.DeclTag(exp) -> Ast0.rewrap e (Ast0.Ddots(d,Some exp))
1685 | _ -> failwith "unexpected binding")
1686 with Not_found -> e)
1691 match Ast0.unwrap e with
1692 Ast0.MetaParam(name,pure) ->
1693 (rebuild_mcode None).V0.rebuilder_parameter
1694 (match lookup name bindings mv_bindings with
1695 Common.Left(Ast0.ParamTag(param)) -> param
1696 | Common.Left(_) -> failwith "not possible 1"
1697 | Common.Right(new_mv) ->
1699 (Ast0.MetaParam(Ast0.set_mcode_data new_mv name, pure)))
1700 | Ast0.MetaParamList(name,lenname,pure) ->
1701 failwith "metaparamlist not supported"
1706 Ast0.DotsStmtTag(stms) -> Ast0.WhenNot stms
1707 | Ast0.StmtTag(stm) -> Ast0.WhenAlways stm
1708 | Ast0.IsoWhenTTag(stm) -> Ast0.WhenNotTrue stm
1709 | Ast0.IsoWhenFTag(stm) -> Ast0.WhenNotFalse stm
1710 | Ast0.IsoWhenTag(x) -> Ast0.WhenModifier(x)
1711 | _ -> failwith "unexpected binding" in
1715 match Ast0.unwrap e with
1716 Ast0.MetaStmt(name,pure) ->
1717 (rebuild_mcode None).V0.rebuilder_statement
1718 (match lookup name bindings mv_bindings with
1719 Common.Left(Ast0.StmtTag(stm)) -> stm
1720 | Common.Left(_) -> failwith "not possible 1"
1721 | Common.Right(new_mv) ->
1723 (Ast0.MetaStmt(Ast0.set_mcode_data new_mv name,pure)))
1724 | Ast0.MetaStmtList(name,pure) -> failwith "metastmtlist not supported"
1730 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1731 | Ast0.Circles(d,_) ->
1736 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1737 | Ast0.Stars(d,_) ->
1742 (List.filter (function (x,v) -> x = (dot_term d)) bindings)))
1746 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1747 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1748 identfn exprfn tyfn donothing paramfn declfn stmtfn donothing donothing
1750 (* --------------------------------------------------------------------- *)
1753 match Ast0.get_mcodekind e with Ast0.MINUS(cell) -> true | _ -> false
1755 let context_required e = not(is_minus e) && not !Flag.sgrep_mode2
1757 let disj_fail bindings e =
1759 Some x -> Printf.fprintf stderr "no disj available at this type"; e
1762 (* isomorphism code is by default CONTEXT *)
1763 let merge_plus model_mcode e_mcode =
1764 match model_mcode with
1766 (* add the replacement information at the root *)
1770 (match (!mc,!emc) with
1771 (([],_),(x,t)) | ((x,_),([],t)) -> (x,t)
1772 | _ -> failwith "how can we combine minuses?")
1773 | _ -> failwith "not possible 6")
1774 | Ast0.CONTEXT(mc) ->
1776 Ast0.CONTEXT(emc) ->
1777 (* keep the logical line info as in the model *)
1778 let (mba,tb,ta) = !mc in
1779 let (eba,_,_) = !emc in
1780 (* merging may be required when a term is replaced by a subterm *)
1782 match (mba,eba) with
1783 (x,Ast.NOTHING) | (Ast.NOTHING,x) -> x
1784 | (Ast.BEFORE(b1),Ast.BEFORE(b2)) -> Ast.BEFORE(b1@b2)
1785 | (Ast.BEFORE(b),Ast.AFTER(a)) -> Ast.BEFOREAFTER(b,a)
1786 | (Ast.BEFORE(b1),Ast.BEFOREAFTER(b2,a)) ->
1787 Ast.BEFOREAFTER(b1@b2,a)
1788 | (Ast.AFTER(a),Ast.BEFORE(b)) -> Ast.BEFOREAFTER(b,a)
1789 | (Ast.AFTER(a1),Ast.AFTER(a2)) ->Ast.AFTER(a2@a1)
1790 | (Ast.AFTER(a1),Ast.BEFOREAFTER(b,a2)) -> Ast.BEFOREAFTER(b,a2@a1)
1791 | (Ast.BEFOREAFTER(b1,a),Ast.BEFORE(b2)) ->
1792 Ast.BEFOREAFTER(b1@b2,a)
1793 | (Ast.BEFOREAFTER(b,a1),Ast.AFTER(a2)) ->
1794 Ast.BEFOREAFTER(b,a2@a1)
1795 | (Ast.BEFOREAFTER(b1,a1),Ast.BEFOREAFTER(b2,a2)) ->
1796 Ast.BEFOREAFTER(b1@b2,a2@a1) in
1797 emc := (merged,tb,ta)
1798 | Ast0.MINUS(emc) ->
1799 let (anything_bef_aft,_,_) = !mc in
1800 let (anythings,t) = !emc in
1802 (match anything_bef_aft with
1803 Ast.BEFORE(b) -> (b@anythings,t)
1804 | Ast.AFTER(a) -> (anythings@a,t)
1805 | Ast.BEFOREAFTER(b,a) -> (b@anythings@a,t)
1806 | Ast.NOTHING -> (anythings,t))
1807 | _ -> failwith "not possible 7")
1808 | Ast0.MIXED(_) -> failwith "not possible 8"
1809 | Ast0.PLUS -> failwith "not possible 9"
1811 let copy_plus printer minusify model e =
1812 if !Flag.sgrep_mode2
1813 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1816 match Ast0.get_mcodekind model with
1817 Ast0.MINUS(mc) -> minusify e
1818 | Ast0.CONTEXT(mc) -> e
1819 | _ -> failwith "not possible: copy_plus\n" in
1820 merge_plus (Ast0.get_mcodekind model) (Ast0.get_mcodekind e);
1823 let copy_minus printer minusify model e =
1824 match Ast0.get_mcodekind model with
1825 Ast0.MINUS(mc) -> minusify e
1826 | Ast0.CONTEXT(mc) -> e
1828 if !Flag.sgrep_mode2
1830 else failwith "not possible 8"
1831 | Ast0.PLUS -> failwith "not possible 9"
1833 let whencode_allowed prev_ecount prev_icount prev_dcount
1834 ecount icount dcount rest =
1835 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1837 let other_ecount = (* number of edots *)
1838 List.fold_left (function rest -> function (_,ec,ic,dc) -> ec + rest)
1840 let other_icount = (* number of dots *)
1841 List.fold_left (function rest -> function (_,ec,ic,dc) -> ic + rest)
1843 let other_dcount = (* number of dots *)
1844 List.fold_left (function rest -> function (_,ec,ic,dc) -> dc + rest)
1846 (ecount = 0 or other_ecount = 0, icount = 0 or other_icount = 0,
1847 dcount = 0 or other_dcount = 0)
1849 (* copy the befores and afters to the instantiated code *)
1850 let extra_copy_stmt_plus model e =
1851 (if not !Flag.sgrep_mode2 (* sgrep has no plus code, so nothing to do *)
1853 (match Ast0.unwrap model with
1854 Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
1855 | Ast0.Decl((info,bef),_) ->
1856 (match Ast0.unwrap e with
1857 Ast0.FunDecl((info,bef1),_,_,_,_,_,_,_,_)
1858 | Ast0.Decl((info,bef1),_) ->
1860 | _ -> merge_plus bef (Ast0.get_mcodekind e))
1861 | Ast0.IfThen(_,_,_,_,_,(info,aft))
1862 | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
1863 | Ast0.While(_,_,_,_,_,(info,aft))
1864 | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft))
1865 | Ast0.Iterator(_,_,_,_,_,(info,aft)) ->
1866 (match Ast0.unwrap e with
1867 Ast0.IfThen(_,_,_,_,_,(info,aft1))
1868 | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft1))
1869 | Ast0.While(_,_,_,_,_,(info,aft1))
1870 | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft1))
1871 | Ast0.Iterator(_,_,_,_,_,(info,aft1)) ->
1873 | _ -> merge_plus aft (Ast0.get_mcodekind e))
1877 let extra_copy_other_plus model e = e
1879 (* --------------------------------------------------------------------- *)
1881 let mv_count = ref 0
1883 let ct = !mv_count in
1884 mv_count := !mv_count + 1;
1885 "_"^s^"_"^(string_of_int ct)
1887 let get_name = function
1888 Ast.MetaIdDecl(ar,nm) ->
1889 (nm,function nm -> Ast.MetaIdDecl(ar,nm))
1890 | Ast.MetaFreshIdDecl(ar,nm) ->
1891 (nm,function nm -> Ast.MetaFreshIdDecl(ar,nm))
1892 | Ast.MetaTypeDecl(ar,nm) ->
1893 (nm,function nm -> Ast.MetaTypeDecl(ar,nm))
1894 | Ast.MetaListlenDecl(nm) ->
1895 failwith "should not be rebuilt"
1896 | Ast.MetaParamDecl(ar,nm) ->
1897 (nm,function nm -> Ast.MetaParamDecl(ar,nm))
1898 | Ast.MetaParamListDecl(ar,nm,nm1) ->
1899 (nm,function nm -> Ast.MetaParamListDecl(ar,nm,nm1))
1900 | Ast.MetaConstDecl(ar,nm,ty) ->
1901 (nm,function nm -> Ast.MetaConstDecl(ar,nm,ty))
1902 | Ast.MetaErrDecl(ar,nm) ->
1903 (nm,function nm -> Ast.MetaErrDecl(ar,nm))
1904 | Ast.MetaExpDecl(ar,nm,ty) ->
1905 (nm,function nm -> Ast.MetaExpDecl(ar,nm,ty))
1906 | Ast.MetaIdExpDecl(ar,nm,ty) ->
1907 (nm,function nm -> Ast.MetaIdExpDecl(ar,nm,ty))
1908 | Ast.MetaLocalIdExpDecl(ar,nm,ty) ->
1909 (nm,function nm -> Ast.MetaLocalIdExpDecl(ar,nm,ty))
1910 | Ast.MetaExpListDecl(ar,nm,nm1) ->
1911 (nm,function nm -> Ast.MetaExpListDecl(ar,nm,nm1))
1912 | Ast.MetaStmDecl(ar,nm) ->
1913 (nm,function nm -> Ast.MetaStmDecl(ar,nm))
1914 | Ast.MetaStmListDecl(ar,nm) ->
1915 (nm,function nm -> Ast.MetaStmListDecl(ar,nm))
1916 | Ast.MetaFuncDecl(ar,nm) ->
1917 (nm,function nm -> Ast.MetaFuncDecl(ar,nm))
1918 | Ast.MetaLocalFuncDecl(ar,nm) ->
1919 (nm,function nm -> Ast.MetaLocalFuncDecl(ar,nm))
1920 | Ast.MetaPosDecl(ar,nm) ->
1921 (nm,function nm -> Ast.MetaPosDecl(ar,nm))
1922 | Ast.MetaDeclarerDecl(ar,nm) ->
1923 (nm,function nm -> Ast.MetaDeclarerDecl(ar,nm))
1924 | Ast.MetaIteratorDecl(ar,nm) ->
1925 (nm,function nm -> Ast.MetaIteratorDecl(ar,nm))
1927 let make_new_metavars metavars bindings =
1931 let (s,_) = get_name mv in
1932 try let _ = List.assoc s bindings in false with Not_found -> true)
1937 let (s,rebuild) = get_name mv in
1938 let new_s = (!current_rule,new_mv s) in
1939 (rebuild new_s, (s,new_s)))
1942 (* --------------------------------------------------------------------- *)
1944 let do_nothing x = x
1946 let mkdisj matcher metavars alts e instantiater mkiso disj_maker minusify
1947 rebuild_mcodes name printer extra_plus update_others =
1948 let call_instantiate bindings mv_bindings alts =
1951 (function (a,_,_,_) ->
1953 (* no need to create duplicates when the bindings have no effect *)
1955 (function bindings ->
1957 (copy_plus printer minusify e
1959 (instantiater bindings mv_bindings
1960 (rebuild_mcodes a))))
1961 (Common.union_set [(name,mkiso a)] (Ast0.get_iso e)))
1964 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount = function
1965 [] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
1966 | ((pattern,ecount,icount,dcount)::rest) ->
1968 whencode_allowed prev_ecount prev_icount prev_dcount
1969 ecount dcount icount rest in
1970 (match matcher true (context_required e) wc pattern e init_env with
1972 if reason = NonMatch || not !Flag_parsing_cocci.show_iso_failures
1975 (match matcher false false wc pattern e init_env with
1977 interpret_reason name (Ast0.get_line e) reason
1978 (function () -> printer e)
1980 inner_loop all_alts (prev_ecount + ecount) (prev_icount + icount)
1981 (prev_dcount + dcount) rest
1982 | OK (bindings : (((string * string) * 'a) list list)) ->
1984 (* apply update_others to all patterns other than the matched
1985 one. This is used to desigate the others as test
1986 expressions in the TestExpression case *)
1988 (function (x,e,i,d) as all ->
1991 else (update_others x,e,i,d))
1992 (List.hd all_alts)) ::
1994 (List.map (function (x,e,i,d) -> (update_others x,e,i,d)))
1995 (List.tl all_alts)) in
1996 (match List.concat all_alts with
1997 [x] -> Common.Left (prev_ecount, prev_icount, prev_dcount)
1999 let (new_metavars,mv_bindings) =
2000 make_new_metavars metavars (nub(List.concat bindings)) in
2003 call_instantiate bindings mv_bindings all_alts))) in
2004 let rec outer_loop prev_ecount prev_icount prev_dcount = function
2005 [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *)
2006 | (alts::rest) as all_alts ->
2007 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts with
2008 Common.Left(prev_ecount, prev_icount, prev_dcount) ->
2009 outer_loop prev_ecount prev_icount prev_dcount rest
2010 | Common.Right (new_metavars,res) ->
2012 copy_minus printer minusify e (disj_maker res)) in
2013 outer_loop 0 0 0 alts
2015 (* no one should ever look at the information stored in these mcodes *)
2016 let disj_starter lst =
2017 let old_info = Ast0.get_info(List.hd lst) in
2020 Ast0.line_end = old_info.Ast0.line_start;
2021 Ast0.logical_end = old_info.Ast0.logical_start;
2022 Ast0.attachable_start = false; Ast0.attachable_end = false;
2023 Ast0.mcode_start = []; Ast0.mcode_end = [];
2024 Ast0.strings_before = []; Ast0.strings_after = [] } in
2025 Ast0.make_mcode_info "(" info
2027 let disj_ender lst =
2028 let old_info = Ast0.get_info(List.hd lst) in
2031 Ast0.line_start = old_info.Ast0.line_end;
2032 Ast0.logical_start = old_info.Ast0.logical_end;
2033 Ast0.attachable_start = false; Ast0.attachable_end = false;
2034 Ast0.mcode_start = []; Ast0.mcode_end = [];
2035 Ast0.strings_before = []; Ast0.strings_after = [] } in
2036 Ast0.make_mcode_info ")" info
2038 let disj_mid _ = Ast0.make_mcode "|"
2040 let make_disj_type tl =
2043 [] -> failwith "bad disjunction"
2044 | x::xs -> List.map disj_mid xs in
2045 Ast0.context_wrap (Ast0.DisjType(disj_starter tl,tl,mids,disj_ender tl))
2046 let make_disj_stmt_list tl =
2049 [] -> failwith "bad disjunction"
2050 | x::xs -> List.map disj_mid xs in
2051 Ast0.context_wrap (Ast0.Disj(disj_starter tl,tl,mids,disj_ender tl))
2052 let make_disj_expr model el =
2055 [] -> failwith "bad disjunction"
2056 | x::xs -> List.map disj_mid xs in
2058 if Ast0.get_arg_exp model then Ast0.set_arg_exp x else x in
2060 let x = if Ast0.get_test_pos model then Ast0.set_test_pos x else x in
2061 if Ast0.get_test_exp model then Ast0.set_test_exp x else x in
2062 let el = List.map update_arg (List.map update_test el) in
2063 Ast0.context_wrap (Ast0.DisjExpr(disj_starter el,el,mids,disj_ender el))
2064 let make_disj_decl dl =
2067 [] -> failwith "bad disjunction"
2068 | x::xs -> List.map disj_mid xs in
2069 Ast0.context_wrap (Ast0.DisjDecl(disj_starter dl,dl,mids,disj_ender dl))
2070 let make_disj_stmt sl =
2071 let dotify x = Ast0.context_wrap (Ast0.DOTS[x]) in
2074 [] -> failwith "bad disjunction"
2075 | x::xs -> List.map disj_mid xs in
2077 (Ast0.Disj(disj_starter sl,List.map dotify sl,mids,disj_ender sl))
2079 let transform_type (metavars,alts,name) e =
2081 (Ast0.TypeCTag(_)::_)::_ ->
2082 (* start line is given to any leaves in the iso code *)
2083 let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
2089 (p,count_edots.V0.combiner_typeC p,
2090 count_idots.V0.combiner_typeC p,
2091 count_dots.V0.combiner_typeC p)
2092 | _ -> failwith "invalid alt"))
2094 mkdisj match_typeC metavars alts e
2095 (function b -> function mv_b ->
2096 (instantiate b mv_b).V0.rebuilder_typeC)
2097 (function t -> Ast0.TypeCTag t)
2098 make_disj_type make_minus.V0.rebuilder_typeC
2099 (rebuild_mcode start_line).V0.rebuilder_typeC
2100 name Unparse_ast0.typeC extra_copy_other_plus do_nothing
2104 let transform_expr (metavars,alts,name) e =
2105 let process update_others =
2106 (* start line is given to any leaves in the iso code *)
2107 let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
2112 Ast0.ExprTag(p) | Ast0.ArgExprTag(p) | Ast0.TestExprTag(p) ->
2113 (p,count_edots.V0.combiner_expression p,
2114 count_idots.V0.combiner_expression p,
2115 count_dots.V0.combiner_expression p)
2116 | _ -> failwith "invalid alt"))
2118 mkdisj match_expr metavars alts e
2119 (function b -> function mv_b ->
2120 (instantiate b mv_b).V0.rebuilder_expression)
2121 (function e -> Ast0.ExprTag e)
2123 make_minus.V0.rebuilder_expression
2124 (rebuild_mcode start_line).V0.rebuilder_expression
2125 name Unparse_ast0.expression extra_copy_other_plus update_others in
2127 (Ast0.ExprTag(_)::_)::_ -> process do_nothing
2128 | (Ast0.ArgExprTag(_)::_)::_ when Ast0.get_arg_exp e -> process do_nothing
2129 | (Ast0.TestExprTag(_)::_)::_ when Ast0.get_test_pos e ->
2130 process Ast0.set_test_exp
2133 let transform_decl (metavars,alts,name) e =
2135 (Ast0.DeclTag(_)::_)::_ ->
2136 (* start line is given to any leaves in the iso code *)
2137 let start_line = Some (Ast0.get_info e).Ast0.line_start in
2143 (p,count_edots.V0.combiner_declaration p,
2144 count_idots.V0.combiner_declaration p,
2145 count_dots.V0.combiner_declaration p)
2146 | _ -> failwith "invalid alt"))
2148 mkdisj match_decl metavars alts e
2149 (function b -> function mv_b ->
2150 (instantiate b mv_b).V0.rebuilder_declaration)
2151 (function d -> Ast0.DeclTag d)
2153 make_minus.V0.rebuilder_declaration
2154 (rebuild_mcode start_line).V0.rebuilder_declaration
2155 name Unparse_ast0.declaration extra_copy_other_plus do_nothing
2158 let transform_stmt (metavars,alts,name) e =
2160 (Ast0.StmtTag(_)::_)::_ ->
2161 (* start line is given to any leaves in the iso code *)
2162 let start_line = Some (Ast0.get_info e).Ast0.line_start in
2168 (p,count_edots.V0.combiner_statement p,
2169 count_idots.V0.combiner_statement p,
2170 count_dots.V0.combiner_statement p)
2171 | _ -> failwith "invalid alt"))
2173 mkdisj match_statement metavars alts e
2174 (function b -> function mv_b ->
2175 (instantiate b mv_b).V0.rebuilder_statement)
2176 (function s -> Ast0.StmtTag s)
2177 make_disj_stmt make_minus.V0.rebuilder_statement
2178 (rebuild_mcode start_line).V0.rebuilder_statement
2179 name (Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2182 (* sort of a hack, because there is no disj at top level *)
2183 let transform_top (metavars,alts,name) e =
2184 match Ast0.unwrap e with
2185 Ast0.DECL(declstm) ->
2191 Ast0.DotsStmtTag(d) ->
2192 (match Ast0.unwrap d with
2193 Ast0.DOTS([s]) -> Ast0.StmtTag(s)
2194 | _ -> raise (Failure ""))
2195 | _ -> raise (Failure "")))
2197 let (mv,s) = transform_stmt (metavars,strip alts,name) declstm in
2198 (mv,Ast0.rewrap e (Ast0.DECL(s)))
2199 with Failure _ -> ([],e))
2200 | Ast0.CODE(stmts) ->
2203 (Ast0.DotsStmtTag(_)::_)::_ ->
2204 (* start line is given to any leaves in the iso code *)
2205 let start_line = Some ((Ast0.get_info e).Ast0.line_start) in
2210 Ast0.DotsStmtTag(p) ->
2211 (p,count_edots.V0.combiner_statement_dots p,
2212 count_idots.V0.combiner_statement_dots p,
2213 count_dots.V0.combiner_statement_dots p)
2214 | _ -> failwith "invalid alt"))
2216 mkdisj match_statement_dots metavars alts stmts
2217 (function b -> function mv_b ->
2218 (instantiate b mv_b).V0.rebuilder_statement_dots)
2219 (function s -> Ast0.DotsStmtTag s)
2221 Ast0.rewrap e (Ast0.DOTS([make_disj_stmt_list x])))
2223 make_minus.V0.rebuilder_statement_dots x)
2224 (rebuild_mcode start_line).V0.rebuilder_statement_dots
2225 name Unparse_ast0.statement_dots extra_copy_other_plus do_nothing
2226 | _ -> ([],stmts) in
2227 (mv,Ast0.rewrap e (Ast0.CODE res))
2230 (* --------------------------------------------------------------------- *)
2232 let transform (alts : isomorphism) t =
2233 (* the following ugliness is because rebuilder only returns a new term *)
2234 let extra_meta_decls = ref ([] : Ast_cocci.metavar list) in
2236 let donothing r k e = k e in
2238 let (extra_meta,exp) = transform_expr alts (k e) in
2239 extra_meta_decls := extra_meta @ !extra_meta_decls;
2243 let (extra_meta,dec) = transform_decl alts (k e) in
2244 extra_meta_decls := extra_meta @ !extra_meta_decls;
2248 let (extra_meta,stm) = transform_stmt alts (k e) in
2249 extra_meta_decls := extra_meta @ !extra_meta_decls;
2254 match Ast0.unwrap e with
2255 Ast0.Signed(signb,tyb) ->
2256 (* Hack! How else to prevent iso from applying under an
2260 let (extra_meta,ty) = transform_type alts continue in
2261 extra_meta_decls := extra_meta @ !extra_meta_decls;
2265 let (extra_meta,ty) = transform_top alts (k e) in
2266 extra_meta_decls := extra_meta @ !extra_meta_decls;
2271 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2272 donothing donothing donothing donothing donothing donothing
2273 donothing exprfn typefn donothing donothing declfn stmtfn
2275 let res = res.V0.rebuilder_top_level t in
2276 (!extra_meta_decls,res)
2278 (* --------------------------------------------------------------------- *)
2280 (* should be done by functorizing the parser to use wrap or context_wrap *)
2282 let mcode (x,a,i,mc,pos) = (x,a,i,Ast0.context_befaft(),pos) in
2283 let donothing r k e = Ast0.context_wrap(Ast0.unwrap(k e)) in
2285 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2286 donothing donothing donothing donothing donothing donothing
2287 donothing donothing donothing donothing donothing donothing donothing
2290 let rewrap_anything = function
2291 Ast0.DotsExprTag(d) ->
2292 Ast0.DotsExprTag(rewrap.V0.rebuilder_expression_dots d)
2293 | Ast0.DotsInitTag(d) ->
2294 Ast0.DotsInitTag(rewrap.V0.rebuilder_initialiser_list d)
2295 | Ast0.DotsParamTag(d) ->
2296 Ast0.DotsParamTag(rewrap.V0.rebuilder_parameter_list d)
2297 | Ast0.DotsStmtTag(d) ->
2298 Ast0.DotsStmtTag(rewrap.V0.rebuilder_statement_dots d)
2299 | Ast0.DotsDeclTag(d) ->
2300 Ast0.DotsDeclTag(rewrap.V0.rebuilder_declaration_dots d)
2301 | Ast0.DotsCaseTag(d) ->
2302 Ast0.DotsCaseTag(rewrap.V0.rebuilder_case_line_dots d)
2303 | Ast0.IdentTag(d) -> Ast0.IdentTag(rewrap.V0.rebuilder_ident d)
2304 | Ast0.ExprTag(d) -> Ast0.ExprTag(rewrap.V0.rebuilder_expression d)
2305 | Ast0.ArgExprTag(d) -> Ast0.ArgExprTag(rewrap.V0.rebuilder_expression d)
2306 | Ast0.TestExprTag(d) -> Ast0.TestExprTag(rewrap.V0.rebuilder_expression d)
2307 | Ast0.TypeCTag(d) -> Ast0.TypeCTag(rewrap.V0.rebuilder_typeC d)
2308 | Ast0.InitTag(d) -> Ast0.InitTag(rewrap.V0.rebuilder_initialiser d)
2309 | Ast0.ParamTag(d) -> Ast0.ParamTag(rewrap.V0.rebuilder_parameter d)
2310 | Ast0.DeclTag(d) -> Ast0.DeclTag(rewrap.V0.rebuilder_declaration d)
2311 | Ast0.StmtTag(d) -> Ast0.StmtTag(rewrap.V0.rebuilder_statement d)
2312 | Ast0.CaseLineTag(d) -> Ast0.CaseLineTag(rewrap.V0.rebuilder_case_line d)
2313 | Ast0.TopTag(d) -> Ast0.TopTag(rewrap.V0.rebuilder_top_level d)
2314 | Ast0.IsoWhenTag(_) | Ast0.IsoWhenTTag(_) | Ast0.IsoWhenFTag(_) ->
2315 failwith "only for isos within iso phase"
2316 | Ast0.MetaPosTag(p) -> Ast0.MetaPosTag(p)
2318 (* --------------------------------------------------------------------- *)
2320 let apply_isos isos rule rule_name =
2325 current_rule := rule_name;
2328 (function (metavars,iso,name) ->
2329 (metavars,List.map (List.map rewrap_anything) iso,name))
2331 let (extra_meta,rule) =
2336 (function (extra_meta,t) -> function iso ->
2337 let (new_extra_meta,t) = transform iso t in
2338 (new_extra_meta@extra_meta,t))
2341 (List.concat extra_meta, Compute_lines.compute_lines rule)