2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
27 (* Potential problem: offset of mcode is not updated when an iso is
28 instantiated, implying that a term may end up with many mcodes with the
29 same offset. On the other hand, at the moment offset only seems to be used
30 before this phase. Furthermore add_dot_binding relies on the offset to
31 remain the same between matching an iso and instantiating it with bindings. *)
33 (* Consider whether ... in iso should match <... ...> in smpl? *)
35 (* --------------------------------------------------------------------- *)
36 (* match a SmPL expression against a SmPL abstract syntax tree,
39 module Ast
= Ast_cocci
40 module Ast0
= Ast0_cocci
41 module V0
= Visitor_ast0
42 module VT0
= Visitor_ast0_types
44 let current_rule = ref ""
46 (* --------------------------------------------------------------------- *)
49 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
52 let mcode (term
,_
,_
,_
,_
,_
) =
53 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
57 {(Ast0.wrap
(Ast0.unwrap
x)) with
58 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
59 Ast0.true_if_test
= x.Ast0.true_if_test
} in
61 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
62 donothing donothing donothing donothing donothing donothing
63 donothing donothing donothing donothing donothing donothing donothing
66 let anything_equal = function
67 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
68 failwith
"not a possible variable binding" (*not sure why these are pbs*)
69 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
70 failwith
"not a possible variable binding"
71 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
72 failwith
"not a possible variable binding"
73 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
74 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
75 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
76 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
77 failwith
"not a possible variable binding"
78 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
79 failwith
"not a possible variable binding"
80 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
81 (strip_info.VT0.rebuilder_rec_ident d1
) =
82 (strip_info.VT0.rebuilder_rec_ident d2
)
83 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
84 (strip_info.VT0.rebuilder_rec_expression d1
) =
85 (strip_info.VT0.rebuilder_rec_expression d2
)
86 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
87 failwith
"not possible - only in isos1"
88 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
89 failwith
"not possible - only in isos1"
90 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
91 (strip_info.VT0.rebuilder_rec_typeC d1
) =
92 (strip_info.VT0.rebuilder_rec_typeC d2
)
93 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
94 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
95 (strip_info.VT0.rebuilder_rec_initialiser d2
)
96 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
97 (strip_info.VT0.rebuilder_rec_parameter d1
) =
98 (strip_info.VT0.rebuilder_rec_parameter d2
)
99 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
100 (strip_info.VT0.rebuilder_rec_declaration d1
) =
101 (strip_info.VT0.rebuilder_rec_declaration d2
)
102 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
103 (strip_info.VT0.rebuilder_rec_statement d1
) =
104 (strip_info.VT0.rebuilder_rec_statement d2
)
105 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
106 (strip_info.VT0.rebuilder_rec_case_line d1
) =
107 (strip_info.VT0.rebuilder_rec_case_line d2
)
108 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
109 (strip_info.VT0.rebuilder_rec_top_level d1
) =
110 (strip_info.VT0.rebuilder_rec_top_level d2
)
111 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
112 failwith
"only for isos within iso phase"
113 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
114 failwith
"only for isos within iso phase"
115 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
116 failwith
"only for isos within iso phase"
119 let term (var1
,_
,_
,_
,_
,_
) = var1
120 let dot_term (var1
,_
,info
,_
,_
,_
) =
121 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
125 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
126 | NotPureLength
of Ast.meta_name
127 | ContextRequired
of Ast0.anything
129 | Braces
of Ast0.statement
130 | Nest
of Ast0.statement
131 | Position
of Ast.meta_name
132 | TypeMatch
of reason list
134 let rec interpret_reason name line reason printer
=
136 "warning: iso %s does not match the code below on line %d\n" name line
;
137 printer
(); Format.print_newline
();
139 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
141 "pure metavariable %s is matched against the following nonpure code:\n"
143 Unparse_ast0.unparse_anything nonpure
144 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
146 "context metavariable %s is matched against the following\nnoncontext code:\n"
148 Unparse_ast0.unparse_anything nonpure
149 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
151 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
153 Unparse_ast0.unparse_anything nonpure
154 | NotPureLength
((_
,var
)) ->
156 "pure metavariable %s is matched against too much or too little code\n"
158 | ContextRequired
(term) ->
160 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
161 Unparse_ast0.unparse_anything
term
163 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
164 Unparse_ast0.statement
"" s
;
165 Format.print_newline
()
167 Printf.printf
"iso with nest doesn't match whencode (TODO):\n";
168 Unparse_ast0.statement
"" s
;
169 Format.print_newline
()
170 | Position
(rule
,name
) ->
171 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
173 | TypeMatch reason_list
->
174 List.iter
(function r
-> interpret_reason name line r printer
)
176 | _
-> failwith
"not possible"
178 type 'a either
= OK
of 'a
| Fail
of reason
180 let add_binding var exp bindings
=
181 let var = term var in
182 let attempt bindings
=
184 let cur = List.assoc
var bindings
in
185 if anything_equal(exp
,cur) then [bindings
] else []
186 with Not_found
-> [((var,exp
)::bindings
)] in
187 match List.concat
(List.map
attempt bindings
) with
191 let add_dot_binding var exp bindings
=
192 let var = dot_term var in
193 let attempt bindings
=
195 let cur = List.assoc
var bindings
in
196 if anything_equal(exp
,cur) then [bindings
] else []
197 with Not_found
-> [((var,exp
)::bindings
)] in
198 match List.concat
(List.map
attempt bindings
) with
203 let add_multi_dot_binding var exp bindings
=
204 let var = dot_term var in
205 let attempt bindings
= [((var,exp
)::bindings
)] in
206 match List.concat
(List.map
attempt bindings
) with
213 | (x::xs
) when (List.mem
x xs
) -> nub xs
214 | (x::xs
) -> x::(nub xs
)
216 (* --------------------------------------------------------------------- *)
220 let debug str m binding
=
221 let res = m binding
in
223 None
-> Printf.printf
"%s: failed\n" str
227 Printf.printf
"%s: %s\n" str
228 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
232 let conjunct_bindings
233 (m1
: 'binding
-> 'binding either
)
234 (m2
: 'binding
-> 'binding either
)
235 (binding
: 'binding
) : 'binding either
=
236 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
238 let rec conjunct_many_bindings = function
239 [] -> failwith
"not possible"
241 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
243 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
245 let return b binding
= if b
then OK binding
else Fail NonMatch
246 let return_false reason binding
= Fail reason
248 let match_option f t1 t2
=
250 (Some t1
, Some t2
) -> f t1 t2
251 | (None
, None
) -> return true
254 let bool_match_option f t1 t2
=
256 (Some t1
, Some t2
) -> f t1 t2
257 | (None
, None
) -> true
260 (* context_required is for the example
264 where we can't change x == NULL to eg NULL == x. So there can either be
265 nothing attached to the root or the term has to be all removed.
266 if would be nice if we knew more about the relationship between the - and +
267 code, because in the case where the + code is a separate statement in a
268 sequence, this is not a problem. Perhaps something could be done in
271 The example seems strange. Why isn't the cast attached to x?
274 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
275 (match Ast0.get_mcodekind e
with
276 Ast0.CONTEXT
(cell
) -> true
279 (* needs a special case when there is a Disj or an empty DOTS
280 the following stops at the statement level, and gives true if one
281 statement is replaced by another *)
282 let rec is_pure_context s
=
283 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
284 (match Ast0.unwrap s
with
285 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
288 match Ast0.undots
x with
289 [s
] -> is_pure_context s
290 | _
-> false (* could we do better? *))
293 (match Ast0.get_mcodekind s
with
296 (Ast.NOTHING
,_
,_
) -> true
300 (* do better for the common case of replacing a stmt by another one *)
301 (Ast.REPLACEMENT
([[Ast.StatementTag
(s
)]],_
),_
) ->
302 (match Ast.unwrap s
with
303 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
309 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
311 let match_list matcher is_list_matcher do_list_match la lb
=
312 let rec loop = function
313 ([],[]) -> return true
314 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
315 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
316 | _
-> return false in
319 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
321 let match_maker checks_needed context_required whencode_allowed
=
323 let check_mcode pmc
(*pattern*) cmc
(*code*) binding
=
326 match Ast0.get_pos cmc
with
327 [] -> OK binding
(* no hidden vars in smpl code, so nothing to do *)
328 | ((a
::_
) as hidden_code
) ->
330 List.filter
(function Ast0.HiddenVarTag _
-> true | _
-> false)
331 (Ast0.get_pos pmc
) in
332 (match hidden_pattern with
333 [Ast0.HiddenVarTag
([Ast0.MetaPosTag
(Ast0.MetaPos
(name1
,_
,_
))])] ->
334 add_binding name1
(Ast0.HiddenVarTag
(hidden_code
)) binding
335 | [] -> Fail
(Position
(Ast0.unwrap_mcode
(Ast0.meta_pos_name a
)))
336 | _
-> failwith
"badly compiled iso - multiple hidden variable")
339 let match_dots matcher is_list_matcher do_list_match d1 d2
=
340 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
341 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
342 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
343 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
344 match_list matcher is_list_matcher
(do_list_match d2
) la lb
345 | _
-> return false in
347 let is_elist_matcher el
=
348 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
350 let is_plist_matcher pl
=
351 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
353 let is_slist_matcher pl
=
354 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
356 let no_list _
= false in
358 let build_dots pattern data
=
359 match Ast0.unwrap pattern
with
360 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
361 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
362 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
365 let bind = Ast0.lub_pure
in
366 let option_default = Ast0.Context
in
367 let pure_mcodekind mc
=
369 then Ast0.PureContext
374 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
378 (Ast.NOREPLACEMENT
,_
) -> Ast0.Pure
380 | _
-> Ast0.Impure
in
381 let donothing r k e
=
382 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
384 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
386 (* a case for everything that has a metavariable *)
387 (* pure is supposed to match only unitary metavars, not anything that
388 contains only unitary metavars *)
390 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
391 (match Ast0.unwrap i
with
392 Ast0.MetaId
(name
,_
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
393 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
394 | _
-> Ast0.Impure
) in
396 let expression r k e
=
397 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
398 (match Ast0.unwrap e
with
399 Ast0.MetaErr
(name
,_
,pure
)
400 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
402 | _
-> Ast0.Impure
) in
405 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
406 (match Ast0.unwrap t
with
407 Ast0.MetaType
(name
,pure
) -> pure
408 | _
-> Ast0.Impure
) in
411 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
412 (match Ast0.unwrap t
with
413 Ast0.MetaInit
(name
,pure
) | Ast0.MetaInitList
(name
,_
,pure
) -> pure
414 | _
-> Ast0.Impure
) in
417 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
418 (match Ast0.unwrap p
with
419 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
420 | _
-> Ast0.Impure
) in
423 bind (bind (pure_mcodekind (Ast0.get_mcodekind d
)) (k d
))
424 (match Ast0.unwrap d
with
425 Ast0.MetaDecl
(name
,pure
) | Ast0.MetaField
(name
,pure
)
426 | Ast0.MetaFieldList
(name
,_
,pure
) ->
428 | _
-> Ast0.Impure
) in
431 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
432 (match Ast0.unwrap s
with
433 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
434 | _
-> Ast0.Impure
) in
436 V0.flat_combiner
bind option_default
437 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
438 donothing donothing donothing donothing donothing donothing
439 ident expression typeC init param decl stmt donothing
442 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
443 match (checks_needed
,pure
) with
444 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
447 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
448 then add_binding name
(builder1 lst
)
449 else return_false (NotPure
(pure
,term name
,builder1 lst
))
450 | _
-> return_false (NotPureLength
(term name
)))
451 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
453 let add_pure_binding name pure is_pure builder
x =
454 match (checks_needed
,pure
) with
455 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
456 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
457 then add_binding name
(builder
x)
458 else return_false (NotPure
(pure
,term name
, builder
x))
459 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
461 let do_elist_match builder el lst
=
462 match Ast0.unwrap el
with
463 Ast0.MetaExprList
(name
,lenname
,pure
) ->
464 (*how to handle lenname? should it be an option type and always None?*)
465 failwith
"expr list pattern not supported in iso"
466 (*add_pure_list_binding name pure
467 pure_sp_code.V0.combiner_expression
468 (function lst -> Ast0.ExprTag(List.hd lst))
469 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
471 | _
-> failwith
"not possible" in
473 let do_plist_match builder pl lst
=
474 match Ast0.unwrap pl
with
475 Ast0.MetaParamList
(name
,lename
,pure
) ->
476 failwith
"param list pattern not supported in iso"
477 (*add_pure_list_binding name pure
478 pure_sp_code.V0.combiner_parameter
479 (function lst -> Ast0.ParamTag(List.hd lst))
480 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
482 | _
-> failwith
"not possible" in
484 let do_slist_match builder sl lst
=
485 match Ast0.unwrap sl
with
486 Ast0.MetaStmtList
(name
,pure
) ->
487 add_pure_list_binding name pure
488 pure_sp_code.VT0.combiner_rec_statement
489 (function lst
-> Ast0.StmtTag
(List.hd lst
))
490 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
492 | _
-> failwith
"not possible" in
494 let do_nolist_match _ _
= failwith
"not possible" in
496 let rec match_ident pattern id
=
497 match Ast0.unwrap pattern
with
498 Ast0.MetaId
(name
,_
,_
,pure
) ->
499 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
500 (function id
-> Ast0.IdentTag id
) id
)
501 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
502 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
504 if not
(checks_needed
) or not
(context_required
) or is_context id
506 match (up
,Ast0.unwrap id
) with
507 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
508 if mcode_equal namea nameb
509 then check_mcode namea nameb
511 | (Ast0.DisjId
(_
,ids
,_
,_
),_
) ->
512 failwith
"not allowed in the pattern of an isomorphism"
513 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
514 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
516 | (_
,Ast0.OptIdent
(idb
))
517 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
519 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
521 (* should we do something about matching metavars against ...? *)
522 let rec match_expr pattern expr
=
523 match Ast0.unwrap pattern
with
524 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
526 match (form
,expr
) with
530 match Ast0.unwrap e
with
531 Ast0.Constant
(c
) -> true
533 (match Ast0.unwrap c
with
535 let nm = Ast0.unwrap_mcode
nm in
536 (* all caps is a const *)
537 Str.string_match
all_caps nm 0
539 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
540 | Ast0.SizeOfExpr
(se
,exp
) -> true
541 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
542 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
543 (Ast0.lub_pure p pure
) = pure
546 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
548 match Ast0.unwrap e
with
549 Ast0.Ident
(c
) -> true
550 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
551 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
552 (Ast0.lub_pure p pure
) = pure
560 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
564 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
566 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
567 (* easier than updating type inferencer to manage multiple
569 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
570 | (_
,Some ty
) -> Some
[ty
]
574 let tyname = Ast0.rewrap_mcode name
tyname in
576 (add_pure_binding name pure
577 pure_sp_code.VT0.combiner_rec_expression
578 (function expr
-> Ast0.ExprTag expr
)
580 (function bindings
->
585 add_pure_binding tyname Ast0.Impure
586 (function _
-> Ast0.Impure
)
587 (function ty
-> Ast0.TypeCTag ty
)
589 (Ast0.reverse_type
expty))
593 "warning: unconvertible type";
594 return false bindings
))
597 (function Fail _
-> false | OK
x -> true)
600 (* not sure why this is ok. can there be more
604 (function Fail _
-> [] | OK
x -> x)
612 | OK
x -> failwith
"not possible")
616 "warning: type metavar can only match one type";*)
620 "mixture of metatype and other types not supported")
622 let expty = Ast0.get_type expr
in
623 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
625 add_pure_binding name pure
626 pure_sp_code.VT0.combiner_rec_expression
627 (function expr
-> Ast0.ExprTag expr
)
631 add_pure_binding name pure
632 pure_sp_code.VT0.combiner_rec_expression
633 (function expr
-> Ast0.ExprTag expr
)
636 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
637 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
639 if not
(checks_needed
) or not
(context_required
) or is_context expr
641 match (up
,Ast0.unwrap expr
) with
642 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
644 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
645 if mcode_equal consta constb
646 then check_mcode consta constb
648 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
649 conjunct_many_bindings
650 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
651 match_dots match_expr is_elist_matcher do_elist_match
653 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
654 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
655 if mcode_equal opa opb
657 conjunct_many_bindings
658 [check_mcode opa opb
; match_expr lefta leftb
;
659 match_expr righta rightb
]
661 | (Ast0.Sequence
(lefta
,opa
,righta
),
662 Ast0.Sequence
(leftb
,opb
,rightb
)) ->
663 if mcode_equal opa opb
665 conjunct_many_bindings
666 [check_mcode opa opb
; match_expr lefta leftb
;
667 match_expr righta rightb
]
669 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
670 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
671 conjunct_many_bindings
672 [check_mcode lp1 lp
; check_mcode rp1 rp
;
673 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
674 match_expr exp3a exp3b
]
675 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
676 if mcode_equal opa opb
678 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
680 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
681 if mcode_equal opa opb
683 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
685 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
686 if mcode_equal opa opb
688 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
690 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
691 if mcode_equal opa opb
693 conjunct_many_bindings
694 [check_mcode opa opb
; match_expr lefta leftb
;
695 match_expr righta rightb
]
697 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
698 conjunct_many_bindings
699 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
700 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
701 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
702 conjunct_many_bindings
703 [check_mcode lb1 lb
; check_mcode rb1 rb
;
704 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
705 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
706 Ast0.RecordAccess
(expb
,op
,fieldb
))
707 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
708 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
709 conjunct_many_bindings
710 [check_mcode opa op
; match_expr expa expb
;
711 match_ident fielda fieldb
]
712 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
713 conjunct_many_bindings
714 [check_mcode lp1 lp
; check_mcode rp1 rp
;
715 match_typeC tya tyb
; match_expr expa expb
]
716 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
717 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
718 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
719 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
720 conjunct_many_bindings
721 [check_mcode lp1 lp
; check_mcode rp1 rp
;
722 check_mcode szf1 szf
; match_typeC tya tyb
]
723 | (Ast0.Constructor
(lp1
,tya
,rp1
,inita
),
724 Ast0.Constructor
(lp
,tyb
,rp
,initb
)) ->
725 conjunct_many_bindings
726 [check_mcode lp1 lp
; check_mcode rp1 rp
;
727 match_typeC tya tyb
; match_init inita initb
]
728 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
730 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
731 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
732 failwith
"not allowed in the pattern of an isomorphism"
733 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
734 failwith
"not allowed in the pattern of an isomorphism"
735 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
736 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
737 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
738 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
739 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
740 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
741 (* hope that mcode of edots is unique somehow *)
742 conjunct_bindings (check_mcode ed ed1
)
743 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
744 if edots_whencode_allowed
745 then add_dot_binding ed
(Ast0.ExprTag wc
)
748 "warning: not applying iso because of whencode";
750 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
751 | (Ast0.Estars
(_
,Some _
),_
) ->
752 failwith
"whencode not allowed in a pattern1"
753 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
754 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) ->
756 | (_
,Ast0.OptExp
(expb
))
757 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
759 else return_false (ContextRequired
(Ast0.ExprTag expr
))
761 (* the special case for function types prevents the eg T X; -> T X = E; iso
762 from applying, which doesn't seem very relevant, but it also avoids a
763 mysterious bug that is obtained with eg int attach(...); *)
764 and match_typeC pattern t
=
765 match Ast0.unwrap pattern
with
766 Ast0.MetaType
(name
,pure
) ->
767 (match Ast0.unwrap t
with
768 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
770 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
771 (function ty
-> Ast0.TypeCTag ty
)
774 if not
(checks_needed
) or not
(context_required
) or is_context t
776 match (up
,Ast0.unwrap t
) with
777 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
778 if mcode_equal cva cvb
780 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
782 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
785 match_list check_mcode
786 (function _
-> false) (function _
-> failwith
"")
789 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
790 if mcode_equal signa signb
792 conjunct_bindings (check_mcode signa signb
)
793 (match_option match_typeC tya tyb
)
795 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
796 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
797 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
798 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
799 conjunct_many_bindings
800 [check_mcode stara starb
; check_mcode lp1a lp1b
;
801 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
802 check_mcode rp2a rp2b
; match_typeC tya tyb
;
803 match_dots match_param
is_plist_matcher
804 do_plist_match paramsa paramsb
]
805 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
806 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
807 conjunct_many_bindings
808 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
809 match_option match_typeC tya tyb
;
810 match_dots match_param
is_plist_matcher do_plist_match
812 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
813 conjunct_many_bindings
814 [check_mcode lb1 lb
; check_mcode rb1 rb
;
815 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
816 | (Ast0.EnumName
(kinda
,Some namea
),
817 Ast0.EnumName
(kindb
,Some nameb
)) ->
818 conjunct_bindings (check_mcode kinda kindb
)
819 (match_ident namea nameb
)
820 | (Ast0.EnumDef
(tya
,lb1
,idsa
,rb1
),
821 Ast0.EnumDef
(tyb
,lb
,idsb
,rb
)) ->
822 conjunct_many_bindings
823 [check_mcode lb1 lb
; check_mcode rb1 rb
;
825 match_dots match_expr no_list do_nolist_match idsa idsb
]
826 | (Ast0.StructUnionName
(kinda
,Some namea
),
827 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
828 if mcode_equal kinda kindb
830 conjunct_bindings (check_mcode kinda kindb
)
831 (match_ident namea nameb
)
833 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
834 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
835 conjunct_many_bindings
836 [check_mcode lb1 lb
; check_mcode rb1 rb
;
838 match_dots match_decl
no_list do_nolist_match declsa declsb
]
839 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
840 if mcode_equal namea nameb
841 then check_mcode namea nameb
843 | (Ast0.DisjType
(_
,typesa
,_
,_
),_
) ->
844 failwith
"not allowed in the pattern of an isomorphism"
845 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
846 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
847 | (_
,Ast0.OptType
(tyb
))
848 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
850 else return_false (ContextRequired
(Ast0.TypeCTag t
))
852 and match_decl pattern d
=
853 match Ast0.unwrap pattern
with
854 Ast0.MetaDecl
(name
,pure
) ->
855 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
856 (function d
-> Ast0.DeclTag d
)
858 | Ast0.MetaField
(name
,pure
) ->
859 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
860 (function d
-> Ast0.DeclTag d
)
862 | Ast0.MetaFieldList
(name
,_
,pure
) -> failwith
"metafieldlist not supporte"
864 if not
(checks_needed
) or not
(context_required
) or is_context d
866 match (up
,Ast0.unwrap d
) with
867 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
868 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
869 if bool_match_option mcode_equal stga stgb
871 conjunct_many_bindings
872 [check_mcode eq1 eq
; check_mcode sc1 sc
;
873 match_option check_mcode stga stgb
;
874 match_typeC tya tyb
; match_ident ida idb
;
875 match_init inia inib
]
877 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
878 if bool_match_option mcode_equal stga stgb
880 conjunct_many_bindings
881 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
882 match_typeC tya tyb
; match_ident ida idb
]
884 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
885 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
886 conjunct_many_bindings
887 [match_ident namea nameb
;
888 check_mcode lp1 lp
; check_mcode rp1 rp
;
890 match_dots match_expr is_elist_matcher do_elist_match
892 | (Ast0.MacroDeclInit
(namea
,lp1
,argsa
,rp1
,eq1
,ini1
,sc1
),
893 Ast0.MacroDeclInit
(nameb
,lp
,argsb
,rp
,eq
,ini
,sc
)) ->
894 conjunct_many_bindings
895 [match_ident namea nameb
;
896 check_mcode lp1 lp
; check_mcode rp1 rp
;
899 match_dots match_expr is_elist_matcher do_elist_match
902 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
903 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
904 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
905 conjunct_bindings (check_mcode sc1 sc
)
906 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
907 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),_
) ->
908 failwith
"not allowed in the pattern of an isomorphism"
909 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
910 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
911 conjunct_bindings (check_mcode dd d
)
912 (* hope that mcode of ddots is unique somehow *)
913 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
914 if ddots_whencode_allowed
915 then add_dot_binding dd
(Ast0.DeclTag wc
)
917 (Printf.printf
"warning: not applying iso because of whencode";
919 | (Ast0.Ddots
(_
,Some _
),_
) ->
920 failwith
"whencode not allowed in a pattern1"
922 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
923 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
924 match_decl decla declb
925 | (_
,Ast0.OptDecl
(declb
))
926 | (_
,Ast0.UniqueDecl
(declb
)) ->
927 match_decl pattern declb
929 else return_false (ContextRequired
(Ast0.DeclTag d
))
931 and match_init pattern i
=
932 match Ast0.unwrap pattern
with
933 Ast0.MetaInit
(name
,pure
) ->
934 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
935 (function ini
-> Ast0.InitTag ini
)
938 if not
(checks_needed
) or not
(context_required
) or is_context i
940 match (up
,Ast0.unwrap i
) with
941 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
943 | (Ast0.InitList
(lb1
,initlista
,rb1
,oa
),
944 Ast0.InitList
(lb
,initlistb
,rb
,ob
))
946 conjunct_many_bindings
947 [check_mcode lb1 lb
; check_mcode rb1 rb
;
948 match_dots match_init
no_list do_nolist_match
950 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
951 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
952 conjunct_many_bindings
953 [match_list match_designator
954 (function _
-> false) (function _
-> failwith
"")
955 designators1 designators2
;
957 match_init inia inib
]
958 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
959 conjunct_many_bindings
960 [check_mcode c1 c
; match_ident namea nameb
;
961 match_init inia inib
]
962 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
963 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
964 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
965 conjunct_bindings (check_mcode id d
)
966 (* hope that mcode of edots is unique somehow *)
967 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
968 if idots_whencode_allowed
969 then add_dot_binding id
(Ast0.InitTag wc
)
972 "warning: not applying iso because of whencode";
974 | (Ast0.Idots
(_
,Some _
),_
) ->
975 failwith
"whencode not allowed in a pattern2"
976 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
977 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
978 | (_
,Ast0.OptIni
(ib
))
979 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
981 else return_false (ContextRequired
(Ast0.InitTag i
))
983 and match_designator pattern d
=
984 match (pattern
,d
) with
985 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
986 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
987 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
988 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
989 conjunct_many_bindings
990 [check_mcode lba lbb
; match_expr expa expb
;
992 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
993 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
994 conjunct_many_bindings
995 [check_mcode lba lbb
; match_expr mina minb
;
996 check_mcode dotsa dotsb
; match_expr maxa maxb
;
1000 and match_param pattern p
=
1001 match Ast0.unwrap pattern
with
1002 Ast0.MetaParam
(name
,pure
) ->
1003 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
1004 (function p
-> Ast0.ParamTag p
)
1006 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
1008 if not
(checks_needed
) or not
(context_required
) or is_context p
1010 match (up
,Ast0.unwrap p
) with
1011 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
1012 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
1013 conjunct_bindings (match_typeC tya tyb
)
1014 (match_option match_ident ida idb
)
1015 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
1016 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
1017 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
1018 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
1019 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
1020 match_param parama paramb
1021 | (_
,Ast0.OptParam
(paramb
))
1022 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
1024 else return_false (ContextRequired
(Ast0.ParamTag p
))
1026 and match_statement pattern s
=
1027 match Ast0.unwrap pattern
with
1028 Ast0.MetaStmt
(name
,pure
) ->
1029 (match Ast0.unwrap s
with
1030 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
1031 return false (* ... is not a single statement *)
1033 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
1034 (function ty
-> Ast0.StmtTag ty
)
1036 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1038 if not
(checks_needed
) or not
(context_required
) or is_context s
1040 match (up
,Ast0.unwrap s
) with
1041 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
1042 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
1043 conjunct_many_bindings
1044 [check_mcode lp1 lp
; check_mcode rp1 rp
;
1045 check_mcode lb1 lb
; check_mcode rb1 rb
;
1046 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
1047 match_dots match_param
is_plist_matcher do_plist_match
1049 match_dots match_statement
is_slist_matcher do_slist_match
1051 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
1052 match_decl decla declb
1053 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
1054 (* seqs can only match if they are all minus (plus code
1055 allowed) or all context (plus code not allowed in the body).
1056 we could be more permissive if the expansions of the isos are
1057 also all seqs, but this would be hard to check except at top
1058 level, and perhaps not worth checking even in that case.
1059 Overall, the issue is that braces are used where single
1060 statements are required, and something not satisfying these
1061 conditions can cause a single statement to become a
1062 non-single statement after the transformation.
1064 example: if { ... -foo(); ... }
1065 if we let the sequence convert to just -foo();
1066 then we produce invalid code. For some reason,
1067 single_statement can't deal with this case, perhaps because
1068 it starts introducing too many braces? don't remember the
1071 conjunct_bindings (check_mcode lb1 lb
)
1072 (conjunct_bindings (check_mcode rb1 rb
)
1073 (if not
(checks_needed
) or is_minus s
or
1075 List.for_all
is_pure_context (Ast0.undots bodyb
))
1077 match_dots match_statement
is_slist_matcher do_slist_match
1079 else return_false (Braces
(s
))))
1080 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1081 conjunct_bindings (check_mcode sc1 sc
)
1082 (match_option match_expr expa expb
)
1083 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1084 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1085 conjunct_many_bindings
1086 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1087 check_mcode rp1 rp2
;
1088 match_expr expa expb
;
1089 match_statement branch1a branch1b
]
1090 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1091 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1092 conjunct_many_bindings
1093 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1094 check_mcode rp1 rp2
; check_mcode e1 e2
;
1095 match_expr expa expb
;
1096 match_statement branch1a branch1b
;
1097 match_statement branch2a branch2b
]
1098 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1099 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1100 conjunct_many_bindings
1101 [check_mcode w1 w
; check_mcode lp1 lp
;
1102 check_mcode rp1 rp
; match_expr expa expb
;
1103 match_statement bodya bodyb
]
1104 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1105 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1106 conjunct_many_bindings
1107 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1108 check_mcode rp1 rp
; match_statement bodya bodyb
;
1109 match_expr expa expb
]
1110 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1111 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1112 conjunct_many_bindings
1113 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1114 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1115 match_option match_expr e1a e1b
;
1116 match_option match_expr e2a e2b
;
1117 match_option match_expr e3a e3b
;
1118 match_statement bodya bodyb
]
1119 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1120 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1121 conjunct_many_bindings
1122 [match_ident nma nmb
;
1123 check_mcode lp1 lp
; check_mcode rp1 rp
;
1124 match_dots match_expr is_elist_matcher do_elist_match
1126 match_statement bodya bodyb
]
1127 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1128 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1129 conjunct_many_bindings
1130 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1131 check_mcode lb1 lb
; check_mcode rb1 rb
;
1132 match_expr expa expb
;
1133 match_dots match_statement
is_slist_matcher do_slist_match
1135 match_dots match_case_line
no_list do_nolist_match
1137 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1138 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1139 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1140 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1141 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1142 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1143 conjunct_many_bindings
1144 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1145 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1146 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1147 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1148 conjunct_many_bindings
1149 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1150 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1151 failwith
"disj not supported in patterns"
1152 | (Ast0.Nest
(_
,stmt_dotsa
,_
,[],multia
),
1153 Ast0.Nest
(_
,stmt_dotsb
,_
,wc
,multib
)) ->
1158 (* not sure this is correct, perhaps too restrictive *)
1159 if not
(checks_needed
) or is_minus s
or
1161 List.for_all
is_pure_context (Ast0.undots stmt_dotsb
))
1163 match_dots match_statement
1164 is_slist_matcher do_slist_match
1165 stmt_dotsa stmt_dotsb
1166 else return_false (Braces
(s
))
1167 | _
-> return_false (Nest
(s
)))
1168 else return false (* diff kind of nest *)
1169 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1170 failwith
"nest with whencode not supported in patterns"
1171 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1172 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1173 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1174 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1175 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1176 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1177 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1178 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1180 [] -> check_mcode d d1
1182 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1183 if dots_whencode_allowed
1185 conjunct_bindings (check_mcode d d1
)
1189 | Ast0.WhenNot wc
->
1190 conjunct_bindings prev
1191 (add_multi_dot_binding d
1192 (Ast0.DotsStmtTag wc
))
1193 | Ast0.WhenAlways wc
->
1194 conjunct_bindings prev
1195 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1196 | Ast0.WhenNotTrue wc
->
1197 conjunct_bindings prev
1198 (add_multi_dot_binding d
1199 (Ast0.IsoWhenTTag wc
))
1200 | Ast0.WhenNotFalse wc
->
1201 conjunct_bindings prev
1202 (add_multi_dot_binding d
1203 (Ast0.IsoWhenFTag wc
))
1204 | Ast0.WhenModifier
(x) ->
1205 conjunct_bindings prev
1206 (add_multi_dot_binding d
1207 (Ast0.IsoWhenTag
x)))
1211 "warning: not applying iso because of whencode";
1213 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1214 | (Ast0.Stars
(_
,_
::_
),_
) ->
1215 failwith
"whencode not allowed in a pattern3"
1216 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1217 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1218 match_statement rea reb
1219 | (_
,Ast0.OptStm
(reb
))
1220 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1222 else return_false (ContextRequired
(Ast0.StmtTag s
))
1224 (* first should provide a subset of the information in the second *)
1225 and match_fninfo patterninfo cinfo
=
1226 let patterninfo = List.sort compare
patterninfo in
1227 let cinfo = List.sort compare
cinfo in
1228 let rec loop = function
1229 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1230 if mcode_equal sta stb
1231 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1233 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1234 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1235 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1236 if mcode_equal ia ib
1237 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1239 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1240 if mcode_equal ia ib
1241 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1243 | (x::resta
,((y
::_
) as restb
)) ->
1244 (match compare
x y
with
1246 | 1 -> loop (resta
,restb
)
1247 | _
-> failwith
"not possible")
1248 | _
-> return false in
1249 loop (patterninfo,cinfo)
1251 and match_case_line pattern c
=
1252 if not
(checks_needed
) or not
(context_required
) or is_context c
1254 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1255 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1256 conjunct_many_bindings
1257 [check_mcode d1 d
; check_mcode c1 c
;
1258 match_dots match_statement
is_slist_matcher do_slist_match
1260 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1261 conjunct_many_bindings
1262 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1263 match_dots match_statement
is_slist_matcher do_slist_match
1265 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1266 failwith
"not allowed in the pattern of an isomorphism"
1267 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1268 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1270 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1272 let match_statement_dots x y
=
1273 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1275 (match_expr, match_decl
, match_statement
, match_typeC
,
1276 match_statement_dots)
1278 let match_expr dochecks context_required whencode_allowed
=
1279 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1282 let match_decl dochecks context_required whencode_allowed
=
1283 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1286 let match_statement dochecks context_required whencode_allowed
=
1287 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1290 let match_typeC dochecks context_required whencode_allowed
=
1291 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1294 let match_statement_dots dochecks context_required whencode_allowed
=
1295 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1298 (* --------------------------------------------------------------------- *)
1299 (* make an entire tree MINUS *)
1302 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1304 match mcodekind
with
1307 (Ast.NOTHING
,_
,_
) ->
1308 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1309 | _
-> failwith
"make_minus: unexpected befaft")
1310 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1311 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1312 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1314 let update_mc mcodekind e
=
1315 match !mcodekind
with
1318 (Ast.NOTHING
,_
,_
) ->
1320 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1321 | _
-> failwith
"make_minus: unexpected befaft")
1322 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1323 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1324 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1326 let donothing r k e
=
1327 let mcodekind = Ast0.get_mcodekind_ref e
in
1328 let e = k
e in update_mc mcodekind e; e in
1330 (* special case for whencode, because it isn't processed by contextneg,
1331 since it doesn't appear in the + code *)
1332 (* cases for dots and nests *)
1333 let expression r k
e =
1334 let mcodekind = Ast0.get_mcodekind_ref
e in
1335 match Ast0.unwrap
e with
1336 Ast0.Edots
(d
,whencode
) ->
1337 (*don't recurse because whencode hasn't been processed by context_neg*)
1338 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1339 | Ast0.Ecircles
(d
,whencode
) ->
1340 (*don't recurse because whencode hasn't been processed by context_neg*)
1341 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1342 | Ast0.Estars
(d
,whencode
) ->
1343 (*don't recurse because whencode hasn't been processed by context_neg*)
1344 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1345 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1346 update_mc mcodekind e;
1348 (Ast0.NestExpr
(mcode starter
,
1349 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1350 mcode ender
,whencode
,multi
))
1351 | _
-> donothing r k
e in
1353 let declaration r k
e =
1354 let mcodekind = Ast0.get_mcodekind_ref
e in
1355 match Ast0.unwrap
e with
1356 Ast0.Ddots
(d
,whencode
) ->
1357 (*don't recurse because whencode hasn't been processed by context_neg*)
1358 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1359 | _
-> donothing r k
e in
1361 let statement r k
e =
1362 let mcodekind = Ast0.get_mcodekind_ref
e in
1363 match Ast0.unwrap
e with
1364 Ast0.Dots
(d
,whencode
) ->
1365 (*don't recurse because whencode hasn't been processed by context_neg*)
1366 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1367 | Ast0.Circles
(d
,whencode
) ->
1368 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1369 | Ast0.Stars
(d
,whencode
) ->
1370 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1371 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1372 update_mc mcodekind e;
1375 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1376 mcode ender
,whencode
,multi
))
1377 | _
-> donothing r k
e in
1379 let initialiser r k
e =
1380 let mcodekind = Ast0.get_mcodekind_ref
e in
1381 match Ast0.unwrap
e with
1382 Ast0.Idots
(d
,whencode
) ->
1383 (*don't recurse because whencode hasn't been processed by context_neg*)
1384 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1385 | _
-> donothing r k
e in
1388 let info = Ast0.get_info
e in
1389 let mcodekind = Ast0.get_mcodekind_ref
e in
1390 match Ast0.unwrap
e with
1392 (* if context is - this should be - as well. There are no tokens
1393 here though, so the bottom-up minusifier in context_neg leaves it
1394 as mixed (or context for sgrep2). It would be better to fix
1395 context_neg, but that would
1396 require a special case for each term with a dots subterm. *)
1397 (match !mcodekind with
1398 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1400 (Ast.NOTHING
,_
,_
) ->
1402 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
));
1404 | _
-> failwith
"make_minus: unexpected befaft")
1405 (* code already processed by an enclosing iso *)
1406 | Ast0.MINUS
(mc
) -> e
1410 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1411 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1412 | _
-> donothing r k
e in
1415 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1416 dots dots dots dots dots dots
1417 donothing expression donothing initialiser donothing declaration
1418 statement donothing donothing
1420 (* --------------------------------------------------------------------- *)
1421 (* rebuild mcode cells in an instantiated alt *)
1423 (* mcodes will be side effected later with plus code, so we have to copy
1424 them on instantiating an isomorphism. One could wonder whether it would
1425 be better not to use side-effects, but they are convenient for insert_plus
1426 where is it useful to manipulate a list of the mcodes but side-effect a
1428 (* hmm... Insert_plus is called before Iso_pattern... *)
1429 let rebuild_mcode start_line
=
1430 let copy_mcodekind = function
1431 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1432 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1433 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1434 | Ast0.PLUS count
->
1435 (* this function is used elsewhere where we need to rebuild the
1436 indices, and so we allow PLUS code as well *)
1439 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1441 match start_line
with
1444 {info.Ast0.pos_info
with
1445 Ast0.line_start
= x;
1446 Ast0.line_end
= x; } in
1447 {info with Ast0.pos_info
= new_pos_info}
1449 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1452 let old_info = Ast0.get_info
x in
1454 match start_line
with
1457 {old_info.Ast0.pos_info
with
1458 Ast0.line_start
= x;
1459 Ast0.line_end
= x; } in
1460 {old_info with Ast0.pos_info
= new_pos_info}
1461 | None
-> old_info in
1462 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1463 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1465 let donothing r k
e = copy_one (k
e) in
1467 (* case for control operators (if, etc) *)
1468 let statement r k
e =
1473 (match Ast0.unwrap
s with
1474 Ast0.Decl
((info,mc
),decl) ->
1475 Ast0.Decl
((info,copy_mcodekind mc
),decl)
1476 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1477 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1478 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1479 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1480 (info,copy_mcodekind mc
))
1481 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1482 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1483 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1484 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1485 (info,copy_mcodekind mc
))
1486 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1487 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1489 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1491 ((info,copy_mcodekind mc
),
1492 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1494 Ast0.set_dots_bef_aft
res
1495 (match Ast0.get_dots_bef_aft
res with
1496 Ast0.NoDots
-> Ast0.NoDots
1497 | Ast0.AddingBetweenDots
s ->
1498 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1499 | Ast0.DroppingBetweenDots
s ->
1500 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1503 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1504 donothing donothing donothing donothing donothing donothing
1505 donothing donothing donothing donothing donothing
1506 donothing statement donothing donothing
1508 (* --------------------------------------------------------------------- *)
1509 (* The problem of whencode. If an isomorphism contains dots in multiple
1510 rules, then the code that is matched cannot contain whencode, because we
1511 won't know which dots it goes with. Should worry about nests, but they
1512 aren't allowed in isomorphisms for the moment. *)
1515 let option_default = 0 in
1516 let bind x y
= x + y
in
1518 match Ast0.unwrap
e with
1519 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1522 V0.combiner
bind option_default
1523 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1526 let option_default = 0 in
1527 let bind x y
= x + y
in
1529 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1531 V0.combiner
bind option_default
1532 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1535 let option_default = 0 in
1536 let bind x y
= x + y
in
1538 match Ast0.unwrap
e with
1539 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1542 V0.combiner
bind option_default
1543 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1545 (* --------------------------------------------------------------------- *)
1547 let lookup name bindings mv_bindings
=
1548 try Common.Left
(List.assoc
(term name
) bindings
)
1551 (* failure is not possible anymore *)
1552 Common.Right
(List.assoc
(term name
) mv_bindings
)
1554 (* mv_bindings is for the fresh metavariables that are introduced by the
1556 let instantiate bindings mv_bindings
=
1558 let (hidden
,others
) =
1560 (function Ast0.HiddenVarTag _
-> true | _
-> false)
1564 [Ast0.HiddenVarTag
([Ast0.MetaPosTag
(Ast0.MetaPos
(name
,_
,_
))])] ->
1566 (* not at all sure that this is good enough *)
1567 match lookup name bindings mv_bindings
with
1568 Common.Left
(Ast0.HiddenVarTag
(ids
)) -> ids
1569 | _
-> failwith
"not possible"
1571 (*can't fail because checks_needed could be false?*)
1573 | [] -> [] (* no hidden metavars allowed *)
1574 | _
-> failwith
"badly compiled mcode" in
1575 Ast0.set_pos
(new_names@others
) x in
1576 let donothing r k
e = k
e in
1578 (* cases where metavariables can occur *)
1581 match Ast0.unwrap
e with
1582 Ast0.MetaId
(name
,constraints
,seed
,pure
) ->
1583 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1584 (match lookup name bindings mv_bindings
with
1585 Common.Left
(Ast0.IdentTag
(id
)) -> id
1586 | Common.Left
(_
) -> failwith
"not possible 1"
1587 | Common.Right
(new_mv
) ->
1590 (Ast0.set_mcode_data new_mv name
,constraints
,seed
,pure
)))
1591 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1592 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1595 (* case for list metavariables *)
1596 let rec elist r same_dots
= function
1599 (match Ast0.unwrap
x with
1600 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1601 failwith
"meta_expr_list in iso not supported"
1602 (*match lookup name bindings mv_bindings with
1603 Common.Left(Ast0.DotsExprTag(exp)) ->
1604 (match same_dots exp with
1606 | None -> failwith "dots put in incompatible context")
1607 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1608 | Common.Left(_) -> failwith "not possible 1"
1609 | Common.Right(new_mv) ->
1610 failwith "MetaExprList in SP not supported"*)
1611 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1612 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1614 let rec plist r same_dots
= function
1617 (match Ast0.unwrap
x with
1618 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1619 failwith
"meta_param_list in iso not supported"
1620 (*match lookup name bindings mv_bindings with
1621 Common.Left(Ast0.DotsParamTag(param)) ->
1622 (match same_dots param with
1624 | None -> failwith "dots put in incompatible context")
1625 | Common.Left(Ast0.ParamTag(param)) -> [param]
1626 | Common.Left(_) -> failwith "not possible 1"
1627 | Common.Right(new_mv) ->
1628 failwith "MetaExprList in SP not supported"*)
1629 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1630 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1632 let rec slist r same_dots
= function
1635 (match Ast0.unwrap
x with
1636 Ast0.MetaStmtList
(name
,pure
) ->
1637 (match lookup name bindings mv_bindings
with
1638 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1639 (match same_dots stm
with
1641 | None
-> failwith
"dots put in incompatible context")
1642 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1643 | Common.Left
(_
) -> failwith
"not possible 1"
1644 | Common.Right
(new_mv
) ->
1645 failwith
"MetaExprList in SP not supported")
1646 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1647 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1650 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1651 let same_circles d
=
1652 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1654 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1656 let dots list_fn r k d
=
1658 (match Ast0.unwrap d
with
1659 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1660 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1661 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1663 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1666 match Ast0.unwrap
e with
1667 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1668 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1669 (match lookup name bindings mv_bindings
with
1670 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1671 | Common.Left
(_
) -> failwith
"not possible 1"
1672 | Common.Right
(new_mv
) ->
1677 let rec renamer = function
1678 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1680 lookup (name
,(),(),(),None
,-1)
1681 bindings mv_bindings
1683 Common.Left
(Ast0.TypeCTag
(t
)) ->
1684 Ast0.ast0_type_to_type t
1686 failwith
"iso pattern: unexpected type"
1687 | Common.Right
(new_mv
) ->
1688 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1689 | Type_cocci.ConstVol
(cv
,ty
) ->
1690 Type_cocci.ConstVol
(cv
,renamer ty
)
1691 | Type_cocci.Pointer
(ty
) ->
1692 Type_cocci.Pointer
(renamer ty
)
1693 | Type_cocci.FunctionPointer
(ty
) ->
1694 Type_cocci.FunctionPointer
(renamer ty
)
1695 | Type_cocci.Array
(ty
) ->
1696 Type_cocci.Array
(renamer ty
)
1698 Some
(List.map
renamer types
) in
1701 (Ast0.set_mcode_data new_mv name
,constraints
,
1702 new_types,form
,pure
)))
1703 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1704 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1705 failwith
"metaexprlist not supported"
1706 | Ast0.Unary
(exp
,unop
) ->
1707 (match Ast0.unwrap_mcode unop
with
1708 (* propagate negation only when the propagated and the encountered
1709 negation have the same transformation, when there is nothing
1710 added to the original one, and when there is nothing added to
1711 the expression into which we are doing the propagation. This
1712 may be too conservative. *)
1715 (* k e doesn't change the outer structure of the term,
1716 only the metavars *)
1717 match Ast0.unwrap old_e
with
1718 Ast0.Unary
(exp
,_
) ->
1719 (match Ast0.unwrap exp
with
1720 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1722 | _
-> failwith
"not possible" in
1723 let nomodif = function
1726 (Ast.NOREPLACEMENT
,_
) -> true
1728 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1730 (Ast.NOTHING
,_
,_
) -> true
1732 | _
-> failwith
"plus not possible" in
1733 let same_modif newop oldop
=
1734 (* only propagate ! is they have the same modification
1735 and no + code on the old one (the new one from the iso
1736 surely has no + code) *)
1737 match (newop
,oldop
) with
1738 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1739 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1740 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1745 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1746 (* k accumulates parens, to keep negation outside if no
1747 propagation is possible *)
1748 if nomodif (Ast0.get_mcodekind
e)
1750 match Ast0.unwrap
res with
1751 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1753 (Ast0.get_mcode_mcodekind unop
)
1754 (Ast0.get_mcode_mcodekind op
) ->
1756 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1757 | Ast0.Paren
(lp
,e1,rp
) ->
1760 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1761 | Ast0.Binary
(e1,op
,e2
) when
1763 (Ast0.get_mcode_mcodekind unop
)
1764 (Ast0.get_mcode_mcodekind op
) ->
1766 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1767 let k1 x = k
(Ast0.rewrap
e x) in
1768 (match Ast0.unwrap_mcode op
with
1769 Ast.Logical
(Ast.Inf
) ->
1770 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1771 | Ast.Logical
(Ast.Sup
) ->
1772 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1773 | Ast.Logical
(Ast.InfEq
) ->
1774 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1775 | Ast.Logical
(Ast.SupEq
) ->
1776 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1777 | Ast.Logical
(Ast.Eq
) ->
1778 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1779 | Ast.Logical
(Ast.NotEq
) ->
1780 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1781 | Ast.Logical
(Ast.AndLog
) ->
1782 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1784 negate_reb
e e2
idcont))
1785 | Ast.Logical
(Ast.OrLog
) ->
1786 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1788 negate_reb
e e2
idcont))
1792 Ast0.rewrap_mcode op
Ast.Not
)))
1793 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1794 (* use res because it is the transformed argument *)
1796 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1797 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1799 (*use e, because this might be the toplevel expression*)
1801 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1804 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1805 and negate_reb
e e1 k
=
1806 (* used when ! is propagated to multiple places, to avoid
1807 duplicating mcode cells *)
1809 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1810 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1815 | Ast0.Edots
(d
,_
) ->
1817 (match List.assoc
(dot_term d
) bindings
with
1818 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1819 | _
-> failwith
"unexpected binding")
1820 with Not_found
-> e)
1821 | Ast0.Ecircles
(d
,_
) ->
1823 (match List.assoc
(dot_term d
) bindings
with
1824 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1825 | _
-> failwith
"unexpected binding")
1826 with Not_found
-> e)
1827 | Ast0.Estars
(d
,_
) ->
1829 (match List.assoc
(dot_term d
) bindings
with
1830 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1831 | _
-> failwith
"unexpected binding")
1832 with Not_found
-> e)
1834 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1838 match Ast0.unwrap
e with
1839 Ast0.MetaType
(name
,pure
) ->
1840 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1841 (match lookup name bindings mv_bindings
with
1842 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1843 | Common.Left
(_
) -> failwith
"not possible 1"
1844 | Common.Right
(new_mv
) ->
1846 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1851 match Ast0.unwrap
e with
1852 Ast0.MetaInit
(name
,pure
) ->
1853 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1854 (match lookup name bindings mv_bindings
with
1855 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1856 | Common.Left
(_
) -> failwith
"not possible 1"
1857 | Common.Right
(new_mv
) ->
1859 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1864 match Ast0.unwrap
e with
1865 Ast0.MetaDecl
(name
,pure
) ->
1866 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1867 (match lookup name bindings mv_bindings
with
1868 Common.Left
(Ast0.DeclTag
(d
)) -> d
1869 | Common.Left
(_
) -> failwith
"not possible 1"
1870 | Common.Right
(new_mv
) ->
1872 (Ast0.MetaDecl
(Ast0.set_mcode_data new_mv name
, pure
)))
1873 | Ast0.MetaField
(name
,pure
) ->
1874 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1875 (match lookup name bindings mv_bindings
with
1876 Common.Left
(Ast0.DeclTag
(d
)) -> d
1877 | Common.Left
(_
) -> failwith
"not possible 1"
1878 | Common.Right
(new_mv
) ->
1880 (Ast0.MetaField
(Ast0.set_mcode_data new_mv name
, pure
)))
1881 | Ast0.MetaFieldList
(name
,lenname
,pure
) ->
1882 failwith
"metafieldlist not supported"
1883 | Ast0.Ddots
(d
,_
) ->
1885 (match List.assoc
(dot_term d
) bindings
with
1886 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1887 | _
-> failwith
"unexpected binding")
1888 with Not_found
-> e)
1893 match Ast0.unwrap
e with
1894 Ast0.MetaParam
(name
,pure
) ->
1895 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1896 (match lookup name bindings mv_bindings
with
1897 Common.Left
(Ast0.ParamTag
(param)) -> param
1898 | Common.Left
(_
) -> failwith
"not possible 1"
1899 | Common.Right
(new_mv
) ->
1901 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1902 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1903 failwith
"metaparamlist not supported"
1908 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1909 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1910 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1911 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1912 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1913 | _
-> failwith
"unexpected binding" in
1917 match Ast0.unwrap
e with
1918 Ast0.MetaStmt
(name
,pure
) ->
1919 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1920 (match lookup name bindings mv_bindings
with
1921 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1922 | Common.Left
(_
) -> failwith
"not possible 1"
1923 | Common.Right
(new_mv
) ->
1925 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1926 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1932 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1933 | Ast0.Circles
(d
,_
) ->
1938 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1939 | Ast0.Stars
(d
,_
) ->
1944 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1948 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1949 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1950 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1952 (* --------------------------------------------------------------------- *)
1955 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1957 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1959 let disj_fail bindings
e =
1961 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1964 (* isomorphism code is by default CONTEXT *)
1965 let merge_plus model_mcode e_mcode
=
1966 match model_mcode
with
1968 (* add the replacement information at the root *)
1972 (match (!mc
,!emc
) with
1973 ((Ast.NOREPLACEMENT
,_
),(x,t
))
1974 | ((x,_
),(Ast.NOREPLACEMENT
,t
)) -> (x,t
)
1975 | _
-> failwith
"how can we combine minuses?")
1976 | _
-> failwith
"not possible 6")
1977 | Ast0.CONTEXT
(mc
) ->
1979 Ast0.CONTEXT
(emc
) ->
1980 (* keep the logical line info as in the model *)
1981 let (mba
,tb
,ta
) = !mc
in
1982 let (eba
,_
,_
) = !emc
in
1983 (* merging may be required when a term is replaced by a subterm *)
1985 match (mba
,eba
) with
1986 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1987 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1988 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1989 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1990 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1991 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1992 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1993 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1994 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1995 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1996 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1997 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1998 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1999 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
2000 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
2001 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
2002 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
2003 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
2004 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
2005 emc
:= (merged,tb
,ta
)
2006 | Ast0.MINUS
(emc
) ->
2007 let (anything_bef_aft
,_
,_
) = !mc
in
2008 let (anythings
,t
) = !emc
in
2009 (match (anything_bef_aft
,anythings
) with
2010 (Ast.BEFORE
(b1
,it1
),Ast.NOREPLACEMENT
) ->
2011 emc
:= (Ast.REPLACEMENT
(b1
,it1
),t
)
2012 | (Ast.AFTER
(a1
,it1
),Ast.NOREPLACEMENT
) ->
2013 emc
:= (Ast.REPLACEMENT
(a1
,it1
),t
)
2014 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.NOREPLACEMENT
) ->
2015 emc
:= (Ast.REPLACEMENT
(b1
@a1
,it1
),t
)
2016 | (Ast.NOTHING
,Ast.NOREPLACEMENT
) ->
2017 emc
:= (Ast.NOREPLACEMENT
,t
)
2018 | (Ast.BEFORE
(b1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2019 emc
:= (Ast.REPLACEMENT
(b1
@a2
,Ast.lub_count it1 it2
),t
)
2020 | (Ast.AFTER
(a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2021 emc
:= (Ast.REPLACEMENT
(a2
@a1
,Ast.lub_count it1 it2
),t
)
2022 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2023 emc
:= (Ast.REPLACEMENT
(b1
@a2
@a1
,Ast.lub_count it1 it2
),t
)
2024 | (Ast.NOTHING
,Ast.REPLACEMENT
(a2
,it2
)) -> ()) (* no change *)
2025 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
2026 | _
-> failwith
"not possible 7")
2027 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
2028 | Ast0.PLUS _
-> failwith
"not possible 9"
2030 let copy_plus printer minusify model
e =
2031 if !Flag.sgrep_mode2
2032 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
2036 match Ast0.get_mcodekind model
with
2037 Ast0.MINUS
(mc
) -> minusify
e
2038 | Ast0.CONTEXT
(mc
) -> e
2039 | _
-> failwith
"not possible: copy_plus\n" in
2040 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
2044 let copy_minus printer minusify model
e =
2045 match Ast0.get_mcodekind model
with
2046 Ast0.MINUS
(mc
) -> minusify
e
2047 | Ast0.CONTEXT
(mc
) -> e
2049 if !Flag.sgrep_mode2
2051 else failwith
"not possible 8"
2052 | Ast0.PLUS _
-> failwith
"not possible 9"
2054 let whencode_allowed prev_ecount prev_icount prev_dcount
2055 ecount icount dcount rest
=
2056 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
2058 let other_ecount = (* number of edots *)
2059 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
2061 let other_icount = (* number of dots *)
2062 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
2064 let other_dcount = (* number of dots *)
2065 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
2067 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
2068 dcount
= 0 or other_dcount = 0)
2070 (* copy the befores and afters to the instantiated code *)
2071 let extra_copy_stmt_plus model
e =
2072 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
2074 (match Ast0.unwrap model
with
2075 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
2076 | Ast0.Decl
((info,bef
),_
) ->
2077 (match Ast0.unwrap
e with
2078 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
2079 | Ast0.Decl
((info,bef1
),_
) ->
2081 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
2082 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
2083 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2084 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
2085 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2086 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
2087 (match Ast0.unwrap
e with
2088 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
2089 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2090 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
2091 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2092 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
2094 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
2098 let extra_copy_other_plus model
e = e
2100 (* --------------------------------------------------------------------- *)
2102 let mv_count = ref 0
2104 let ct = !mv_count in
2105 mv_count := !mv_count + 1;
2106 "_"^
s^
"_"^
(string_of_int
ct)
2108 let get_name = function
2109 Ast.MetaMetaDecl
(ar
,nm) ->
2110 (nm,function nm -> Ast.MetaMetaDecl
(ar
,nm))
2111 | Ast.MetaIdDecl
(ar
,nm) ->
2112 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2113 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2114 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2115 | Ast.MetaTypeDecl
(ar
,nm) ->
2116 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2117 | Ast.MetaInitDecl
(ar
,nm) ->
2118 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2119 | Ast.MetaInitListDecl
(ar
,nm,nm1
) ->
2120 (nm,function nm -> Ast.MetaInitListDecl
(ar
,nm,nm1
))
2121 | Ast.MetaListlenDecl
(nm) ->
2122 failwith
"should not be rebuilt"
2123 | Ast.MetaParamDecl
(ar
,nm) ->
2124 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2125 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2126 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2127 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2128 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2129 | Ast.MetaErrDecl
(ar
,nm) ->
2130 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2131 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2132 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2133 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2134 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2135 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2136 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2137 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2138 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2139 | Ast.MetaDeclDecl
(ar
,nm) ->
2140 (nm,function nm -> Ast.MetaDeclDecl
(ar
,nm))
2141 | Ast.MetaFieldListDecl
(ar
,nm,nm1
) ->
2142 (nm,function nm -> Ast.MetaFieldListDecl
(ar
,nm,nm1
))
2143 | Ast.MetaFieldDecl
(ar
,nm) ->
2144 (nm,function nm -> Ast.MetaFieldDecl
(ar
,nm))
2145 | Ast.MetaStmDecl
(ar
,nm) ->
2146 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2147 | Ast.MetaStmListDecl
(ar
,nm) ->
2148 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2149 | Ast.MetaFuncDecl
(ar
,nm) ->
2150 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2151 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2152 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2153 | Ast.MetaPosDecl
(ar
,nm) ->
2154 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2155 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2156 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2157 | Ast.MetaIteratorDecl
(ar
,nm) ->
2158 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2160 let make_new_metavars metavars bindings
=
2164 let (s,_
) = get_name mv
in
2165 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2170 let (s,rebuild
) = get_name mv
in
2171 let new_s = (!current_rule,new_mv s) in
2172 (rebuild
new_s, (s,new_s)))
2175 (* --------------------------------------------------------------------- *)
2177 let do_nothing x = x
2179 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2180 rebuild_mcodes name printer extra_plus update_others has_context
=
2181 let call_instantiate bindings mv_bindings alts pattern has_context
=
2184 (function (a
,_,_,_) ->
2186 (* no need to create duplicates when the bindings have no effect *)
2188 (function bindings
->
2190 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2192 if has_context
(* ie if pat is not just a metavara *)
2194 copy_plus printer minusify
e (extra_plus
e instantiated)
2195 else instantiated in
2198 else (* iso tracking *)
2199 Ast0.set_iso
plus_added
2200 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2203 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2204 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2205 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2207 whencode_allowed prev_ecount prev_icount prev_dcount
2208 ecount dcount icount rest
in
2209 (match matcher
true (context_required e) wc pattern
e init_env with
2211 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2214 (match matcher
false false wc pattern
e init_env with
2216 interpret_reason name
(Ast0.get_line
e) reason
2217 (function () -> printer
e)
2219 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2220 (prev_dcount
+ dcount
) rest
2221 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2223 (* apply update_others to all patterns other than the matched
2224 one. This is used to desigate the others as test
2225 expressions in the TestExpression case *)
2227 (function (x,e,i
,d
) as all
->
2230 else (update_others
x,e,i
,d
))
2231 (List.hd
all_alts)) ::
2233 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2234 (List.tl
all_alts)) in
2235 (match List.concat
all_alts with
2236 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2238 let (new_metavars,mv_bindings
) =
2239 make_new_metavars metavars
(nub(List.concat bindings
)) in
2242 call_instantiate bindings mv_bindings
all_alts pattern
2243 (has_context pattern
)))) in
2244 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2245 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2246 | (alts
::rest
) as all_alts ->
2247 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2248 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2249 outer_loop prev_ecount prev_icount prev_dcount rest
2250 | Common.Right
(new_metavars,res) ->
2252 copy_minus printer minusify
e (disj_maker
res)) in
2253 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2254 (count
, metavars
, e)
2256 (* no one should ever look at the information stored in these mcodes *)
2257 let disj_starter lst
=
2258 let old_info = Ast0.get_info
(List.hd lst
) in
2260 { old_info.Ast0.pos_info
with
2261 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2262 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2264 { Ast0.pos_info
= new_pos_info;
2265 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2266 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2267 Ast0.strings_before
= []; Ast0.strings_after
= [];
2268 Ast0.isSymbolIdent
= false; } in
2269 Ast0.make_mcode_info
"(" info
2271 let disj_ender lst
=
2272 let old_info = Ast0.get_info
(List.hd lst
) in
2274 { old_info.Ast0.pos_info
with
2275 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2276 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2278 { Ast0.pos_info
= new_pos_info;
2279 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2280 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2281 Ast0.strings_before
= []; Ast0.strings_after
= [];
2282 Ast0.isSymbolIdent
= false; } in
2283 Ast0.make_mcode_info
")" info
2285 let disj_mid _ = Ast0.make_mcode
"|"
2287 let make_disj_type tl
=
2290 [] -> failwith
"bad disjunction"
2291 | x::xs
-> List.map
disj_mid xs
in
2292 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2293 let make_disj_stmt_list tl
=
2296 [] -> failwith
"bad disjunction"
2297 | x::xs
-> List.map
disj_mid xs
in
2298 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2299 let make_disj_expr model el
=
2302 [] -> failwith
"bad disjunction"
2303 | x::xs
-> List.map
disj_mid xs
in
2305 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2307 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2308 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2309 let el = List.map
update_arg (List.map
update_test el) in
2310 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2311 let make_disj_decl dl
=
2314 [] -> failwith
"bad disjunction"
2315 | x::xs
-> List.map
disj_mid xs
in
2316 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2317 let make_disj_stmt sl
=
2318 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2321 [] -> failwith
"bad disjunction"
2322 | x::xs
-> List.map
disj_mid xs
in
2324 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2326 let transform_type (metavars
,alts
,name
) e =
2328 (Ast0.TypeCTag
(_)::_)::_ ->
2329 (* start line is given to any leaves in the iso code *)
2331 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2337 (p
,count_edots.VT0.combiner_rec_typeC p
,
2338 count_idots.VT0.combiner_rec_typeC p
,
2339 count_dots.VT0.combiner_rec_typeC p
)
2340 | _ -> failwith
"invalid alt"))
2342 mkdisj match_typeC metavars
alts e
2343 (function b
-> function mv_b
->
2344 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2345 (function t
-> Ast0.TypeCTag t
)
2346 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2347 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2348 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2350 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2354 let transform_expr (metavars
,alts,name
) e =
2355 let process update_others
=
2356 (* start line is given to any leaves in the iso code *)
2358 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2363 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2364 (p
,count_edots.VT0.combiner_rec_expression p
,
2365 count_idots.VT0.combiner_rec_expression p
,
2366 count_dots.VT0.combiner_rec_expression p
)
2367 | _ -> failwith
"invalid alt"))
2369 mkdisj match_expr metavars
alts e
2370 (function b
-> function mv_b
->
2371 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2372 (function e -> Ast0.ExprTag
e)
2374 make_minus.VT0.rebuilder_rec_expression
2375 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2376 name
Unparse_ast0.expression extra_copy_other_plus update_others
2378 match Ast0.unwrap
x with
2379 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2383 (Ast0.ExprTag
(_)::r
)::rs
->
2384 (* hack to accomodate ToTestExpression case, where the first pattern is
2385 a normal expression, but the others are test expressions *)
2386 let others = r
@ (List.concat rs
) in
2387 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2388 if List.for_all
is_test others then process Ast0.set_test_exp
2389 else if List.exists
is_test others then failwith
"inconsistent iso"
2390 else process do_nothing
2391 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2392 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2393 process Ast0.set_test_exp
2396 let transform_decl (metavars
,alts,name
) e =
2398 (Ast0.DeclTag
(_)::_)::_ ->
2399 (* start line is given to any leaves in the iso code *)
2401 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2407 (p
,count_edots.VT0.combiner_rec_declaration p
,
2408 count_idots.VT0.combiner_rec_declaration p
,
2409 count_dots.VT0.combiner_rec_declaration p
)
2410 | _ -> failwith
"invalid alt"))
2412 mkdisj match_decl metavars
alts e
2413 (function b
-> function mv_b
->
2414 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2415 (function d
-> Ast0.DeclTag d
)
2417 make_minus.VT0.rebuilder_rec_declaration
2418 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2419 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2420 (function _ -> true (* no metavars *))
2423 let transform_stmt (metavars
,alts,name
) e =
2425 (Ast0.StmtTag
(_)::_)::_ ->
2426 (* start line is given to any leaves in the iso code *)
2428 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2434 (p
,count_edots.VT0.combiner_rec_statement p
,
2435 count_idots.VT0.combiner_rec_statement p
,
2436 count_dots.VT0.combiner_rec_statement p
)
2437 | _ -> failwith
"invalid alt"))
2439 mkdisj match_statement metavars
alts e
2440 (function b
-> function mv_b
->
2441 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2442 (function s -> Ast0.StmtTag
s)
2443 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2444 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2445 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2447 match Ast0.unwrap
x with
2448 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2452 (* sort of a hack, because there is no disj at top level *)
2453 let transform_top (metavars
,alts,name
) e =
2454 match Ast0.unwrap
e with
2455 Ast0.NONDECL
(declstm
) ->
2461 Ast0.DotsStmtTag
(d
) ->
2462 (match Ast0.unwrap d
with
2463 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2464 | _ -> raise
(Failure
""))
2465 | _ -> raise
(Failure
"")))
2467 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2468 (count
,mv
,Ast0.rewrap
e (Ast0.NONDECL
(s)))
2469 with Failure
_ -> (0,[],e))
2470 | Ast0.CODE
(stmts
) ->
2471 let (count
,mv
,res) =
2473 (Ast0.DotsStmtTag
(_)::_)::_ ->
2474 (* start line is given to any leaves in the iso code *)
2476 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2481 Ast0.DotsStmtTag
(p
) ->
2482 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2483 count_idots.VT0.combiner_rec_statement_dots p
,
2484 count_dots.VT0.combiner_rec_statement_dots p
)
2485 | _ -> failwith
"invalid alt"))
2487 mkdisj match_statement_dots metavars
alts stmts
2488 (function b
-> function mv_b
->
2489 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2490 (function s -> Ast0.DotsStmtTag
s)
2492 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2494 make_minus.VT0.rebuilder_rec_statement_dots
x)
2495 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2496 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2497 (function _ -> true)
2498 | _ -> (0,[],stmts
) in
2499 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2502 (* --------------------------------------------------------------------- *)
2504 let transform (alts : isomorphism
) t
=
2505 (* the following ugliness is because rebuilder only returns a new term *)
2506 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2507 let in_limit n
= function
2511 ((if !Flag_parsing_cocci.show_iso_failures
2512 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2514 let bind x y
= x + y
in
2515 let option_default = 0 in
2517 let (e_count
,e) = k
e in
2518 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2520 let (count
,extra_meta
,exp
) = transform_expr alts e in
2521 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2522 (bind count e_count
,exp
)
2526 let (e_count
,e) = k
e in
2527 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2529 let (count
,extra_meta
,dec
) = transform_decl alts e in
2530 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2531 (bind count e_count
,dec
)
2535 let (e_count
,e) = k
e in
2536 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2538 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2539 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2540 (bind count e_count
,stm
)
2544 let (continue
,e_count
,e) =
2545 match Ast0.unwrap
e with
2546 Ast0.Signed
(signb
,tyb
) ->
2547 (* Hack! How else to prevent iso from applying under an
2551 let (e_count
,e) = k
e in
2552 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2553 then (true,e_count
,e)
2554 else (false,e_count
,e) in
2557 let (count
,extra_meta
,ty
) = transform_type alts e in
2558 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2559 (bind count e_count
,ty
)
2563 let (e_count
,e) = k
e in
2564 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2566 let (count
,extra_meta
,ty
) = transform_top alts e in
2567 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2568 (bind count e_count
,ty
)
2572 V0.combiner_rebuilder
bind option_default
2573 {V0.combiner_rebuilder_functions
with
2574 VT0.combiner_rebuilder_exprfn
= exprfn;
2575 VT0.combiner_rebuilder_tyfn
= typefn;
2576 VT0.combiner_rebuilder_declfn
= declfn;
2577 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2578 VT0.combiner_rebuilder_topfn
= topfn} in
2579 let (_,res) = res.VT0.top_level t
in
2580 (!extra_meta_decls,res)
2582 (* --------------------------------------------------------------------- *)
2584 (* should be done by functorizing the parser to use wrap or context_wrap *)
2586 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2587 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2589 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2590 donothing donothing donothing donothing donothing donothing
2591 donothing donothing donothing donothing donothing donothing donothing
2594 let rewrap_anything = function
2595 Ast0.DotsExprTag
(d
) ->
2596 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2597 | Ast0.DotsInitTag
(d
) ->
2598 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2599 | Ast0.DotsParamTag
(d
) ->
2600 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2601 | Ast0.DotsStmtTag
(d
) ->
2602 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2603 | Ast0.DotsDeclTag
(d
) ->
2604 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2605 | Ast0.DotsCaseTag
(d
) ->
2606 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2607 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2608 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2609 | Ast0.ArgExprTag
(d
) ->
2610 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2611 | Ast0.TestExprTag
(d
) ->
2612 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2613 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2614 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2615 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2616 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2617 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2618 | Ast0.CaseLineTag
(d
) ->
2619 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2620 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2621 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2622 failwith
"only for isos within iso phase"
2623 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2624 | Ast0.HiddenVarTag
(p
) -> Ast0.HiddenVarTag
(p
) (* not sure it is possible *)
2626 (* --------------------------------------------------------------------- *)
2628 let apply_isos isos rule rule_name
=
2633 current_rule := rule_name
;
2636 (function (metavars
,iso
,name
) ->
2637 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2639 let (extra_meta
,rule
) =
2644 (function (extra_meta
,t
) -> function iso
->
2645 let (new_extra_meta
,t
) = transform iso t
in
2646 (new_extra_meta
@extra_meta
,t
))
2649 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)