2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* Potential problem: offset of mcode is not updated when an iso is
26 instantiated, implying that a term may end up with many mcodes with the
27 same offset. On the other hand, at the moment offset only seems to be used
28 before this phase. Furthermore add_dot_binding relies on the offset to
29 remain the same between matching an iso and instantiating it with bindings. *)
31 (* Consider whether ... in iso should match <... ...> in smpl? *)
33 (* --------------------------------------------------------------------- *)
34 (* match a SmPL expression against a SmPL abstract syntax tree,
37 module Ast
= Ast_cocci
38 module Ast0
= Ast0_cocci
39 module V0
= Visitor_ast0
40 module VT0
= Visitor_ast0_types
42 let current_rule = ref ""
44 (* --------------------------------------------------------------------- *)
47 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
50 let mcode (term
,_
,_
,_
,_
,_
) =
51 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
55 {(Ast0.wrap
(Ast0.unwrap
x)) with
56 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
57 Ast0.true_if_test
= x.Ast0.true_if_test
} in
59 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
60 donothing donothing donothing donothing donothing donothing
61 donothing donothing donothing donothing donothing donothing donothing
64 let anything_equal = function
65 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
66 failwith
"not a possible variable binding" (*not sure why these are pbs*)
67 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
68 failwith
"not a possible variable binding"
69 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
70 failwith
"not a possible variable binding"
71 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
72 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
73 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
74 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
75 failwith
"not a possible variable binding"
76 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
77 failwith
"not a possible variable binding"
78 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
79 (strip_info.VT0.rebuilder_rec_ident d1
) =
80 (strip_info.VT0.rebuilder_rec_ident d2
)
81 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
82 (strip_info.VT0.rebuilder_rec_expression d1
) =
83 (strip_info.VT0.rebuilder_rec_expression d2
)
84 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
85 failwith
"not possible - only in isos1"
86 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
87 failwith
"not possible - only in isos1"
88 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
89 (strip_info.VT0.rebuilder_rec_typeC d1
) =
90 (strip_info.VT0.rebuilder_rec_typeC d2
)
91 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
92 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
93 (strip_info.VT0.rebuilder_rec_initialiser d2
)
94 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
95 (strip_info.VT0.rebuilder_rec_parameter d1
) =
96 (strip_info.VT0.rebuilder_rec_parameter d2
)
97 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
98 (strip_info.VT0.rebuilder_rec_declaration d1
) =
99 (strip_info.VT0.rebuilder_rec_declaration d2
)
100 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
101 (strip_info.VT0.rebuilder_rec_statement d1
) =
102 (strip_info.VT0.rebuilder_rec_statement d2
)
103 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
104 (strip_info.VT0.rebuilder_rec_case_line d1
) =
105 (strip_info.VT0.rebuilder_rec_case_line d2
)
106 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
107 (strip_info.VT0.rebuilder_rec_top_level d1
) =
108 (strip_info.VT0.rebuilder_rec_top_level d2
)
109 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
110 failwith
"only for isos within iso phase"
111 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
112 failwith
"only for isos within iso phase"
113 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
114 failwith
"only for isos within iso phase"
117 let term (var1
,_
,_
,_
,_
,_
) = var1
118 let dot_term (var1
,_
,info
,_
,_
,_
) =
119 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
123 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
124 | NotPureLength
of Ast.meta_name
125 | ContextRequired
of Ast0.anything
127 | Braces
of Ast0.statement
128 | Nest
of Ast0.statement
129 | Position
of Ast.meta_name
131 | TypeMatch
of reason list
133 let rec interpret_reason name line reason printer
=
135 "warning: iso %s does not match the code below on line %d\n" name line
;
136 printer
(); Format.print_newline
();
138 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
140 "pure metavariable %s is matched against the following nonpure code:\n"
142 Unparse_ast0.unparse_anything nonpure
143 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
145 "context metavariable %s is matched against the following\nnoncontext code:\n"
147 Unparse_ast0.unparse_anything nonpure
148 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
150 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
152 Unparse_ast0.unparse_anything nonpure
153 | NotPureLength
((_
,var
)) ->
155 "pure metavariable %s is matched against too much or too little code\n"
157 | ContextRequired
(term) ->
159 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
160 Unparse_ast0.unparse_anything
term
162 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
163 Unparse_ast0.statement
"" s
;
164 Format.print_newline
()
166 Printf.printf
"iso with nest doesn't match whencode (TODO):\n";
167 Unparse_ast0.statement
"" s
;
168 Format.print_newline
()
169 | Position
(rule
,name
) ->
170 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
173 Printf.printf
"multiple position variables conflict with an isomorphism\n"
174 | TypeMatch reason_list
->
175 List.iter
(function r
-> interpret_reason name line r printer
)
177 | _
-> failwith
"not possible"
179 type 'a either
= OK
of 'a
| Fail
of reason
181 let add_binding var exp bindings
=
182 let var = term var in
183 let attempt bindings
=
185 let cur = List.assoc
var bindings
in
186 if anything_equal(exp
,cur) then [bindings
] else []
187 with Not_found
-> [((var,exp
)::bindings
)] in
188 match List.concat
(List.map
attempt bindings
) with
192 let add_dot_binding var exp bindings
=
193 let var = dot_term var in
194 let attempt bindings
=
196 let cur = List.assoc
var bindings
in
197 if anything_equal(exp
,cur) then [bindings
] else []
198 with Not_found
-> [((var,exp
)::bindings
)] in
199 match List.concat
(List.map
attempt bindings
) with
204 let add_multi_dot_binding var exp bindings
=
205 let var = dot_term var in
206 let attempt bindings
= [((var,exp
)::bindings
)] in
207 match List.concat
(List.map
attempt bindings
) with
214 | (x::xs
) when (List.mem
x xs
) -> nub xs
215 | (x::xs
) -> x::(nub xs
)
217 (* --------------------------------------------------------------------- *)
221 let debug str m binding
=
222 let res = m binding
in
224 None
-> Printf.printf
"%s: failed\n" str
228 Printf.printf
"%s: %s\n" str
229 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
233 let conjunct_bindings
234 (m1
: 'binding
-> 'binding either
)
235 (m2
: 'binding
-> 'binding either
)
236 (binding
: 'binding
) : 'binding either
=
237 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
239 let rec conjunct_many_bindings = function
240 [] -> failwith
"not possible"
242 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
244 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
246 let return b binding
= if b
then OK binding
else Fail NonMatch
247 let return_false reason binding
= Fail reason
249 let match_option f t1 t2
=
251 (Some t1
, Some t2
) -> f t1 t2
252 | (None
, None
) -> return true
255 let bool_match_option f t1 t2
=
257 (Some t1
, Some t2
) -> f t1 t2
258 | (None
, None
) -> true
261 (* context_required is for the example
265 where we can't change x == NULL to eg NULL == x. So there can either be
266 nothing attached to the root or the term has to be all removed.
267 if would be nice if we knew more about the relationship between the - and +
268 code, because in the case where the + code is a separate statement in a
269 sequence, this is not a problem. Perhaps something could be done in
272 The example seems strange. Why isn't the cast attached to x?
275 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
276 (match Ast0.get_mcodekind e
with
277 Ast0.CONTEXT
(cell
) -> true
280 (* needs a special case when there is a Disj or an empty DOTS
281 the following stops at the statement level, and gives true if one
282 statement is replaced by another *)
283 let rec is_pure_context s
=
284 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
285 (match Ast0.unwrap s
with
286 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
289 match Ast0.undots
x with
290 [s
] -> is_pure_context s
291 | _
-> false (* could we do better? *))
294 (match Ast0.get_mcodekind s
with
297 (Ast.NOTHING
,_
,_
) -> true
301 (* do better for the common case of replacing a stmt by another one *)
302 (Ast.REPLACEMENT
([[Ast.StatementTag
(s
)]],_
),_
) ->
303 (match Ast.unwrap s
with
304 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
310 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
312 let match_list matcher is_list_matcher do_list_match la lb
=
313 let rec loop = function
314 ([],[]) -> return true
315 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
316 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
317 | _
-> return false in
320 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
322 let match_maker checks_needed context_required whencode_allowed
=
324 let check_mcode pmc
(*pattern*) cmc
(*code*) binding
=
327 match Ast0.get_pos cmc
with
328 [(Ast0.MetaPos
(name
,_
,_
)) as x] ->
329 (match Ast0.get_pos pmc
with
330 [Ast0.MetaPos
(name1
,_
,_
)] ->
331 add_binding name1
(Ast0.MetaPosTag
x) binding
333 let (rule
,name
) = Ast0.unwrap_mcode name
in
334 Fail
(Position
(rule
,name
))
335 | _
-> Fail Multiposition
)
337 | _
-> Fail Multiposition
340 let match_dots matcher is_list_matcher do_list_match d1 d2
=
341 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
342 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
343 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
344 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
345 match_list matcher is_list_matcher
(do_list_match d2
) la lb
346 | _
-> return false in
348 let is_elist_matcher el
=
349 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
351 let is_plist_matcher pl
=
352 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
354 let is_slist_matcher pl
=
355 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
357 let no_list _
= false in
359 let build_dots pattern data
=
360 match Ast0.unwrap pattern
with
361 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
362 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
363 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
366 let bind = Ast0.lub_pure
in
367 let option_default = Ast0.Context
in
368 let pure_mcodekind mc
=
370 then Ast0.PureContext
375 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
379 (Ast.NOREPLACEMENT
,_
) -> Ast0.Pure
381 | _
-> Ast0.Impure
in
382 let donothing r k e
=
383 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
385 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
387 (* a case for everything that has a metavariable *)
388 (* pure is supposed to match only unitary metavars, not anything that
389 contains only unitary metavars *)
391 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
392 (match Ast0.unwrap i
with
393 Ast0.MetaId
(name
,_
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
394 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
395 | _
-> Ast0.Impure
) in
397 let expression r k e
=
398 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
399 (match Ast0.unwrap e
with
400 Ast0.MetaErr
(name
,_
,pure
)
401 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
403 | _
-> Ast0.Impure
) in
406 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
407 (match Ast0.unwrap t
with
408 Ast0.MetaType
(name
,pure
) -> pure
409 | _
-> Ast0.Impure
) in
412 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
413 (match Ast0.unwrap t
with
414 Ast0.MetaInit
(name
,pure
) | Ast0.MetaInitList
(name
,_
,pure
) -> pure
415 | _
-> Ast0.Impure
) in
418 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
419 (match Ast0.unwrap p
with
420 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
421 | _
-> Ast0.Impure
) in
424 bind (bind (pure_mcodekind (Ast0.get_mcodekind d
)) (k d
))
425 (match Ast0.unwrap d
with
426 Ast0.MetaDecl
(name
,pure
) | Ast0.MetaField
(name
,pure
)
427 | Ast0.MetaFieldList
(name
,_
,pure
) ->
429 | _
-> Ast0.Impure
) in
432 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
433 (match Ast0.unwrap s
with
434 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
435 | _
-> Ast0.Impure
) in
437 V0.flat_combiner
bind option_default
438 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
439 donothing donothing donothing donothing donothing donothing
440 ident expression typeC init param decl stmt donothing
443 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
444 match (checks_needed
,pure
) with
445 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
448 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
449 then add_binding name
(builder1 lst
)
450 else return_false (NotPure
(pure
,term name
,builder1 lst
))
451 | _
-> return_false (NotPureLength
(term name
)))
452 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
454 let add_pure_binding name pure is_pure builder
x =
455 match (checks_needed
,pure
) with
456 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
457 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
458 then add_binding name
(builder
x)
459 else return_false (NotPure
(pure
,term name
, builder
x))
460 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
462 let do_elist_match builder el lst
=
463 match Ast0.unwrap el
with
464 Ast0.MetaExprList
(name
,lenname
,pure
) ->
465 (*how to handle lenname? should it be an option type and always None?*)
466 failwith
"expr list pattern not supported in iso"
467 (*add_pure_list_binding name pure
468 pure_sp_code.V0.combiner_expression
469 (function lst -> Ast0.ExprTag(List.hd lst))
470 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
472 | _
-> failwith
"not possible" in
474 let do_plist_match builder pl lst
=
475 match Ast0.unwrap pl
with
476 Ast0.MetaParamList
(name
,lename
,pure
) ->
477 failwith
"param list pattern not supported in iso"
478 (*add_pure_list_binding name pure
479 pure_sp_code.V0.combiner_parameter
480 (function lst -> Ast0.ParamTag(List.hd lst))
481 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
483 | _
-> failwith
"not possible" in
485 let do_slist_match builder sl lst
=
486 match Ast0.unwrap sl
with
487 Ast0.MetaStmtList
(name
,pure
) ->
488 add_pure_list_binding name pure
489 pure_sp_code.VT0.combiner_rec_statement
490 (function lst
-> Ast0.StmtTag
(List.hd lst
))
491 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
493 | _
-> failwith
"not possible" in
495 let do_nolist_match _ _
= failwith
"not possible" in
497 let rec match_ident pattern id
=
498 match Ast0.unwrap pattern
with
499 Ast0.MetaId
(name
,_
,_
,pure
) ->
500 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
501 (function id
-> Ast0.IdentTag id
) id
)
502 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
503 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
505 if not
(checks_needed
) or not
(context_required
) or is_context id
507 match (up
,Ast0.unwrap id
) with
508 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
509 if mcode_equal namea nameb
510 then check_mcode namea nameb
512 | (Ast0.DisjId
(_
,ids
,_
,_
),_
) ->
513 failwith
"not allowed in the pattern of an isomorphism"
514 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
515 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
517 | (_
,Ast0.OptIdent
(idb
))
518 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
520 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
522 (* should we do something about matching metavars against ...? *)
523 let rec match_expr pattern expr
=
524 match Ast0.unwrap pattern
with
525 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
527 match (form
,expr
) with
531 match Ast0.unwrap e
with
532 Ast0.Constant
(c
) -> true
534 (match Ast0.unwrap c
with
536 let nm = Ast0.unwrap_mcode
nm in
537 (* all caps is a const *)
538 Str.string_match
all_caps nm 0
540 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
541 | Ast0.SizeOfExpr
(se
,exp
) -> true
542 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
543 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
544 (Ast0.lub_pure p pure
) = pure
547 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
549 match Ast0.unwrap e
with
550 Ast0.Ident
(c
) -> true
551 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
552 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
553 (Ast0.lub_pure p pure
) = pure
561 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
565 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
567 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
568 (* easier than updating type inferencer to manage multiple
570 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
571 | (_
,Some ty
) -> Some
[ty
]
575 let tyname = Ast0.rewrap_mcode name
tyname in
577 (add_pure_binding name pure
578 pure_sp_code.VT0.combiner_rec_expression
579 (function expr
-> Ast0.ExprTag expr
)
581 (function bindings
->
586 add_pure_binding tyname Ast0.Impure
587 (function _
-> Ast0.Impure
)
588 (function ty
-> Ast0.TypeCTag ty
)
590 (Ast0.reverse_type
expty))
594 "warning: unconvertible type";
595 return false bindings
))
598 (function Fail _
-> false | OK
x -> true)
601 (* not sure why this is ok. can there be more
605 (function Fail _
-> [] | OK
x -> x)
613 | OK
x -> failwith
"not possible")
617 "warning: type metavar can only match one type";*)
621 "mixture of metatype and other types not supported")
623 let expty = Ast0.get_type expr
in
624 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
626 add_pure_binding name pure
627 pure_sp_code.VT0.combiner_rec_expression
628 (function expr
-> Ast0.ExprTag expr
)
632 add_pure_binding name pure
633 pure_sp_code.VT0.combiner_rec_expression
634 (function expr
-> Ast0.ExprTag expr
)
637 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
638 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
640 if not
(checks_needed
) or not
(context_required
) or is_context expr
642 match (up
,Ast0.unwrap expr
) with
643 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
645 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
646 if mcode_equal consta constb
647 then check_mcode consta constb
649 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
650 conjunct_many_bindings
651 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
652 match_dots match_expr is_elist_matcher do_elist_match
654 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
655 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
656 if mcode_equal opa opb
658 conjunct_many_bindings
659 [check_mcode opa opb
; match_expr lefta leftb
;
660 match_expr righta rightb
]
662 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
663 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
664 conjunct_many_bindings
665 [check_mcode lp1 lp
; check_mcode rp1 rp
;
666 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
667 match_expr exp3a exp3b
]
668 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
669 if mcode_equal opa opb
671 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
673 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
674 if mcode_equal opa opb
676 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
678 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
679 if mcode_equal opa opb
681 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
683 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
684 if mcode_equal opa opb
686 conjunct_many_bindings
687 [check_mcode opa opb
; match_expr lefta leftb
;
688 match_expr righta rightb
]
690 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
691 conjunct_many_bindings
692 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
693 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
694 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
695 conjunct_many_bindings
696 [check_mcode lb1 lb
; check_mcode rb1 rb
;
697 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
698 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
699 Ast0.RecordAccess
(expb
,op
,fieldb
))
700 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
701 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
702 conjunct_many_bindings
703 [check_mcode opa op
; match_expr expa expb
;
704 match_ident fielda fieldb
]
705 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
706 conjunct_many_bindings
707 [check_mcode lp1 lp
; check_mcode rp1 rp
;
708 match_typeC tya tyb
; match_expr expa expb
]
709 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
710 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
711 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
712 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
713 conjunct_many_bindings
714 [check_mcode lp1 lp
; check_mcode rp1 rp
;
715 check_mcode szf1 szf
; match_typeC tya tyb
]
716 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
718 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
719 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
720 failwith
"not allowed in the pattern of an isomorphism"
721 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
722 failwith
"not allowed in the pattern of an isomorphism"
723 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
724 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
725 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
726 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
727 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
728 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
729 (* hope that mcode of edots is unique somehow *)
730 conjunct_bindings (check_mcode ed ed1
)
731 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
732 if edots_whencode_allowed
733 then add_dot_binding ed
(Ast0.ExprTag wc
)
736 "warning: not applying iso because of whencode";
738 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
739 | (Ast0.Estars
(_
,Some _
),_
) ->
740 failwith
"whencode not allowed in a pattern1"
741 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
742 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
743 | (_
,Ast0.OptExp
(expb
))
744 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
746 else return_false (ContextRequired
(Ast0.ExprTag expr
))
748 (* the special case for function types prevents the eg T X; -> T X = E; iso
749 from applying, which doesn't seem very relevant, but it also avoids a
750 mysterious bug that is obtained with eg int attach(...); *)
751 and match_typeC pattern t
=
752 match Ast0.unwrap pattern
with
753 Ast0.MetaType
(name
,pure
) ->
754 (match Ast0.unwrap t
with
755 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
757 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
758 (function ty
-> Ast0.TypeCTag ty
)
761 if not
(checks_needed
) or not
(context_required
) or is_context t
763 match (up
,Ast0.unwrap t
) with
764 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
765 if mcode_equal cva cvb
767 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
769 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
772 match_list check_mcode
773 (function _
-> false) (function _
-> failwith
"")
776 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
777 if mcode_equal signa signb
779 conjunct_bindings (check_mcode signa signb
)
780 (match_option match_typeC tya tyb
)
782 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
783 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
784 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
785 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
786 conjunct_many_bindings
787 [check_mcode stara starb
; check_mcode lp1a lp1b
;
788 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
789 check_mcode rp2a rp2b
; match_typeC tya tyb
;
790 match_dots match_param
is_plist_matcher
791 do_plist_match paramsa paramsb
]
792 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
793 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
794 conjunct_many_bindings
795 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
796 match_option match_typeC tya tyb
;
797 match_dots match_param
is_plist_matcher do_plist_match
799 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
800 conjunct_many_bindings
801 [check_mcode lb1 lb
; check_mcode rb1 rb
;
802 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
803 | (Ast0.EnumName
(kinda
,Some namea
),
804 Ast0.EnumName
(kindb
,Some nameb
)) ->
805 conjunct_bindings (check_mcode kinda kindb
)
806 (match_ident namea nameb
)
807 | (Ast0.EnumDef
(tya
,lb1
,idsa
,rb1
),
808 Ast0.EnumDef
(tyb
,lb
,idsb
,rb
)) ->
809 conjunct_many_bindings
810 [check_mcode lb1 lb
; check_mcode rb1 rb
;
812 match_dots match_expr no_list do_nolist_match idsa idsb
]
813 | (Ast0.StructUnionName
(kinda
,Some namea
),
814 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
815 if mcode_equal kinda kindb
817 conjunct_bindings (check_mcode kinda kindb
)
818 (match_ident namea nameb
)
820 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
821 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
822 conjunct_many_bindings
823 [check_mcode lb1 lb
; check_mcode rb1 rb
;
825 match_dots match_decl
no_list do_nolist_match declsa declsb
]
826 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
827 if mcode_equal namea nameb
828 then check_mcode namea nameb
830 | (Ast0.DisjType
(_
,typesa
,_
,_
),_
) ->
831 failwith
"not allowed in the pattern of an isomorphism"
832 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
833 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
834 | (_
,Ast0.OptType
(tyb
))
835 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
837 else return_false (ContextRequired
(Ast0.TypeCTag t
))
839 and match_decl pattern d
=
840 match Ast0.unwrap pattern
with
841 Ast0.MetaDecl
(name
,pure
) ->
842 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
843 (function d
-> Ast0.DeclTag d
)
845 | Ast0.MetaField
(name
,pure
) ->
846 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
847 (function d
-> Ast0.DeclTag d
)
849 | Ast0.MetaFieldList
(name
,_
,pure
) -> failwith
"metafieldlist not supporte"
851 if not
(checks_needed
) or not
(context_required
) or is_context d
853 match (up
,Ast0.unwrap d
) with
854 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
855 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
856 if bool_match_option mcode_equal stga stgb
858 conjunct_many_bindings
859 [check_mcode eq1 eq
; check_mcode sc1 sc
;
860 match_option check_mcode stga stgb
;
861 match_typeC tya tyb
; match_ident ida idb
;
862 match_init inia inib
]
864 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
865 if bool_match_option mcode_equal stga stgb
867 conjunct_many_bindings
868 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
869 match_typeC tya tyb
; match_ident ida idb
]
871 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
872 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
873 conjunct_many_bindings
874 [match_ident namea nameb
;
875 check_mcode lp1 lp
; check_mcode rp1 rp
;
877 match_dots match_expr is_elist_matcher do_elist_match
879 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
880 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
881 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
882 conjunct_bindings (check_mcode sc1 sc
)
883 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
884 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),_
) ->
885 failwith
"not allowed in the pattern of an isomorphism"
886 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
887 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
888 conjunct_bindings (check_mcode dd d
)
889 (* hope that mcode of ddots is unique somehow *)
890 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
891 if ddots_whencode_allowed
892 then add_dot_binding dd
(Ast0.DeclTag wc
)
894 (Printf.printf
"warning: not applying iso because of whencode";
896 | (Ast0.Ddots
(_
,Some _
),_
) ->
897 failwith
"whencode not allowed in a pattern1"
899 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
900 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
901 match_decl decla declb
902 | (_
,Ast0.OptDecl
(declb
))
903 | (_
,Ast0.UniqueDecl
(declb
)) ->
904 match_decl pattern declb
906 else return_false (ContextRequired
(Ast0.DeclTag d
))
908 and match_init pattern i
=
909 match Ast0.unwrap pattern
with
910 Ast0.MetaInit
(name
,pure
) ->
911 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
912 (function ini
-> Ast0.InitTag ini
)
915 if not
(checks_needed
) or not
(context_required
) or is_context i
917 match (up
,Ast0.unwrap i
) with
918 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
920 | (Ast0.InitList
(lb1
,initlista
,rb1
,oa
),
921 Ast0.InitList
(lb
,initlistb
,rb
,ob
))
923 conjunct_many_bindings
924 [check_mcode lb1 lb
; check_mcode rb1 rb
;
925 match_dots match_init
no_list do_nolist_match
927 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
928 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
929 conjunct_many_bindings
930 [match_list match_designator
931 (function _
-> false) (function _
-> failwith
"")
932 designators1 designators2
;
934 match_init inia inib
]
935 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
936 conjunct_many_bindings
937 [check_mcode c1 c
; match_ident namea nameb
;
938 match_init inia inib
]
939 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
940 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
941 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
942 conjunct_bindings (check_mcode id d
)
943 (* hope that mcode of edots is unique somehow *)
944 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
945 if idots_whencode_allowed
946 then add_dot_binding id
(Ast0.InitTag wc
)
949 "warning: not applying iso because of whencode";
951 | (Ast0.Idots
(_
,Some _
),_
) ->
952 failwith
"whencode not allowed in a pattern2"
953 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
954 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
955 | (_
,Ast0.OptIni
(ib
))
956 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
958 else return_false (ContextRequired
(Ast0.InitTag i
))
960 and match_designator pattern d
=
961 match (pattern
,d
) with
962 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
963 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
964 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
965 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
966 conjunct_many_bindings
967 [check_mcode lba lbb
; match_expr expa expb
;
969 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
970 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
971 conjunct_many_bindings
972 [check_mcode lba lbb
; match_expr mina minb
;
973 check_mcode dotsa dotsb
; match_expr maxa maxb
;
977 and match_param pattern p
=
978 match Ast0.unwrap pattern
with
979 Ast0.MetaParam
(name
,pure
) ->
980 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
981 (function p
-> Ast0.ParamTag p
)
983 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
985 if not
(checks_needed
) or not
(context_required
) or is_context p
987 match (up
,Ast0.unwrap p
) with
988 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
989 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
990 conjunct_bindings (match_typeC tya tyb
)
991 (match_option match_ident ida idb
)
992 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
993 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
994 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
995 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
996 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
997 match_param parama paramb
998 | (_
,Ast0.OptParam
(paramb
))
999 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
1001 else return_false (ContextRequired
(Ast0.ParamTag p
))
1003 and match_statement pattern s
=
1004 match Ast0.unwrap pattern
with
1005 Ast0.MetaStmt
(name
,pure
) ->
1006 (match Ast0.unwrap s
with
1007 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
1008 return false (* ... is not a single statement *)
1010 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
1011 (function ty
-> Ast0.StmtTag ty
)
1013 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1015 if not
(checks_needed
) or not
(context_required
) or is_context s
1017 match (up
,Ast0.unwrap s
) with
1018 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
1019 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
1020 conjunct_many_bindings
1021 [check_mcode lp1 lp
; check_mcode rp1 rp
;
1022 check_mcode lb1 lb
; check_mcode rb1 rb
;
1023 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
1024 match_dots match_param
is_plist_matcher do_plist_match
1026 match_dots match_statement
is_slist_matcher do_slist_match
1028 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
1029 match_decl decla declb
1030 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
1031 (* seqs can only match if they are all minus (plus code
1032 allowed) or all context (plus code not allowed in the body).
1033 we could be more permissive if the expansions of the isos are
1034 also all seqs, but this would be hard to check except at top
1035 level, and perhaps not worth checking even in that case.
1036 Overall, the issue is that braces are used where single
1037 statements are required, and something not satisfying these
1038 conditions can cause a single statement to become a
1039 non-single statement after the transformation.
1041 example: if { ... -foo(); ... }
1042 if we let the sequence convert to just -foo();
1043 then we produce invalid code. For some reason,
1044 single_statement can't deal with this case, perhaps because
1045 it starts introducing too many braces? don't remember the
1048 conjunct_bindings (check_mcode lb1 lb
)
1049 (conjunct_bindings (check_mcode rb1 rb
)
1050 (if not
(checks_needed
) or is_minus s
or
1052 List.for_all
is_pure_context (Ast0.undots bodyb
))
1054 match_dots match_statement
is_slist_matcher do_slist_match
1056 else return_false (Braces
(s
))))
1057 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1058 conjunct_bindings (check_mcode sc1 sc
)
1059 (match_option match_expr expa expb
)
1060 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1061 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1062 conjunct_many_bindings
1063 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1064 check_mcode rp1 rp2
;
1065 match_expr expa expb
;
1066 match_statement branch1a branch1b
]
1067 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1068 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1069 conjunct_many_bindings
1070 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1071 check_mcode rp1 rp2
; check_mcode e1 e2
;
1072 match_expr expa expb
;
1073 match_statement branch1a branch1b
;
1074 match_statement branch2a branch2b
]
1075 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1076 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1077 conjunct_many_bindings
1078 [check_mcode w1 w
; check_mcode lp1 lp
;
1079 check_mcode rp1 rp
; match_expr expa expb
;
1080 match_statement bodya bodyb
]
1081 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1082 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1083 conjunct_many_bindings
1084 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1085 check_mcode rp1 rp
; match_statement bodya bodyb
;
1086 match_expr expa expb
]
1087 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1088 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1089 conjunct_many_bindings
1090 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1091 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1092 match_option match_expr e1a e1b
;
1093 match_option match_expr e2a e2b
;
1094 match_option match_expr e3a e3b
;
1095 match_statement bodya bodyb
]
1096 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1097 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1098 conjunct_many_bindings
1099 [match_ident nma nmb
;
1100 check_mcode lp1 lp
; check_mcode rp1 rp
;
1101 match_dots match_expr is_elist_matcher do_elist_match
1103 match_statement bodya bodyb
]
1104 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1105 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1106 conjunct_many_bindings
1107 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1108 check_mcode lb1 lb
; check_mcode rb1 rb
;
1109 match_expr expa expb
;
1110 match_dots match_statement
is_slist_matcher do_slist_match
1112 match_dots match_case_line
no_list do_nolist_match
1114 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1115 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1116 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1117 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1118 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1119 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1120 conjunct_many_bindings
1121 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1122 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1123 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1124 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1125 conjunct_many_bindings
1126 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1127 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1128 failwith
"disj not supported in patterns"
1129 | (Ast0.Nest
(_
,stmt_dotsa
,_
,[],multia
),
1130 Ast0.Nest
(_
,stmt_dotsb
,_
,wc
,multib
)) ->
1135 (* not sure this is correct, perhaps too restrictive *)
1136 if not
(checks_needed
) or is_minus s
or
1138 List.for_all
is_pure_context (Ast0.undots stmt_dotsb
))
1140 match_dots match_statement
1141 is_slist_matcher do_slist_match
1142 stmt_dotsa stmt_dotsb
1143 else return_false (Braces
(s
))
1144 | _
-> return_false (Nest
(s
)))
1145 else return false (* diff kind of nest *)
1146 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1147 failwith
"nest with whencode not supported in patterns"
1148 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1149 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1150 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1151 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1152 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1153 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1154 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1155 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1157 [] -> check_mcode d d1
1159 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1160 if dots_whencode_allowed
1162 conjunct_bindings (check_mcode d d1
)
1166 | Ast0.WhenNot wc
->
1167 conjunct_bindings prev
1168 (add_multi_dot_binding d
1169 (Ast0.DotsStmtTag wc
))
1170 | Ast0.WhenAlways wc
->
1171 conjunct_bindings prev
1172 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1173 | Ast0.WhenNotTrue wc
->
1174 conjunct_bindings prev
1175 (add_multi_dot_binding d
1176 (Ast0.IsoWhenTTag wc
))
1177 | Ast0.WhenNotFalse wc
->
1178 conjunct_bindings prev
1179 (add_multi_dot_binding d
1180 (Ast0.IsoWhenFTag wc
))
1181 | Ast0.WhenModifier
(x) ->
1182 conjunct_bindings prev
1183 (add_multi_dot_binding d
1184 (Ast0.IsoWhenTag
x)))
1188 "warning: not applying iso because of whencode";
1190 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1191 | (Ast0.Stars
(_
,_
::_
),_
) ->
1192 failwith
"whencode not allowed in a pattern3"
1193 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1194 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1195 match_statement rea reb
1196 | (_
,Ast0.OptStm
(reb
))
1197 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1199 else return_false (ContextRequired
(Ast0.StmtTag s
))
1201 (* first should provide a subset of the information in the second *)
1202 and match_fninfo patterninfo cinfo
=
1203 let patterninfo = List.sort compare
patterninfo in
1204 let cinfo = List.sort compare
cinfo in
1205 let rec loop = function
1206 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1207 if mcode_equal sta stb
1208 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1210 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1211 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1212 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1213 if mcode_equal ia ib
1214 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1216 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1217 if mcode_equal ia ib
1218 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1220 | (x::resta
,((y
::_
) as restb
)) ->
1221 (match compare
x y
with
1223 | 1 -> loop (resta
,restb
)
1224 | _
-> failwith
"not possible")
1225 | _
-> return false in
1226 loop (patterninfo,cinfo)
1228 and match_case_line pattern c
=
1229 if not
(checks_needed
) or not
(context_required
) or is_context c
1231 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1232 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1233 conjunct_many_bindings
1234 [check_mcode d1 d
; check_mcode c1 c
;
1235 match_dots match_statement
is_slist_matcher do_slist_match
1237 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1238 conjunct_many_bindings
1239 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1240 match_dots match_statement
is_slist_matcher do_slist_match
1242 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1243 failwith
"not allowed in the pattern of an isomorphism"
1244 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1245 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1247 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1249 let match_statement_dots x y
=
1250 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1252 (match_expr, match_decl
, match_statement
, match_typeC
,
1253 match_statement_dots)
1255 let match_expr dochecks context_required whencode_allowed
=
1256 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1259 let match_decl dochecks context_required whencode_allowed
=
1260 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1263 let match_statement dochecks context_required whencode_allowed
=
1264 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1267 let match_typeC dochecks context_required whencode_allowed
=
1268 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1271 let match_statement_dots dochecks context_required whencode_allowed
=
1272 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1275 (* --------------------------------------------------------------------- *)
1276 (* make an entire tree MINUS *)
1279 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1281 match mcodekind
with
1284 (Ast.NOTHING
,_
,_
) ->
1285 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1286 | _
-> failwith
"make_minus: unexpected befaft")
1287 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1288 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1289 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1291 let update_mc mcodekind e
=
1292 match !mcodekind
with
1295 (Ast.NOTHING
,_
,_
) ->
1297 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1298 | _
-> failwith
"make_minus: unexpected befaft")
1299 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1300 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1301 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1303 let donothing r k e
=
1304 let mcodekind = Ast0.get_mcodekind_ref e
in
1305 let e = k
e in update_mc mcodekind e; e in
1307 (* special case for whencode, because it isn't processed by contextneg,
1308 since it doesn't appear in the + code *)
1309 (* cases for dots and nests *)
1310 let expression r k
e =
1311 let mcodekind = Ast0.get_mcodekind_ref
e in
1312 match Ast0.unwrap
e with
1313 Ast0.Edots
(d
,whencode
) ->
1314 (*don't recurse because whencode hasn't been processed by context_neg*)
1315 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1316 | Ast0.Ecircles
(d
,whencode
) ->
1317 (*don't recurse because whencode hasn't been processed by context_neg*)
1318 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1319 | Ast0.Estars
(d
,whencode
) ->
1320 (*don't recurse because whencode hasn't been processed by context_neg*)
1321 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1322 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1323 update_mc mcodekind e;
1325 (Ast0.NestExpr
(mcode starter
,
1326 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1327 mcode ender
,whencode
,multi
))
1328 | _
-> donothing r k
e in
1330 let declaration r k
e =
1331 let mcodekind = Ast0.get_mcodekind_ref
e in
1332 match Ast0.unwrap
e with
1333 Ast0.Ddots
(d
,whencode
) ->
1334 (*don't recurse because whencode hasn't been processed by context_neg*)
1335 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1336 | _
-> donothing r k
e in
1338 let statement r k
e =
1339 let mcodekind = Ast0.get_mcodekind_ref
e in
1340 match Ast0.unwrap
e with
1341 Ast0.Dots
(d
,whencode
) ->
1342 (*don't recurse because whencode hasn't been processed by context_neg*)
1343 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1344 | Ast0.Circles
(d
,whencode
) ->
1345 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1346 | Ast0.Stars
(d
,whencode
) ->
1347 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1348 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1349 update_mc mcodekind e;
1352 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1353 mcode ender
,whencode
,multi
))
1354 | _
-> donothing r k
e in
1356 let initialiser r k
e =
1357 let mcodekind = Ast0.get_mcodekind_ref
e in
1358 match Ast0.unwrap
e with
1359 Ast0.Idots
(d
,whencode
) ->
1360 (*don't recurse because whencode hasn't been processed by context_neg*)
1361 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1362 | _
-> donothing r k
e in
1365 let info = Ast0.get_info
e in
1366 let mcodekind = Ast0.get_mcodekind_ref
e in
1367 match Ast0.unwrap
e with
1369 (* if context is - this should be - as well. There are no tokens
1370 here though, so the bottom-up minusifier in context_neg leaves it
1371 as mixed (or context for sgrep2). It would be better to fix
1372 context_neg, but that would
1373 require a special case for each term with a dots subterm. *)
1374 (match !mcodekind with
1375 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1377 (Ast.NOTHING
,_
,_
) ->
1379 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
));
1381 | _
-> failwith
"make_minus: unexpected befaft")
1382 (* code already processed by an enclosing iso *)
1383 | Ast0.MINUS
(mc
) -> e
1387 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1388 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1389 | _
-> donothing r k
e in
1392 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1393 dots dots dots dots dots dots
1394 donothing expression donothing initialiser donothing declaration
1395 statement donothing donothing
1397 (* --------------------------------------------------------------------- *)
1398 (* rebuild mcode cells in an instantiated alt *)
1400 (* mcodes will be side effected later with plus code, so we have to copy
1401 them on instantiating an isomorphism. One could wonder whether it would
1402 be better not to use side-effects, but they are convenient for insert_plus
1403 where is it useful to manipulate a list of the mcodes but side-effect a
1405 (* hmm... Insert_plus is called before Iso_pattern... *)
1406 let rebuild_mcode start_line
=
1407 let copy_mcodekind = function
1408 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1409 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1410 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1411 | Ast0.PLUS count
->
1412 (* this function is used elsewhere where we need to rebuild the
1413 indices, and so we allow PLUS code as well *)
1416 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1418 match start_line
with
1421 {info.Ast0.pos_info
with
1422 Ast0.line_start
= x;
1423 Ast0.line_end
= x; } in
1424 {info with Ast0.pos_info
= new_pos_info}
1426 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1429 let old_info = Ast0.get_info
x in
1431 match start_line
with
1434 {old_info.Ast0.pos_info
with
1435 Ast0.line_start
= x;
1436 Ast0.line_end
= x; } in
1437 {old_info with Ast0.pos_info
= new_pos_info}
1438 | None
-> old_info in
1439 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1440 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1442 let donothing r k
e = copy_one (k
e) in
1444 (* case for control operators (if, etc) *)
1445 let statement r k
e =
1450 (match Ast0.unwrap
s with
1451 Ast0.Decl
((info,mc
),decl) ->
1452 Ast0.Decl
((info,copy_mcodekind mc
),decl)
1453 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1454 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1455 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1456 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1457 (info,copy_mcodekind mc
))
1458 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1459 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1460 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1461 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1462 (info,copy_mcodekind mc
))
1463 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1464 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1466 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1468 ((info,copy_mcodekind mc
),
1469 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1471 Ast0.set_dots_bef_aft
res
1472 (match Ast0.get_dots_bef_aft
res with
1473 Ast0.NoDots
-> Ast0.NoDots
1474 | Ast0.AddingBetweenDots
s ->
1475 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1476 | Ast0.DroppingBetweenDots
s ->
1477 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1480 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1481 donothing donothing donothing donothing donothing donothing
1482 donothing donothing donothing donothing donothing
1483 donothing statement donothing donothing
1485 (* --------------------------------------------------------------------- *)
1486 (* The problem of whencode. If an isomorphism contains dots in multiple
1487 rules, then the code that is matched cannot contain whencode, because we
1488 won't know which dots it goes with. Should worry about nests, but they
1489 aren't allowed in isomorphisms for the moment. *)
1492 let option_default = 0 in
1493 let bind x y
= x + y
in
1495 match Ast0.unwrap
e with
1496 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1499 V0.combiner
bind option_default
1500 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1503 let option_default = 0 in
1504 let bind x y
= x + y
in
1506 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1508 V0.combiner
bind option_default
1509 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1512 let option_default = 0 in
1513 let bind x y
= x + y
in
1515 match Ast0.unwrap
e with
1516 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1519 V0.combiner
bind option_default
1520 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1522 (* --------------------------------------------------------------------- *)
1524 let lookup name bindings mv_bindings
=
1525 try Common.Left
(List.assoc
(term name
) bindings
)
1528 (* failure is not possible anymore *)
1529 Common.Right
(List.assoc
(term name
) mv_bindings
)
1531 (* mv_bindings is for the fresh metavariables that are introduced by the
1533 let instantiate bindings mv_bindings
=
1536 List.map
(function Ast0.MetaPos
(name
,_
,_
) -> name
) (Ast0.get_pos
x) in
1542 match lookup name bindings mv_bindings
with
1543 Common.Left
(Ast0.MetaPosTag
(id
)) -> id
::prev
1544 | _
-> failwith
"not possible"
1545 with Not_found
-> prev
)
1547 Ast0.set_pos
new_names x in
1548 let donothing r k
e = k
e in
1550 (* cases where metavariables can occur *)
1553 match Ast0.unwrap
e with
1554 Ast0.MetaId
(name
,constraints
,seed
,pure
) ->
1555 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1556 (match lookup name bindings mv_bindings
with
1557 Common.Left
(Ast0.IdentTag
(id
)) -> id
1558 | Common.Left
(_
) -> failwith
"not possible 1"
1559 | Common.Right
(new_mv
) ->
1562 (Ast0.set_mcode_data new_mv name
,constraints
,seed
,pure
)))
1563 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1564 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1567 (* case for list metavariables *)
1568 let rec elist r same_dots
= function
1571 (match Ast0.unwrap
x with
1572 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1573 failwith
"meta_expr_list in iso not supported"
1574 (*match lookup name bindings mv_bindings with
1575 Common.Left(Ast0.DotsExprTag(exp)) ->
1576 (match same_dots exp with
1578 | None -> failwith "dots put in incompatible context")
1579 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1580 | Common.Left(_) -> failwith "not possible 1"
1581 | Common.Right(new_mv) ->
1582 failwith "MetaExprList in SP not supported"*)
1583 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1584 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1586 let rec plist r same_dots
= function
1589 (match Ast0.unwrap
x with
1590 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1591 failwith
"meta_param_list in iso not supported"
1592 (*match lookup name bindings mv_bindings with
1593 Common.Left(Ast0.DotsParamTag(param)) ->
1594 (match same_dots param with
1596 | None -> failwith "dots put in incompatible context")
1597 | Common.Left(Ast0.ParamTag(param)) -> [param]
1598 | Common.Left(_) -> failwith "not possible 1"
1599 | Common.Right(new_mv) ->
1600 failwith "MetaExprList in SP not supported"*)
1601 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1602 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1604 let rec slist r same_dots
= function
1607 (match Ast0.unwrap
x with
1608 Ast0.MetaStmtList
(name
,pure
) ->
1609 (match lookup name bindings mv_bindings
with
1610 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1611 (match same_dots stm
with
1613 | None
-> failwith
"dots put in incompatible context")
1614 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1615 | Common.Left
(_
) -> failwith
"not possible 1"
1616 | Common.Right
(new_mv
) ->
1617 failwith
"MetaExprList in SP not supported")
1618 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1619 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1622 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1623 let same_circles d
=
1624 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1626 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1628 let dots list_fn r k d
=
1630 (match Ast0.unwrap d
with
1631 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1632 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1633 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1635 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1638 match Ast0.unwrap
e with
1639 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1640 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1641 (match lookup name bindings mv_bindings
with
1642 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1643 | Common.Left
(_
) -> failwith
"not possible 1"
1644 | Common.Right
(new_mv
) ->
1649 let rec renamer = function
1650 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1652 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1654 Common.Left
(Ast0.TypeCTag
(t
)) ->
1655 Ast0.ast0_type_to_type t
1657 failwith
"iso pattern: unexpected type"
1658 | Common.Right
(new_mv
) ->
1659 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1660 | Type_cocci.ConstVol
(cv
,ty
) ->
1661 Type_cocci.ConstVol
(cv
,renamer ty
)
1662 | Type_cocci.Pointer
(ty
) ->
1663 Type_cocci.Pointer
(renamer ty
)
1664 | Type_cocci.FunctionPointer
(ty
) ->
1665 Type_cocci.FunctionPointer
(renamer ty
)
1666 | Type_cocci.Array
(ty
) ->
1667 Type_cocci.Array
(renamer ty
)
1669 Some
(List.map
renamer types
) in
1672 (Ast0.set_mcode_data new_mv name
,constraints
,
1673 new_types,form
,pure
)))
1674 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1675 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1676 failwith
"metaexprlist not supported"
1677 | Ast0.Unary
(exp
,unop
) ->
1678 (match Ast0.unwrap_mcode unop
with
1679 (* propagate negation only when the propagated and the encountered
1680 negation have the same transformation, when there is nothing
1681 added to the original one, and when there is nothing added to
1682 the expression into which we are doing the propagation. This
1683 may be too conservative. *)
1686 (* k e doesn't change the outer structure of the term,
1687 only the metavars *)
1688 match Ast0.unwrap old_e
with
1689 Ast0.Unary
(exp
,_
) ->
1690 (match Ast0.unwrap exp
with
1691 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1693 | _
-> failwith
"not possible" in
1694 let nomodif = function
1697 (Ast.NOREPLACEMENT
,_
) -> true
1699 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1701 (Ast.NOTHING
,_
,_
) -> true
1703 | _
-> failwith
"plus not possible" in
1704 let same_modif newop oldop
=
1705 (* only propagate ! is they have the same modification
1706 and no + code on the old one (the new one from the iso
1707 surely has no + code) *)
1708 match (newop
,oldop
) with
1709 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1710 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1711 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1716 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1717 (* k accumulates parens, to keep negation outside if no
1718 propagation is possible *)
1719 if nomodif (Ast0.get_mcodekind
e)
1721 match Ast0.unwrap
res with
1722 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1724 (Ast0.get_mcode_mcodekind unop
)
1725 (Ast0.get_mcode_mcodekind op
) ->
1727 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1728 | Ast0.Paren
(lp
,e1,rp
) ->
1731 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1732 | Ast0.Binary
(e1,op
,e2
) when
1734 (Ast0.get_mcode_mcodekind unop
)
1735 (Ast0.get_mcode_mcodekind op
) ->
1737 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1738 let k1 x = k
(Ast0.rewrap
e x) in
1739 (match Ast0.unwrap_mcode op
with
1740 Ast.Logical
(Ast.Inf
) ->
1741 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1742 | Ast.Logical
(Ast.Sup
) ->
1743 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1744 | Ast.Logical
(Ast.InfEq
) ->
1745 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1746 | Ast.Logical
(Ast.SupEq
) ->
1747 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1748 | Ast.Logical
(Ast.Eq
) ->
1749 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1750 | Ast.Logical
(Ast.NotEq
) ->
1751 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1752 | Ast.Logical
(Ast.AndLog
) ->
1753 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1755 negate_reb
e e2
idcont))
1756 | Ast.Logical
(Ast.OrLog
) ->
1757 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1759 negate_reb
e e2
idcont))
1763 Ast0.rewrap_mcode op
Ast.Not
)))
1764 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1765 (* use res because it is the transformed argument *)
1767 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1768 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1770 (*use e, because this might be the toplevel expression*)
1772 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1775 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1776 and negate_reb
e e1 k
=
1777 (* used when ! is propagated to multiple places, to avoid
1778 duplicating mcode cells *)
1780 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1781 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1786 | Ast0.Edots
(d
,_
) ->
1788 (match List.assoc
(dot_term d
) bindings
with
1789 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1790 | _
-> failwith
"unexpected binding")
1791 with Not_found
-> e)
1792 | Ast0.Ecircles
(d
,_
) ->
1794 (match List.assoc
(dot_term d
) bindings
with
1795 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1796 | _
-> failwith
"unexpected binding")
1797 with Not_found
-> e)
1798 | Ast0.Estars
(d
,_
) ->
1800 (match List.assoc
(dot_term d
) bindings
with
1801 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1802 | _
-> failwith
"unexpected binding")
1803 with Not_found
-> e)
1805 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1809 match Ast0.unwrap
e with
1810 Ast0.MetaType
(name
,pure
) ->
1811 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1812 (match lookup name bindings mv_bindings
with
1813 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1814 | Common.Left
(_
) -> failwith
"not possible 1"
1815 | Common.Right
(new_mv
) ->
1817 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1822 match Ast0.unwrap
e with
1823 Ast0.MetaInit
(name
,pure
) ->
1824 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1825 (match lookup name bindings mv_bindings
with
1826 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1827 | Common.Left
(_
) -> failwith
"not possible 1"
1828 | Common.Right
(new_mv
) ->
1830 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1835 match Ast0.unwrap
e with
1836 Ast0.MetaDecl
(name
,pure
) ->
1837 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1838 (match lookup name bindings mv_bindings
with
1839 Common.Left
(Ast0.DeclTag
(d
)) -> d
1840 | Common.Left
(_
) -> failwith
"not possible 1"
1841 | Common.Right
(new_mv
) ->
1843 (Ast0.MetaDecl
(Ast0.set_mcode_data new_mv name
, pure
)))
1844 | Ast0.MetaField
(name
,pure
) ->
1845 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1846 (match lookup name bindings mv_bindings
with
1847 Common.Left
(Ast0.DeclTag
(d
)) -> d
1848 | Common.Left
(_
) -> failwith
"not possible 1"
1849 | Common.Right
(new_mv
) ->
1851 (Ast0.MetaField
(Ast0.set_mcode_data new_mv name
, pure
)))
1852 | Ast0.MetaFieldList
(name
,lenname
,pure
) ->
1853 failwith
"metafieldlist not supported"
1854 | Ast0.Ddots
(d
,_
) ->
1856 (match List.assoc
(dot_term d
) bindings
with
1857 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1858 | _
-> failwith
"unexpected binding")
1859 with Not_found
-> e)
1864 match Ast0.unwrap
e with
1865 Ast0.MetaParam
(name
,pure
) ->
1866 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1867 (match lookup name bindings mv_bindings
with
1868 Common.Left
(Ast0.ParamTag
(param)) -> param
1869 | Common.Left
(_
) -> failwith
"not possible 1"
1870 | Common.Right
(new_mv
) ->
1872 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1873 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1874 failwith
"metaparamlist not supported"
1879 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1880 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1881 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1882 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1883 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1884 | _
-> failwith
"unexpected binding" in
1888 match Ast0.unwrap
e with
1889 Ast0.MetaStmt
(name
,pure
) ->
1890 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1891 (match lookup name bindings mv_bindings
with
1892 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1893 | Common.Left
(_
) -> failwith
"not possible 1"
1894 | Common.Right
(new_mv
) ->
1896 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1897 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1903 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1904 | Ast0.Circles
(d
,_
) ->
1909 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1910 | Ast0.Stars
(d
,_
) ->
1915 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1919 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1920 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1921 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1923 (* --------------------------------------------------------------------- *)
1926 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1928 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1930 let disj_fail bindings
e =
1932 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1935 (* isomorphism code is by default CONTEXT *)
1936 let merge_plus model_mcode e_mcode
=
1937 match model_mcode
with
1939 (* add the replacement information at the root *)
1943 (match (!mc
,!emc
) with
1944 ((Ast.NOREPLACEMENT
,_
),(x,t
))
1945 | ((x,_
),(Ast.NOREPLACEMENT
,t
)) -> (x,t
)
1946 | _
-> failwith
"how can we combine minuses?")
1947 | _
-> failwith
"not possible 6")
1948 | Ast0.CONTEXT
(mc
) ->
1950 Ast0.CONTEXT
(emc
) ->
1951 (* keep the logical line info as in the model *)
1952 let (mba
,tb
,ta
) = !mc
in
1953 let (eba
,_
,_
) = !emc
in
1954 (* merging may be required when a term is replaced by a subterm *)
1956 match (mba
,eba
) with
1957 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1958 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1959 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1960 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1961 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1962 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1963 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1964 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1965 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1966 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1967 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1968 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1969 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1970 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1971 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1972 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1973 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1974 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1975 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1976 emc
:= (merged,tb
,ta
)
1977 | Ast0.MINUS
(emc
) ->
1978 let (anything_bef_aft
,_
,_
) = !mc
in
1979 let (anythings
,t
) = !emc
in
1980 (match (anything_bef_aft
,anythings
) with
1981 (Ast.BEFORE
(b1
,it1
),Ast.NOREPLACEMENT
) ->
1982 emc
:= (Ast.REPLACEMENT
(b1
,it1
),t
)
1983 | (Ast.AFTER
(a1
,it1
),Ast.NOREPLACEMENT
) ->
1984 emc
:= (Ast.REPLACEMENT
(a1
,it1
),t
)
1985 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.NOREPLACEMENT
) ->
1986 emc
:= (Ast.REPLACEMENT
(b1
@a1
,it1
),t
)
1987 | (Ast.NOTHING
,Ast.NOREPLACEMENT
) ->
1988 emc
:= (Ast.NOREPLACEMENT
,t
)
1989 | (Ast.BEFORE
(b1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
1990 emc
:= (Ast.REPLACEMENT
(b1
@a2
,Ast.lub_count it1 it2
),t
)
1991 | (Ast.AFTER
(a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
1992 emc
:= (Ast.REPLACEMENT
(a2
@a1
,Ast.lub_count it1 it2
),t
)
1993 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
1994 emc
:= (Ast.REPLACEMENT
(b1
@a2
@a1
,Ast.lub_count it1 it2
),t
)
1995 | (Ast.NOTHING
,Ast.REPLACEMENT
(a2
,it2
)) -> ()) (* no change *)
1996 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1997 | _
-> failwith
"not possible 7")
1998 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1999 | Ast0.PLUS _
-> failwith
"not possible 9"
2001 let copy_plus printer minusify model
e =
2002 if !Flag.sgrep_mode2
2003 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
2007 match Ast0.get_mcodekind model
with
2008 Ast0.MINUS
(mc
) -> minusify
e
2009 | Ast0.CONTEXT
(mc
) -> e
2010 | _
-> failwith
"not possible: copy_plus\n" in
2011 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
2015 let copy_minus printer minusify model
e =
2016 match Ast0.get_mcodekind model
with
2017 Ast0.MINUS
(mc
) -> minusify
e
2018 | Ast0.CONTEXT
(mc
) -> e
2020 if !Flag.sgrep_mode2
2022 else failwith
"not possible 8"
2023 | Ast0.PLUS _
-> failwith
"not possible 9"
2025 let whencode_allowed prev_ecount prev_icount prev_dcount
2026 ecount icount dcount rest
=
2027 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
2029 let other_ecount = (* number of edots *)
2030 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
2032 let other_icount = (* number of dots *)
2033 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
2035 let other_dcount = (* number of dots *)
2036 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
2038 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
2039 dcount
= 0 or other_dcount = 0)
2041 (* copy the befores and afters to the instantiated code *)
2042 let extra_copy_stmt_plus model
e =
2043 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
2045 (match Ast0.unwrap model
with
2046 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
2047 | Ast0.Decl
((info,bef
),_
) ->
2048 (match Ast0.unwrap
e with
2049 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
2050 | Ast0.Decl
((info,bef1
),_
) ->
2052 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
2053 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
2054 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2055 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
2056 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2057 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
2058 (match Ast0.unwrap
e with
2059 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
2060 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2061 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
2062 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2063 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
2065 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
2069 let extra_copy_other_plus model
e = e
2071 (* --------------------------------------------------------------------- *)
2073 let mv_count = ref 0
2075 let ct = !mv_count in
2076 mv_count := !mv_count + 1;
2077 "_"^
s^
"_"^
(string_of_int
ct)
2079 let get_name = function
2080 Ast.MetaMetaDecl
(ar
,nm) ->
2081 (nm,function nm -> Ast.MetaMetaDecl
(ar
,nm))
2082 | Ast.MetaIdDecl
(ar
,nm) ->
2083 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2084 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2085 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2086 | Ast.MetaTypeDecl
(ar
,nm) ->
2087 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2088 | Ast.MetaInitDecl
(ar
,nm) ->
2089 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2090 | Ast.MetaInitListDecl
(ar
,nm,nm1
) ->
2091 (nm,function nm -> Ast.MetaInitListDecl
(ar
,nm,nm1
))
2092 | Ast.MetaListlenDecl
(nm) ->
2093 failwith
"should not be rebuilt"
2094 | Ast.MetaParamDecl
(ar
,nm) ->
2095 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2096 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2097 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2098 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2099 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2100 | Ast.MetaErrDecl
(ar
,nm) ->
2101 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2102 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2103 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2104 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2105 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2106 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2107 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2108 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2109 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2110 | Ast.MetaDeclDecl
(ar
,nm) ->
2111 (nm,function nm -> Ast.MetaDeclDecl
(ar
,nm))
2112 | Ast.MetaFieldListDecl
(ar
,nm,nm1
) ->
2113 (nm,function nm -> Ast.MetaFieldListDecl
(ar
,nm,nm1
))
2114 | Ast.MetaFieldDecl
(ar
,nm) ->
2115 (nm,function nm -> Ast.MetaFieldDecl
(ar
,nm))
2116 | Ast.MetaStmDecl
(ar
,nm) ->
2117 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2118 | Ast.MetaStmListDecl
(ar
,nm) ->
2119 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2120 | Ast.MetaFuncDecl
(ar
,nm) ->
2121 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2122 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2123 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2124 | Ast.MetaPosDecl
(ar
,nm) ->
2125 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2126 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2127 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2128 | Ast.MetaIteratorDecl
(ar
,nm) ->
2129 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2131 let make_new_metavars metavars bindings
=
2135 let (s,_
) = get_name mv
in
2136 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2141 let (s,rebuild
) = get_name mv
in
2142 let new_s = (!current_rule,new_mv s) in
2143 (rebuild
new_s, (s,new_s)))
2146 (* --------------------------------------------------------------------- *)
2148 let do_nothing x = x
2150 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2151 rebuild_mcodes name printer extra_plus update_others has_context
=
2152 let call_instantiate bindings mv_bindings alts pattern has_context
=
2155 (function (a
,_,_,_) ->
2157 (* no need to create duplicates when the bindings have no effect *)
2159 (function bindings
->
2161 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2163 if has_context
(* ie if pat is not just a metavara *)
2165 copy_plus printer minusify
e (extra_plus
e instantiated)
2166 else instantiated in
2169 else (* iso tracking *)
2170 Ast0.set_iso
plus_added
2171 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2174 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2175 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2176 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2178 whencode_allowed prev_ecount prev_icount prev_dcount
2179 ecount dcount icount rest
in
2180 (match matcher
true (context_required e) wc pattern
e init_env with
2182 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2185 (match matcher
false false wc pattern
e init_env with
2187 interpret_reason name
(Ast0.get_line
e) reason
2188 (function () -> printer
e)
2190 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2191 (prev_dcount
+ dcount
) rest
2192 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2194 (* apply update_others to all patterns other than the matched
2195 one. This is used to desigate the others as test
2196 expressions in the TestExpression case *)
2198 (function (x,e,i
,d
) as all
->
2201 else (update_others
x,e,i
,d
))
2202 (List.hd
all_alts)) ::
2204 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2205 (List.tl
all_alts)) in
2206 (match List.concat
all_alts with
2207 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2209 let (new_metavars,mv_bindings
) =
2210 make_new_metavars metavars
(nub(List.concat bindings
)) in
2213 call_instantiate bindings mv_bindings
all_alts pattern
2214 (has_context pattern
)))) in
2215 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2216 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2217 | (alts
::rest
) as all_alts ->
2218 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2219 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2220 outer_loop prev_ecount prev_icount prev_dcount rest
2221 | Common.Right
(new_metavars,res) ->
2223 copy_minus printer minusify
e (disj_maker
res)) in
2224 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2225 (count
, metavars
, e)
2227 (* no one should ever look at the information stored in these mcodes *)
2228 let disj_starter lst
=
2229 let old_info = Ast0.get_info
(List.hd lst
) in
2231 { old_info.Ast0.pos_info
with
2232 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2233 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2235 { Ast0.pos_info
= new_pos_info;
2236 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2237 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2238 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2239 Ast0.make_mcode_info
"(" info
2241 let disj_ender lst
=
2242 let old_info = Ast0.get_info
(List.hd lst
) in
2244 { old_info.Ast0.pos_info
with
2245 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2246 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2248 { Ast0.pos_info
= new_pos_info;
2249 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2250 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2251 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2252 Ast0.make_mcode_info
")" info
2254 let disj_mid _ = Ast0.make_mcode
"|"
2256 let make_disj_type tl
=
2259 [] -> failwith
"bad disjunction"
2260 | x::xs
-> List.map
disj_mid xs
in
2261 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2262 let make_disj_stmt_list tl
=
2265 [] -> failwith
"bad disjunction"
2266 | x::xs
-> List.map
disj_mid xs
in
2267 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2268 let make_disj_expr model el
=
2271 [] -> failwith
"bad disjunction"
2272 | x::xs
-> List.map
disj_mid xs
in
2274 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2276 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2277 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2278 let el = List.map
update_arg (List.map
update_test el) in
2279 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2280 let make_disj_decl dl
=
2283 [] -> failwith
"bad disjunction"
2284 | x::xs
-> List.map
disj_mid xs
in
2285 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2286 let make_disj_stmt sl
=
2287 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2290 [] -> failwith
"bad disjunction"
2291 | x::xs
-> List.map
disj_mid xs
in
2293 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2295 let transform_type (metavars
,alts
,name
) e =
2297 (Ast0.TypeCTag
(_)::_)::_ ->
2298 (* start line is given to any leaves in the iso code *)
2300 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2306 (p
,count_edots.VT0.combiner_rec_typeC p
,
2307 count_idots.VT0.combiner_rec_typeC p
,
2308 count_dots.VT0.combiner_rec_typeC p
)
2309 | _ -> failwith
"invalid alt"))
2311 mkdisj match_typeC metavars
alts e
2312 (function b
-> function mv_b
->
2313 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2314 (function t
-> Ast0.TypeCTag t
)
2315 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2316 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2317 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2319 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2323 let transform_expr (metavars
,alts,name
) e =
2324 let process update_others
=
2325 (* start line is given to any leaves in the iso code *)
2327 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2332 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2333 (p
,count_edots.VT0.combiner_rec_expression p
,
2334 count_idots.VT0.combiner_rec_expression p
,
2335 count_dots.VT0.combiner_rec_expression p
)
2336 | _ -> failwith
"invalid alt"))
2338 mkdisj match_expr metavars
alts e
2339 (function b
-> function mv_b
->
2340 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2341 (function e -> Ast0.ExprTag
e)
2343 make_minus.VT0.rebuilder_rec_expression
2344 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2345 name
Unparse_ast0.expression extra_copy_other_plus update_others
2347 match Ast0.unwrap
x with
2348 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2352 (Ast0.ExprTag
(_)::r
)::rs
->
2353 (* hack to accomodate ToTestExpression case, where the first pattern is
2354 a normal expression, but the others are test expressions *)
2355 let others = r
@ (List.concat rs
) in
2356 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2357 if List.for_all
is_test others then process Ast0.set_test_exp
2358 else if List.exists
is_test others then failwith
"inconsistent iso"
2359 else process do_nothing
2360 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2361 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2362 process Ast0.set_test_exp
2365 let transform_decl (metavars
,alts,name
) e =
2367 (Ast0.DeclTag
(_)::_)::_ ->
2368 (* start line is given to any leaves in the iso code *)
2370 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2376 (p
,count_edots.VT0.combiner_rec_declaration p
,
2377 count_idots.VT0.combiner_rec_declaration p
,
2378 count_dots.VT0.combiner_rec_declaration p
)
2379 | _ -> failwith
"invalid alt"))
2381 mkdisj match_decl metavars
alts e
2382 (function b
-> function mv_b
->
2383 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2384 (function d
-> Ast0.DeclTag d
)
2386 make_minus.VT0.rebuilder_rec_declaration
2387 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2388 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2389 (function _ -> true (* no metavars *))
2392 let transform_stmt (metavars
,alts,name
) e =
2394 (Ast0.StmtTag
(_)::_)::_ ->
2395 (* start line is given to any leaves in the iso code *)
2397 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2403 (p
,count_edots.VT0.combiner_rec_statement p
,
2404 count_idots.VT0.combiner_rec_statement p
,
2405 count_dots.VT0.combiner_rec_statement p
)
2406 | _ -> failwith
"invalid alt"))
2408 mkdisj match_statement metavars
alts e
2409 (function b
-> function mv_b
->
2410 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2411 (function s -> Ast0.StmtTag
s)
2412 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2413 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2414 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2416 match Ast0.unwrap
x with
2417 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2421 (* sort of a hack, because there is no disj at top level *)
2422 let transform_top (metavars
,alts,name
) e =
2423 match Ast0.unwrap
e with
2424 Ast0.DECL
(declstm
) ->
2430 Ast0.DotsStmtTag
(d
) ->
2431 (match Ast0.unwrap d
with
2432 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2433 | _ -> raise
(Failure
""))
2434 | _ -> raise
(Failure
"")))
2436 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2437 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2438 with Failure
_ -> (0,[],e))
2439 | Ast0.CODE
(stmts
) ->
2440 let (count
,mv
,res) =
2442 (Ast0.DotsStmtTag
(_)::_)::_ ->
2443 (* start line is given to any leaves in the iso code *)
2445 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2450 Ast0.DotsStmtTag
(p
) ->
2451 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2452 count_idots.VT0.combiner_rec_statement_dots p
,
2453 count_dots.VT0.combiner_rec_statement_dots p
)
2454 | _ -> failwith
"invalid alt"))
2456 mkdisj match_statement_dots metavars
alts stmts
2457 (function b
-> function mv_b
->
2458 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2459 (function s -> Ast0.DotsStmtTag
s)
2461 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2463 make_minus.VT0.rebuilder_rec_statement_dots
x)
2464 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2465 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2466 (function _ -> true)
2467 | _ -> (0,[],stmts
) in
2468 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2471 (* --------------------------------------------------------------------- *)
2473 let transform (alts : isomorphism
) t
=
2474 (* the following ugliness is because rebuilder only returns a new term *)
2475 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2476 let in_limit n
= function
2480 ((if !Flag_parsing_cocci.show_iso_failures
2481 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2483 let bind x y
= x + y
in
2484 let option_default = 0 in
2486 let (e_count
,e) = k
e in
2487 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2489 let (count
,extra_meta
,exp
) = transform_expr alts e in
2490 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2491 (bind count e_count
,exp
)
2495 let (e_count
,e) = k
e in
2496 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2498 let (count
,extra_meta
,dec
) = transform_decl alts e in
2499 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2500 (bind count e_count
,dec
)
2504 let (e_count
,e) = k
e in
2505 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2507 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2508 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2509 (bind count e_count
,stm
)
2513 let (continue
,e_count
,e) =
2514 match Ast0.unwrap
e with
2515 Ast0.Signed
(signb
,tyb
) ->
2516 (* Hack! How else to prevent iso from applying under an
2520 let (e_count
,e) = k
e in
2521 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2522 then (true,e_count
,e)
2523 else (false,e_count
,e) in
2526 let (count
,extra_meta
,ty
) = transform_type alts e in
2527 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2528 (bind count e_count
,ty
)
2532 let (e_count
,e) = k
e in
2533 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2535 let (count
,extra_meta
,ty
) = transform_top alts e in
2536 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2537 (bind count e_count
,ty
)
2541 V0.combiner_rebuilder
bind option_default
2542 {V0.combiner_rebuilder_functions
with
2543 VT0.combiner_rebuilder_exprfn
= exprfn;
2544 VT0.combiner_rebuilder_tyfn
= typefn;
2545 VT0.combiner_rebuilder_declfn
= declfn;
2546 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2547 VT0.combiner_rebuilder_topfn
= topfn} in
2548 let (_,res) = res.VT0.top_level t
in
2549 (!extra_meta_decls,res)
2551 (* --------------------------------------------------------------------- *)
2553 (* should be done by functorizing the parser to use wrap or context_wrap *)
2555 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2556 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2558 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2559 donothing donothing donothing donothing donothing donothing
2560 donothing donothing donothing donothing donothing donothing donothing
2563 let rewrap_anything = function
2564 Ast0.DotsExprTag
(d
) ->
2565 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2566 | Ast0.DotsInitTag
(d
) ->
2567 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2568 | Ast0.DotsParamTag
(d
) ->
2569 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2570 | Ast0.DotsStmtTag
(d
) ->
2571 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2572 | Ast0.DotsDeclTag
(d
) ->
2573 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2574 | Ast0.DotsCaseTag
(d
) ->
2575 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2576 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2577 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2578 | Ast0.ArgExprTag
(d
) ->
2579 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2580 | Ast0.TestExprTag
(d
) ->
2581 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2582 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2583 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2584 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2585 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2586 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2587 | Ast0.CaseLineTag
(d
) ->
2588 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2589 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2590 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2591 failwith
"only for isos within iso phase"
2592 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2594 (* --------------------------------------------------------------------- *)
2596 let apply_isos isos rule rule_name
=
2601 current_rule := rule_name
;
2604 (function (metavars
,iso
,name
) ->
2605 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2607 let (extra_meta
,rule
) =
2612 (function (extra_meta
,t
) -> function iso
->
2613 let (new_extra_meta
,t
) = transform iso t
in
2614 (new_extra_meta
@extra_meta
,t
))
2617 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)