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 #
0 "./iso_pattern.ml"
28 (* Potential problem: offset of mcode is not updated when an iso is
29 instantiated, implying that a term may end up with many mcodes with the
30 same offset. On the other hand, at the moment offset only seems to be used
31 before this phase. Furthermore add_dot_binding relies on the offset to
32 remain the same between matching an iso and instantiating it with bindings. *)
34 (* Consider whether ... in iso should match <... ...> in smpl? *)
36 (* --------------------------------------------------------------------- *)
37 (* match a SmPL expression against a SmPL abstract syntax tree,
40 module Ast
= Ast_cocci
41 module Ast0
= Ast0_cocci
42 module V0
= Visitor_ast0
43 module VT0
= Visitor_ast0_types
45 let current_rule = ref ""
47 (* --------------------------------------------------------------------- *)
50 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
53 let mcode (term
,_
,_
,_
,_
,_
) =
54 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
58 {(Ast0.wrap
(Ast0.unwrap
x)) with
59 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
60 Ast0.true_if_test
= x.Ast0.true_if_test
} in
62 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
63 donothing donothing donothing donothing donothing donothing
64 donothing donothing donothing donothing donothing donothing donothing
67 let anything_equal = function
68 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
69 failwith
"not a possible variable binding" (*not sure why these are pbs*)
70 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
71 failwith
"not a possible variable binding"
72 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
73 failwith
"not a possible variable binding"
74 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
75 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
76 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
77 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
78 failwith
"not a possible variable binding"
79 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
80 failwith
"not a possible variable binding"
81 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
82 (strip_info.VT0.rebuilder_rec_ident d1
) =
83 (strip_info.VT0.rebuilder_rec_ident d2
)
84 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
85 (strip_info.VT0.rebuilder_rec_expression d1
) =
86 (strip_info.VT0.rebuilder_rec_expression d2
)
87 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
88 failwith
"not possible - only in isos1"
89 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
90 failwith
"not possible - only in isos1"
91 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
92 (strip_info.VT0.rebuilder_rec_typeC d1
) =
93 (strip_info.VT0.rebuilder_rec_typeC d2
)
94 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
95 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
96 (strip_info.VT0.rebuilder_rec_initialiser d2
)
97 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
98 (strip_info.VT0.rebuilder_rec_parameter d1
) =
99 (strip_info.VT0.rebuilder_rec_parameter d2
)
100 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
101 (strip_info.VT0.rebuilder_rec_declaration d1
) =
102 (strip_info.VT0.rebuilder_rec_declaration d2
)
103 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
104 (strip_info.VT0.rebuilder_rec_statement d1
) =
105 (strip_info.VT0.rebuilder_rec_statement d2
)
106 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
107 (strip_info.VT0.rebuilder_rec_case_line d1
) =
108 (strip_info.VT0.rebuilder_rec_case_line d2
)
109 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
110 (strip_info.VT0.rebuilder_rec_top_level d1
) =
111 (strip_info.VT0.rebuilder_rec_top_level d2
)
112 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
113 failwith
"only for isos within iso phase"
114 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
115 failwith
"only for isos within iso phase"
116 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
117 failwith
"only for isos within iso phase"
120 let term (var1
,_
,_
,_
,_
,_
) = var1
121 let dot_term (var1
,_
,info
,_
,_
,_
) =
122 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
126 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
127 | NotPureLength
of Ast.meta_name
128 | ContextRequired
of Ast0.anything
130 | Braces
of Ast0.statement
131 | Nest
of Ast0.statement
132 | Position
of Ast.meta_name
133 | TypeMatch
of reason list
135 let rec interpret_reason name line reason printer
=
137 "warning: iso %s does not match the code below on line %d\n" name line
;
138 printer
(); Format.print_newline
();
140 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
142 "pure metavariable %s is matched against the following nonpure code:\n"
144 Unparse_ast0.unparse_anything nonpure
145 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
147 "context metavariable %s is matched against the following\nnoncontext code:\n"
149 Unparse_ast0.unparse_anything nonpure
150 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
152 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
154 Unparse_ast0.unparse_anything nonpure
155 | NotPureLength
((_
,var
)) ->
157 "pure metavariable %s is matched against too much or too little code\n"
159 | ContextRequired
(term) ->
161 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
162 Unparse_ast0.unparse_anything
term
164 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
165 Unparse_ast0.statement
"" s
;
166 Format.print_newline
()
168 Printf.printf
"iso with nest doesn't match whencode (TODO):\n";
169 Unparse_ast0.statement
"" s
;
170 Format.print_newline
()
171 | Position
(rule
,name
) ->
172 Printf.printf
"position variable %s.%s conflicts 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 [] -> OK binding
(* no hidden vars in smpl code, so nothing to do *)
329 | ((a
::_
) as hidden_code
) ->
331 List.filter
(function Ast0.HiddenVarTag _
-> true | _
-> false)
332 (Ast0.get_pos pmc
) in
333 (match hidden_pattern with
334 [Ast0.HiddenVarTag
([Ast0.MetaPosTag
(Ast0.MetaPos
(name1
,_
,_
))])] ->
335 add_binding name1
(Ast0.HiddenVarTag
(hidden_code
)) binding
336 | [] -> Fail
(Position
(Ast0.unwrap_mcode
(Ast0.meta_pos_name a
)))
337 | _
-> failwith
"badly compiled iso - multiple hidden variable")
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.Sequence
(lefta
,opa
,righta
),
663 Ast0.Sequence
(leftb
,opb
,rightb
)) ->
664 if mcode_equal opa opb
666 conjunct_many_bindings
667 [check_mcode opa opb
; match_expr lefta leftb
;
668 match_expr righta rightb
]
670 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
671 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
672 conjunct_many_bindings
673 [check_mcode lp1 lp
; check_mcode rp1 rp
;
674 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
675 match_expr exp3a exp3b
]
676 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
677 if mcode_equal opa opb
679 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
681 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
682 if mcode_equal opa opb
684 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
686 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
687 if mcode_equal opa opb
689 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
691 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
692 if mcode_equal opa opb
694 conjunct_many_bindings
695 [check_mcode opa opb
; match_expr lefta leftb
;
696 match_expr righta rightb
]
698 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
699 conjunct_many_bindings
700 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
701 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
702 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
703 conjunct_many_bindings
704 [check_mcode lb1 lb
; check_mcode rb1 rb
;
705 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
706 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
707 Ast0.RecordAccess
(expb
,op
,fieldb
))
708 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
709 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
710 conjunct_many_bindings
711 [check_mcode opa op
; match_expr expa expb
;
712 match_ident fielda fieldb
]
713 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
714 conjunct_many_bindings
715 [check_mcode lp1 lp
; check_mcode rp1 rp
;
716 match_typeC tya tyb
; match_expr expa expb
]
717 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
718 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
719 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
720 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
721 conjunct_many_bindings
722 [check_mcode lp1 lp
; check_mcode rp1 rp
;
723 check_mcode szf1 szf
; match_typeC tya tyb
]
724 | (Ast0.Constructor
(lp1
,tya
,rp1
,inita
),
725 Ast0.Constructor
(lp
,tyb
,rp
,initb
)) ->
726 conjunct_many_bindings
727 [check_mcode lp1 lp
; check_mcode rp1 rp
;
728 match_typeC tya tyb
; match_init inita initb
]
729 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
731 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
732 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
733 failwith
"not allowed in the pattern of an isomorphism"
734 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
735 failwith
"not allowed in the pattern of an isomorphism"
736 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
737 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
738 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
739 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
740 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
741 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
742 (* hope that mcode of edots is unique somehow *)
743 conjunct_bindings (check_mcode ed ed1
)
744 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
745 if edots_whencode_allowed
746 then add_dot_binding ed
(Ast0.ExprTag wc
)
749 "warning: not applying iso because of whencode";
751 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
752 | (Ast0.Estars
(_
,Some _
),_
) ->
753 failwith
"whencode not allowed in a pattern1"
754 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
755 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) ->
757 | (_
,Ast0.OptExp
(expb
))
758 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
760 else return_false (ContextRequired
(Ast0.ExprTag expr
))
762 (* the special case for function types prevents the eg T X; -> T X = E; iso
763 from applying, which doesn't seem very relevant, but it also avoids a
764 mysterious bug that is obtained with eg int attach(...); *)
765 and match_typeC pattern t
=
766 match Ast0.unwrap pattern
with
767 Ast0.MetaType
(name
,pure
) ->
768 (match Ast0.unwrap t
with
769 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
771 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
772 (function ty
-> Ast0.TypeCTag ty
)
775 if not
(checks_needed
) or not
(context_required
) or is_context t
777 match (up
,Ast0.unwrap t
) with
778 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
779 if mcode_equal cva cvb
781 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
783 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
786 match_list check_mcode
787 (function _
-> false) (function _
-> failwith
"")
790 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
791 if mcode_equal signa signb
793 conjunct_bindings (check_mcode signa signb
)
794 (match_option match_typeC tya tyb
)
796 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
797 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
798 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
799 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
800 conjunct_many_bindings
801 [check_mcode stara starb
; check_mcode lp1a lp1b
;
802 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
803 check_mcode rp2a rp2b
; match_typeC tya tyb
;
804 match_dots match_param
is_plist_matcher
805 do_plist_match paramsa paramsb
]
806 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
807 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
808 conjunct_many_bindings
809 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
810 match_option match_typeC tya tyb
;
811 match_dots match_param
is_plist_matcher do_plist_match
813 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
814 conjunct_many_bindings
815 [check_mcode lb1 lb
; check_mcode rb1 rb
;
816 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
817 | (Ast0.EnumName
(kinda
,Some namea
),
818 Ast0.EnumName
(kindb
,Some nameb
)) ->
819 conjunct_bindings (check_mcode kinda kindb
)
820 (match_ident namea nameb
)
821 | (Ast0.EnumDef
(tya
,lb1
,idsa
,rb1
),
822 Ast0.EnumDef
(tyb
,lb
,idsb
,rb
)) ->
823 conjunct_many_bindings
824 [check_mcode lb1 lb
; check_mcode rb1 rb
;
826 match_dots match_expr no_list do_nolist_match idsa idsb
]
827 | (Ast0.StructUnionName
(kinda
,Some namea
),
828 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
829 if mcode_equal kinda kindb
831 conjunct_bindings (check_mcode kinda kindb
)
832 (match_ident namea nameb
)
834 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
835 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
836 conjunct_many_bindings
837 [check_mcode lb1 lb
; check_mcode rb1 rb
;
839 match_dots match_decl
no_list do_nolist_match declsa declsb
]
840 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
841 if mcode_equal namea nameb
842 then check_mcode namea nameb
844 | (Ast0.DisjType
(_
,typesa
,_
,_
),_
) ->
845 failwith
"not allowed in the pattern of an isomorphism"
846 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
847 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
848 | (_
,Ast0.OptType
(tyb
))
849 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
851 else return_false (ContextRequired
(Ast0.TypeCTag t
))
853 and match_decl pattern d
=
854 match Ast0.unwrap pattern
with
855 Ast0.MetaDecl
(name
,pure
) ->
856 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
857 (function d
-> Ast0.DeclTag d
)
859 | Ast0.MetaField
(name
,pure
) ->
860 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
861 (function d
-> Ast0.DeclTag d
)
863 | Ast0.MetaFieldList
(name
,_
,pure
) -> failwith
"metafieldlist not supporte"
865 if not
(checks_needed
) or not
(context_required
) or is_context d
867 match (up
,Ast0.unwrap d
) with
868 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
869 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
870 if bool_match_option mcode_equal stga stgb
872 conjunct_many_bindings
873 [check_mcode eq1 eq
; check_mcode sc1 sc
;
874 match_option check_mcode stga stgb
;
875 match_typeC tya tyb
; match_ident ida idb
;
876 match_init inia inib
]
878 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
879 if bool_match_option mcode_equal stga stgb
881 conjunct_many_bindings
882 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
883 match_typeC tya tyb
; match_ident ida idb
]
885 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
886 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
887 conjunct_many_bindings
888 [match_ident namea nameb
;
889 check_mcode lp1 lp
; check_mcode rp1 rp
;
891 match_dots match_expr is_elist_matcher do_elist_match
893 | (Ast0.MacroDeclInit
(namea
,lp1
,argsa
,rp1
,eq1
,ini1
,sc1
),
894 Ast0.MacroDeclInit
(nameb
,lp
,argsb
,rp
,eq
,ini
,sc
)) ->
895 conjunct_many_bindings
896 [match_ident namea nameb
;
897 check_mcode lp1 lp
; check_mcode rp1 rp
;
900 match_dots match_expr is_elist_matcher do_elist_match
903 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
904 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
905 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
906 conjunct_bindings (check_mcode sc1 sc
)
907 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
908 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),_
) ->
909 failwith
"not allowed in the pattern of an isomorphism"
910 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
911 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
912 conjunct_bindings (check_mcode dd d
)
913 (* hope that mcode of ddots is unique somehow *)
914 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
915 if ddots_whencode_allowed
916 then add_dot_binding dd
(Ast0.DeclTag wc
)
918 (Printf.printf
"warning: not applying iso because of whencode";
920 | (Ast0.Ddots
(_
,Some _
),_
) ->
921 failwith
"whencode not allowed in a pattern1"
923 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
924 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
925 match_decl decla declb
926 | (_
,Ast0.OptDecl
(declb
))
927 | (_
,Ast0.UniqueDecl
(declb
)) ->
928 match_decl pattern declb
930 else return_false (ContextRequired
(Ast0.DeclTag d
))
932 and match_init pattern i
=
933 match Ast0.unwrap pattern
with
934 Ast0.MetaInit
(name
,pure
) ->
935 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
936 (function ini
-> Ast0.InitTag ini
)
939 if not
(checks_needed
) or not
(context_required
) or is_context i
941 match (up
,Ast0.unwrap i
) with
942 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
944 | (Ast0.InitList
(lb1
,initlista
,rb1
,oa
),
945 Ast0.InitList
(lb
,initlistb
,rb
,ob
))
947 conjunct_many_bindings
948 [check_mcode lb1 lb
; check_mcode rb1 rb
;
949 match_dots match_init
no_list do_nolist_match
951 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
952 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
953 conjunct_many_bindings
954 [match_list match_designator
955 (function _
-> false) (function _
-> failwith
"")
956 designators1 designators2
;
958 match_init inia inib
]
959 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
960 conjunct_many_bindings
961 [check_mcode c1 c
; match_ident namea nameb
;
962 match_init inia inib
]
963 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
964 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
965 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
966 conjunct_bindings (check_mcode id d
)
967 (* hope that mcode of edots is unique somehow *)
968 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
969 if idots_whencode_allowed
970 then add_dot_binding id
(Ast0.InitTag wc
)
973 "warning: not applying iso because of whencode";
975 | (Ast0.Idots
(_
,Some _
),_
) ->
976 failwith
"whencode not allowed in a pattern2"
977 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
978 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
979 | (_
,Ast0.OptIni
(ib
))
980 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
982 else return_false (ContextRequired
(Ast0.InitTag i
))
984 and match_designator pattern d
=
985 match (pattern
,d
) with
986 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
987 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
988 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
989 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
990 conjunct_many_bindings
991 [check_mcode lba lbb
; match_expr expa expb
;
993 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
994 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
995 conjunct_many_bindings
996 [check_mcode lba lbb
; match_expr mina minb
;
997 check_mcode dotsa dotsb
; match_expr maxa maxb
;
1001 and match_param pattern p
=
1002 match Ast0.unwrap pattern
with
1003 Ast0.MetaParam
(name
,pure
) ->
1004 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
1005 (function p
-> Ast0.ParamTag p
)
1007 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
1009 if not
(checks_needed
) or not
(context_required
) or is_context p
1011 match (up
,Ast0.unwrap p
) with
1012 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
1013 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
1014 conjunct_bindings (match_typeC tya tyb
)
1015 (match_option match_ident ida idb
)
1016 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
1017 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
1018 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
1019 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
1020 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
1021 match_param parama paramb
1022 | (_
,Ast0.OptParam
(paramb
))
1023 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
1025 else return_false (ContextRequired
(Ast0.ParamTag p
))
1027 and match_statement pattern s
=
1028 match Ast0.unwrap pattern
with
1029 Ast0.MetaStmt
(name
,pure
) ->
1030 (match Ast0.unwrap s
with
1031 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
1032 return false (* ... is not a single statement *)
1034 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
1035 (function ty
-> Ast0.StmtTag ty
)
1037 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1039 if not
(checks_needed
) or not
(context_required
) or is_context s
1041 match (up
,Ast0.unwrap s
) with
1042 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
1043 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
1044 conjunct_many_bindings
1045 [check_mcode lp1 lp
; check_mcode rp1 rp
;
1046 check_mcode lb1 lb
; check_mcode rb1 rb
;
1047 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
1048 match_dots match_param
is_plist_matcher do_plist_match
1050 match_dots match_statement
is_slist_matcher do_slist_match
1052 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
1053 match_decl decla declb
1054 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
1055 (* seqs can only match if they are all minus (plus code
1056 allowed) or all context (plus code not allowed in the body).
1057 we could be more permissive if the expansions of the isos are
1058 also all seqs, but this would be hard to check except at top
1059 level, and perhaps not worth checking even in that case.
1060 Overall, the issue is that braces are used where single
1061 statements are required, and something not satisfying these
1062 conditions can cause a single statement to become a
1063 non-single statement after the transformation.
1065 example: if { ... -foo(); ... }
1066 if we let the sequence convert to just -foo();
1067 then we produce invalid code. For some reason,
1068 single_statement can't deal with this case, perhaps because
1069 it starts introducing too many braces? don't remember the
1072 conjunct_bindings (check_mcode lb1 lb
)
1073 (conjunct_bindings (check_mcode rb1 rb
)
1074 (if not
(checks_needed
) or is_minus s
or
1076 List.for_all
is_pure_context (Ast0.undots bodyb
))
1078 match_dots match_statement
is_slist_matcher do_slist_match
1080 else return_false (Braces
(s
))))
1081 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1082 conjunct_bindings (check_mcode sc1 sc
)
1083 (match_option match_expr expa expb
)
1084 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1085 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1086 conjunct_many_bindings
1087 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1088 check_mcode rp1 rp2
;
1089 match_expr expa expb
;
1090 match_statement branch1a branch1b
]
1091 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1092 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1093 conjunct_many_bindings
1094 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1095 check_mcode rp1 rp2
; check_mcode e1 e2
;
1096 match_expr expa expb
;
1097 match_statement branch1a branch1b
;
1098 match_statement branch2a branch2b
]
1099 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1100 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1101 conjunct_many_bindings
1102 [check_mcode w1 w
; check_mcode lp1 lp
;
1103 check_mcode rp1 rp
; match_expr expa expb
;
1104 match_statement bodya bodyb
]
1105 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1106 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1107 conjunct_many_bindings
1108 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1109 check_mcode rp1 rp
; match_statement bodya bodyb
;
1110 match_expr expa expb
]
1111 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1112 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1113 conjunct_many_bindings
1114 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1115 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1116 match_option match_expr e1a e1b
;
1117 match_option match_expr e2a e2b
;
1118 match_option match_expr e3a e3b
;
1119 match_statement bodya bodyb
]
1120 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1121 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1122 conjunct_many_bindings
1123 [match_ident nma nmb
;
1124 check_mcode lp1 lp
; check_mcode rp1 rp
;
1125 match_dots match_expr is_elist_matcher do_elist_match
1127 match_statement bodya bodyb
]
1128 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1129 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1130 conjunct_many_bindings
1131 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1132 check_mcode lb1 lb
; check_mcode rb1 rb
;
1133 match_expr expa expb
;
1134 match_dots match_statement
is_slist_matcher do_slist_match
1136 match_dots match_case_line
no_list do_nolist_match
1138 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1139 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1140 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1141 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1142 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1143 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1144 conjunct_many_bindings
1145 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1146 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1147 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1148 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1149 conjunct_many_bindings
1150 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1151 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1152 failwith
"disj not supported in patterns"
1153 | (Ast0.Nest
(_
,stmt_dotsa
,_
,[],multia
),
1154 Ast0.Nest
(_
,stmt_dotsb
,_
,wc
,multib
)) ->
1159 (* not sure this is correct, perhaps too restrictive *)
1160 if not
(checks_needed
) or is_minus s
or
1162 List.for_all
is_pure_context (Ast0.undots stmt_dotsb
))
1164 match_dots match_statement
1165 is_slist_matcher do_slist_match
1166 stmt_dotsa stmt_dotsb
1167 else return_false (Braces
(s
))
1168 | _
-> return_false (Nest
(s
)))
1169 else return false (* diff kind of nest *)
1170 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1171 failwith
"nest with whencode not supported in patterns"
1172 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1173 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1174 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1175 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1176 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1177 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1178 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1179 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1181 [] -> check_mcode d d1
1183 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1184 if dots_whencode_allowed
1186 conjunct_bindings (check_mcode d d1
)
1190 | Ast0.WhenNot wc
->
1191 conjunct_bindings prev
1192 (add_multi_dot_binding d
1193 (Ast0.DotsStmtTag wc
))
1194 | Ast0.WhenAlways wc
->
1195 conjunct_bindings prev
1196 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1197 | Ast0.WhenNotTrue wc
->
1198 conjunct_bindings prev
1199 (add_multi_dot_binding d
1200 (Ast0.IsoWhenTTag wc
))
1201 | Ast0.WhenNotFalse wc
->
1202 conjunct_bindings prev
1203 (add_multi_dot_binding d
1204 (Ast0.IsoWhenFTag wc
))
1205 | Ast0.WhenModifier
(x) ->
1206 conjunct_bindings prev
1207 (add_multi_dot_binding d
1208 (Ast0.IsoWhenTag
x)))
1212 "warning: not applying iso because of whencode";
1214 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1215 | (Ast0.Stars
(_
,_
::_
),_
) ->
1216 failwith
"whencode not allowed in a pattern3"
1217 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1218 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1219 match_statement rea reb
1220 | (_
,Ast0.OptStm
(reb
))
1221 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1223 else return_false (ContextRequired
(Ast0.StmtTag s
))
1225 (* first should provide a subset of the information in the second *)
1226 and match_fninfo patterninfo cinfo
=
1227 let patterninfo = List.sort compare
patterninfo in
1228 let cinfo = List.sort compare
cinfo in
1229 let rec loop = function
1230 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1231 if mcode_equal sta stb
1232 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1234 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1235 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1236 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1237 if mcode_equal ia ib
1238 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1240 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1241 if mcode_equal ia ib
1242 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1244 | (x::resta
,((y
::_
) as restb
)) ->
1245 (match compare
x y
with
1247 | 1 -> loop (resta
,restb
)
1248 | _
-> failwith
"not possible")
1249 | _
-> return false in
1250 loop (patterninfo,cinfo)
1252 and match_case_line pattern c
=
1253 if not
(checks_needed
) or not
(context_required
) or is_context c
1255 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1256 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1257 conjunct_many_bindings
1258 [check_mcode d1 d
; check_mcode c1 c
;
1259 match_dots match_statement
is_slist_matcher do_slist_match
1261 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1262 conjunct_many_bindings
1263 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1264 match_dots match_statement
is_slist_matcher do_slist_match
1266 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1267 failwith
"not allowed in the pattern of an isomorphism"
1268 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1269 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1271 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1273 let match_statement_dots x y
=
1274 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1276 (match_expr, match_decl
, match_statement
, match_typeC
,
1277 match_statement_dots)
1279 let match_expr dochecks context_required whencode_allowed
=
1280 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1283 let match_decl dochecks context_required whencode_allowed
=
1284 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1287 let match_statement dochecks context_required whencode_allowed
=
1288 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1291 let match_typeC dochecks context_required whencode_allowed
=
1292 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1295 let match_statement_dots dochecks context_required whencode_allowed
=
1296 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1299 (* --------------------------------------------------------------------- *)
1300 (* make an entire tree MINUS *)
1303 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1305 match mcodekind
with
1308 (Ast.NOTHING
,_
,_
) ->
1309 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1310 | _
-> failwith
"make_minus: unexpected befaft")
1311 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1312 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1313 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1315 let update_mc mcodekind e
=
1316 match !mcodekind
with
1319 (Ast.NOTHING
,_
,_
) ->
1321 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1322 | _
-> failwith
"make_minus: unexpected befaft")
1323 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1324 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1325 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1327 let donothing r k e
=
1328 let mcodekind = Ast0.get_mcodekind_ref e
in
1329 let e = k
e in update_mc mcodekind e; e in
1331 (* special case for whencode, because it isn't processed by contextneg,
1332 since it doesn't appear in the + code *)
1333 (* cases for dots and nests *)
1334 let expression r k
e =
1335 let mcodekind = Ast0.get_mcodekind_ref
e in
1336 match Ast0.unwrap
e with
1337 Ast0.Edots
(d
,whencode
) ->
1338 (*don't recurse because whencode hasn't been processed by context_neg*)
1339 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1340 | Ast0.Ecircles
(d
,whencode
) ->
1341 (*don't recurse because whencode hasn't been processed by context_neg*)
1342 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1343 | Ast0.Estars
(d
,whencode
) ->
1344 (*don't recurse because whencode hasn't been processed by context_neg*)
1345 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1346 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1347 update_mc mcodekind e;
1349 (Ast0.NestExpr
(mcode starter
,
1350 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1351 mcode ender
,whencode
,multi
))
1352 | _
-> donothing r k
e in
1354 let declaration r k
e =
1355 let mcodekind = Ast0.get_mcodekind_ref
e in
1356 match Ast0.unwrap
e with
1357 Ast0.Ddots
(d
,whencode
) ->
1358 (*don't recurse because whencode hasn't been processed by context_neg*)
1359 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1360 | _
-> donothing r k
e in
1362 let statement r k
e =
1363 let mcodekind = Ast0.get_mcodekind_ref
e in
1364 match Ast0.unwrap
e with
1365 Ast0.Dots
(d
,whencode
) ->
1366 (*don't recurse because whencode hasn't been processed by context_neg*)
1367 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1368 | Ast0.Circles
(d
,whencode
) ->
1369 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1370 | Ast0.Stars
(d
,whencode
) ->
1371 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1372 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1373 update_mc mcodekind e;
1376 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1377 mcode ender
,whencode
,multi
))
1378 | _
-> donothing r k
e in
1380 let initialiser r k
e =
1381 let mcodekind = Ast0.get_mcodekind_ref
e in
1382 match Ast0.unwrap
e with
1383 Ast0.Idots
(d
,whencode
) ->
1384 (*don't recurse because whencode hasn't been processed by context_neg*)
1385 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1386 | _
-> donothing r k
e in
1389 let info = Ast0.get_info
e in
1390 let mcodekind = Ast0.get_mcodekind_ref
e in
1391 match Ast0.unwrap
e with
1393 (* if context is - this should be - as well. There are no tokens
1394 here though, so the bottom-up minusifier in context_neg leaves it
1395 as mixed (or context for sgrep2). It would be better to fix
1396 context_neg, but that would
1397 require a special case for each term with a dots subterm. *)
1398 (match !mcodekind with
1399 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1401 (Ast.NOTHING
,_
,_
) ->
1403 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
));
1405 | _
-> failwith
"make_minus: unexpected befaft")
1406 (* code already processed by an enclosing iso *)
1407 | Ast0.MINUS
(mc
) -> e
1411 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1412 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1413 | _
-> donothing r k
e in
1416 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1417 dots dots dots dots dots dots
1418 donothing expression donothing initialiser donothing declaration
1419 statement donothing donothing
1421 (* --------------------------------------------------------------------- *)
1422 (* rebuild mcode cells in an instantiated alt *)
1424 (* mcodes will be side effected later with plus code, so we have to copy
1425 them on instantiating an isomorphism. One could wonder whether it would
1426 be better not to use side-effects, but they are convenient for insert_plus
1427 where is it useful to manipulate a list of the mcodes but side-effect a
1429 (* hmm... Insert_plus is called before Iso_pattern... *)
1430 let rebuild_mcode start_line
=
1431 let copy_mcodekind = function
1432 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1433 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1434 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1435 | Ast0.PLUS count
->
1436 (* this function is used elsewhere where we need to rebuild the
1437 indices, and so we allow PLUS code as well *)
1440 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1442 match start_line
with
1445 {info.Ast0.pos_info
with
1446 Ast0.line_start
= x;
1447 Ast0.line_end
= x; } in
1448 {info with Ast0.pos_info
= new_pos_info}
1450 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1453 let old_info = Ast0.get_info
x in
1455 match start_line
with
1458 {old_info.Ast0.pos_info
with
1459 Ast0.line_start
= x;
1460 Ast0.line_end
= x; } in
1461 {old_info with Ast0.pos_info
= new_pos_info}
1462 | None
-> old_info in
1463 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1464 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1466 let donothing r k
e = copy_one (k
e) in
1468 (* case for control operators (if, etc) *)
1469 let statement r k
e =
1474 (match Ast0.unwrap
s with
1475 Ast0.Decl
((info,mc
),decl) ->
1476 Ast0.Decl
((info,copy_mcodekind mc
),decl)
1477 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1478 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1479 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1480 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1481 (info,copy_mcodekind mc
))
1482 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1483 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1484 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1485 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1486 (info,copy_mcodekind mc
))
1487 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1488 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1490 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1492 ((info,copy_mcodekind mc
),
1493 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1495 Ast0.set_dots_bef_aft
res
1496 (match Ast0.get_dots_bef_aft
res with
1497 Ast0.NoDots
-> Ast0.NoDots
1498 | Ast0.AddingBetweenDots
s ->
1499 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1500 | Ast0.DroppingBetweenDots
s ->
1501 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1504 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1505 donothing donothing donothing donothing donothing donothing
1506 donothing donothing donothing donothing donothing
1507 donothing statement donothing donothing
1509 (* --------------------------------------------------------------------- *)
1510 (* The problem of whencode. If an isomorphism contains dots in multiple
1511 rules, then the code that is matched cannot contain whencode, because we
1512 won't know which dots it goes with. Should worry about nests, but they
1513 aren't allowed in isomorphisms for the moment. *)
1516 let option_default = 0 in
1517 let bind x y
= x + y
in
1519 match Ast0.unwrap
e with
1520 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1523 V0.combiner
bind option_default
1524 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1527 let option_default = 0 in
1528 let bind x y
= x + y
in
1530 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1532 V0.combiner
bind option_default
1533 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1536 let option_default = 0 in
1537 let bind x y
= x + y
in
1539 match Ast0.unwrap
e with
1540 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1543 V0.combiner
bind option_default
1544 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1546 (* --------------------------------------------------------------------- *)
1548 let lookup name bindings mv_bindings
=
1549 try Common.Left
(List.assoc
(term name
) bindings
)
1552 (* failure is not possible anymore *)
1553 Common.Right
(List.assoc
(term name
) mv_bindings
)
1555 (* mv_bindings is for the fresh metavariables that are introduced by the
1557 let instantiate bindings mv_bindings
=
1559 let (hidden
,others
) =
1561 (function Ast0.HiddenVarTag _
-> true | _
-> false)
1565 [Ast0.HiddenVarTag
([Ast0.MetaPosTag
(Ast0.MetaPos
(name
,_
,_
))])] ->
1567 (* not at all sure that this is good enough *)
1568 match lookup name bindings mv_bindings
with
1569 Common.Left
(Ast0.HiddenVarTag
(ids
)) -> ids
1570 | _
-> failwith
"not possible"
1572 (*can't fail because checks_needed could be false?*)
1574 | [] -> [] (* no hidden metavars allowed *)
1575 | _
-> failwith
"badly compiled mcode" in
1576 Ast0.set_pos
(new_names@others
) x in
1577 let donothing r k
e = k
e in
1579 (* cases where metavariables can occur *)
1582 match Ast0.unwrap
e with
1583 Ast0.MetaId
(name
,constraints
,seed
,pure
) ->
1584 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1585 (match lookup name bindings mv_bindings
with
1586 Common.Left
(Ast0.IdentTag
(id
)) -> id
1587 | Common.Left
(_
) -> failwith
"not possible 1"
1588 | Common.Right
(new_mv
) ->
1591 (Ast0.set_mcode_data new_mv name
,constraints
,seed
,pure
)))
1592 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1593 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1596 (* case for list metavariables *)
1597 let rec elist r same_dots
= function
1600 (match Ast0.unwrap
x with
1601 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1602 failwith
"meta_expr_list in iso not supported"
1603 (*match lookup name bindings mv_bindings with
1604 Common.Left(Ast0.DotsExprTag(exp)) ->
1605 (match same_dots exp with
1607 | None -> failwith "dots put in incompatible context")
1608 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1609 | Common.Left(_) -> failwith "not possible 1"
1610 | Common.Right(new_mv) ->
1611 failwith "MetaExprList in SP not supported"*)
1612 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1613 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1615 let rec plist r same_dots
= function
1618 (match Ast0.unwrap
x with
1619 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1620 failwith
"meta_param_list in iso not supported"
1621 (*match lookup name bindings mv_bindings with
1622 Common.Left(Ast0.DotsParamTag(param)) ->
1623 (match same_dots param with
1625 | None -> failwith "dots put in incompatible context")
1626 | Common.Left(Ast0.ParamTag(param)) -> [param]
1627 | Common.Left(_) -> failwith "not possible 1"
1628 | Common.Right(new_mv) ->
1629 failwith "MetaExprList in SP not supported"*)
1630 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1631 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1633 let rec slist r same_dots
= function
1636 (match Ast0.unwrap
x with
1637 Ast0.MetaStmtList
(name
,pure
) ->
1638 (match lookup name bindings mv_bindings
with
1639 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1640 (match same_dots stm
with
1642 | None
-> failwith
"dots put in incompatible context")
1643 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1644 | Common.Left
(_
) -> failwith
"not possible 1"
1645 | Common.Right
(new_mv
) ->
1646 failwith
"MetaExprList in SP not supported")
1647 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1648 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1651 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1652 let same_circles d
=
1653 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1655 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1657 let dots list_fn r k d
=
1659 (match Ast0.unwrap d
with
1660 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1661 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1662 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1664 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1667 match Ast0.unwrap
e with
1668 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1669 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1670 (match lookup name bindings mv_bindings
with
1671 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1672 | Common.Left
(_
) -> failwith
"not possible 1"
1673 | Common.Right
(new_mv
) ->
1678 let rec renamer = function
1679 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1681 lookup (name
,(),(),(),None
,-1)
1682 bindings mv_bindings
1684 Common.Left
(Ast0.TypeCTag
(t
)) ->
1685 Ast0.ast0_type_to_type t
1687 failwith
"iso pattern: unexpected type"
1688 | Common.Right
(new_mv
) ->
1689 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1690 | Type_cocci.ConstVol
(cv
,ty
) ->
1691 Type_cocci.ConstVol
(cv
,renamer ty
)
1692 | Type_cocci.Pointer
(ty
) ->
1693 Type_cocci.Pointer
(renamer ty
)
1694 | Type_cocci.FunctionPointer
(ty
) ->
1695 Type_cocci.FunctionPointer
(renamer ty
)
1696 | Type_cocci.Array
(ty
) ->
1697 Type_cocci.Array
(renamer ty
)
1699 Some
(List.map
renamer types
) in
1702 (Ast0.set_mcode_data new_mv name
,constraints
,
1703 new_types,form
,pure
)))
1704 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1705 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1706 failwith
"metaexprlist not supported"
1707 | Ast0.Unary
(exp
,unop
) ->
1708 (match Ast0.unwrap_mcode unop
with
1709 (* propagate negation only when the propagated and the encountered
1710 negation have the same transformation, when there is nothing
1711 added to the original one, and when there is nothing added to
1712 the expression into which we are doing the propagation. This
1713 may be too conservative. *)
1716 (* k e doesn't change the outer structure of the term,
1717 only the metavars *)
1718 match Ast0.unwrap old_e
with
1719 Ast0.Unary
(exp
,_
) ->
1720 (match Ast0.unwrap exp
with
1721 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1723 | _
-> failwith
"not possible" in
1724 let nomodif = function
1727 (Ast.NOREPLACEMENT
,_
) -> true
1729 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1731 (Ast.NOTHING
,_
,_
) -> true
1733 | _
-> failwith
"plus not possible" in
1734 let same_modif newop oldop
=
1735 (* only propagate ! is they have the same modification
1736 and no + code on the old one (the new one from the iso
1737 surely has no + code) *)
1738 match (newop
,oldop
) with
1739 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1740 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1741 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1746 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1747 (* k accumulates parens, to keep negation outside if no
1748 propagation is possible *)
1749 if nomodif (Ast0.get_mcodekind
e)
1751 match Ast0.unwrap
res with
1752 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1754 (Ast0.get_mcode_mcodekind unop
)
1755 (Ast0.get_mcode_mcodekind op
) ->
1757 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1758 | Ast0.Paren
(lp
,e1,rp
) ->
1761 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1762 | Ast0.Binary
(e1,op
,e2
) when
1764 (Ast0.get_mcode_mcodekind unop
)
1765 (Ast0.get_mcode_mcodekind op
) ->
1767 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1768 let k1 x = k
(Ast0.rewrap
e x) in
1769 (match Ast0.unwrap_mcode op
with
1770 Ast.Logical
(Ast.Inf
) ->
1771 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1772 | Ast.Logical
(Ast.Sup
) ->
1773 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1774 | Ast.Logical
(Ast.InfEq
) ->
1775 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1776 | Ast.Logical
(Ast.SupEq
) ->
1777 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1778 | Ast.Logical
(Ast.Eq
) ->
1779 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1780 | Ast.Logical
(Ast.NotEq
) ->
1781 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1782 | Ast.Logical
(Ast.AndLog
) ->
1783 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1785 negate_reb
e e2
idcont))
1786 | Ast.Logical
(Ast.OrLog
) ->
1787 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1789 negate_reb
e e2
idcont))
1793 Ast0.rewrap_mcode op
Ast.Not
)))
1794 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1795 (* use res because it is the transformed argument *)
1797 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1798 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1800 (*use e, because this might be the toplevel expression*)
1802 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1805 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1806 and negate_reb
e e1 k
=
1807 (* used when ! is propagated to multiple places, to avoid
1808 duplicating mcode cells *)
1810 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1811 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1816 | Ast0.Edots
(d
,_
) ->
1818 (match List.assoc
(dot_term d
) bindings
with
1819 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1820 | _
-> failwith
"unexpected binding")
1821 with Not_found
-> e)
1822 | Ast0.Ecircles
(d
,_
) ->
1824 (match List.assoc
(dot_term d
) bindings
with
1825 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1826 | _
-> failwith
"unexpected binding")
1827 with Not_found
-> e)
1828 | Ast0.Estars
(d
,_
) ->
1830 (match List.assoc
(dot_term d
) bindings
with
1831 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1832 | _
-> failwith
"unexpected binding")
1833 with Not_found
-> e)
1835 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1839 match Ast0.unwrap
e with
1840 Ast0.MetaType
(name
,pure
) ->
1841 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1842 (match lookup name bindings mv_bindings
with
1843 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1844 | Common.Left
(_
) -> failwith
"not possible 1"
1845 | Common.Right
(new_mv
) ->
1847 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1852 match Ast0.unwrap
e with
1853 Ast0.MetaInit
(name
,pure
) ->
1854 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1855 (match lookup name bindings mv_bindings
with
1856 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1857 | Common.Left
(_
) -> failwith
"not possible 1"
1858 | Common.Right
(new_mv
) ->
1860 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1865 match Ast0.unwrap
e with
1866 Ast0.MetaDecl
(name
,pure
) ->
1867 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1868 (match lookup name bindings mv_bindings
with
1869 Common.Left
(Ast0.DeclTag
(d
)) -> d
1870 | Common.Left
(_
) -> failwith
"not possible 1"
1871 | Common.Right
(new_mv
) ->
1873 (Ast0.MetaDecl
(Ast0.set_mcode_data new_mv name
, pure
)))
1874 | Ast0.MetaField
(name
,pure
) ->
1875 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1876 (match lookup name bindings mv_bindings
with
1877 Common.Left
(Ast0.DeclTag
(d
)) -> d
1878 | Common.Left
(_
) -> failwith
"not possible 1"
1879 | Common.Right
(new_mv
) ->
1881 (Ast0.MetaField
(Ast0.set_mcode_data new_mv name
, pure
)))
1882 | Ast0.MetaFieldList
(name
,lenname
,pure
) ->
1883 failwith
"metafieldlist not supported"
1884 | Ast0.Ddots
(d
,_
) ->
1886 (match List.assoc
(dot_term d
) bindings
with
1887 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1888 | _
-> failwith
"unexpected binding")
1889 with Not_found
-> e)
1894 match Ast0.unwrap
e with
1895 Ast0.MetaParam
(name
,pure
) ->
1896 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1897 (match lookup name bindings mv_bindings
with
1898 Common.Left
(Ast0.ParamTag
(param)) -> param
1899 | Common.Left
(_
) -> failwith
"not possible 1"
1900 | Common.Right
(new_mv
) ->
1902 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1903 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1904 failwith
"metaparamlist not supported"
1909 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1910 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1911 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1912 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1913 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1914 | _
-> failwith
"unexpected binding" in
1918 match Ast0.unwrap
e with
1919 Ast0.MetaStmt
(name
,pure
) ->
1920 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1921 (match lookup name bindings mv_bindings
with
1922 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1923 | Common.Left
(_
) -> failwith
"not possible 1"
1924 | Common.Right
(new_mv
) ->
1926 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1927 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1933 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1934 | Ast0.Circles
(d
,_
) ->
1939 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1940 | Ast0.Stars
(d
,_
) ->
1945 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1949 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1950 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1951 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1953 (* --------------------------------------------------------------------- *)
1956 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1958 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1960 let disj_fail bindings
e =
1962 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1965 (* isomorphism code is by default CONTEXT *)
1966 let merge_plus model_mcode e_mcode
=
1967 match model_mcode
with
1969 (* add the replacement information at the root *)
1973 (match (!mc
,!emc
) with
1974 ((Ast.NOREPLACEMENT
,_
),(x,t
))
1975 | ((x,_
),(Ast.NOREPLACEMENT
,t
)) -> (x,t
)
1976 | _
-> failwith
"how can we combine minuses?")
1977 | _
-> failwith
"not possible 6")
1978 | Ast0.CONTEXT
(mc
) ->
1980 Ast0.CONTEXT
(emc
) ->
1981 (* keep the logical line info as in the model *)
1982 let (mba
,tb
,ta
) = !mc
in
1983 let (eba
,_
,_
) = !emc
in
1984 (* merging may be required when a term is replaced by a subterm *)
1986 match (mba
,eba
) with
1987 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1988 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1989 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1990 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1991 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1992 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1993 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1994 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1995 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1996 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1997 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1998 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1999 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
2000 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
2001 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
2002 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
2003 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
2004 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
2005 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
2006 emc
:= (merged,tb
,ta
)
2007 | Ast0.MINUS
(emc
) ->
2008 let (anything_bef_aft
,_
,_
) = !mc
in
2009 let (anythings
,t
) = !emc
in
2010 (match (anything_bef_aft
,anythings
) with
2011 (Ast.BEFORE
(b1
,it1
),Ast.NOREPLACEMENT
) ->
2012 emc
:= (Ast.REPLACEMENT
(b1
,it1
),t
)
2013 | (Ast.AFTER
(a1
,it1
),Ast.NOREPLACEMENT
) ->
2014 emc
:= (Ast.REPLACEMENT
(a1
,it1
),t
)
2015 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.NOREPLACEMENT
) ->
2016 emc
:= (Ast.REPLACEMENT
(b1
@a1
,it1
),t
)
2017 | (Ast.NOTHING
,Ast.NOREPLACEMENT
) ->
2018 emc
:= (Ast.NOREPLACEMENT
,t
)
2019 | (Ast.BEFORE
(b1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2020 emc
:= (Ast.REPLACEMENT
(b1
@a2
,Ast.lub_count it1 it2
),t
)
2021 | (Ast.AFTER
(a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2022 emc
:= (Ast.REPLACEMENT
(a2
@a1
,Ast.lub_count it1 it2
),t
)
2023 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2024 emc
:= (Ast.REPLACEMENT
(b1
@a2
@a1
,Ast.lub_count it1 it2
),t
)
2025 | (Ast.NOTHING
,Ast.REPLACEMENT
(a2
,it2
)) -> ()) (* no change *)
2026 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
2027 | _
-> failwith
"not possible 7")
2028 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
2029 | Ast0.PLUS _
-> failwith
"not possible 9"
2031 let copy_plus printer minusify model
e =
2032 if !Flag.sgrep_mode2
2033 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
2037 match Ast0.get_mcodekind model
with
2038 Ast0.MINUS
(mc
) -> minusify
e
2039 | Ast0.CONTEXT
(mc
) -> e
2040 | _
-> failwith
"not possible: copy_plus\n" in
2041 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
2045 let copy_minus printer minusify model
e =
2046 match Ast0.get_mcodekind model
with
2047 Ast0.MINUS
(mc
) -> minusify
e
2048 | Ast0.CONTEXT
(mc
) -> e
2050 if !Flag.sgrep_mode2
2052 else failwith
"not possible 8"
2053 | Ast0.PLUS _
-> failwith
"not possible 9"
2055 let whencode_allowed prev_ecount prev_icount prev_dcount
2056 ecount icount dcount rest
=
2057 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
2059 let other_ecount = (* number of edots *)
2060 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
2062 let other_icount = (* number of dots *)
2063 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
2065 let other_dcount = (* number of dots *)
2066 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
2068 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
2069 dcount
= 0 or other_dcount = 0)
2071 (* copy the befores and afters to the instantiated code *)
2072 let extra_copy_stmt_plus model
e =
2073 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
2075 (match Ast0.unwrap model
with
2076 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
2077 | Ast0.Decl
((info,bef
),_
) ->
2078 (match Ast0.unwrap
e with
2079 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
2080 | Ast0.Decl
((info,bef1
),_
) ->
2082 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
2083 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
2084 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2085 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
2086 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2087 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
2088 (match Ast0.unwrap
e with
2089 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
2090 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2091 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
2092 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2093 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
2095 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
2099 let extra_copy_other_plus model
e = e
2101 (* --------------------------------------------------------------------- *)
2103 let mv_count = ref 0
2105 let ct = !mv_count in
2106 mv_count := !mv_count + 1;
2107 "_"^
s^
"_"^
(string_of_int
ct)
2109 let get_name = function
2110 Ast.MetaMetaDecl
(ar
,nm) ->
2111 (nm,function nm -> Ast.MetaMetaDecl
(ar
,nm))
2112 | Ast.MetaIdDecl
(ar
,nm) ->
2113 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2114 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2115 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2116 | Ast.MetaTypeDecl
(ar
,nm) ->
2117 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2118 | Ast.MetaInitDecl
(ar
,nm) ->
2119 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2120 | Ast.MetaInitListDecl
(ar
,nm,nm1
) ->
2121 (nm,function nm -> Ast.MetaInitListDecl
(ar
,nm,nm1
))
2122 | Ast.MetaListlenDecl
(nm) ->
2123 failwith
"should not be rebuilt"
2124 | Ast.MetaParamDecl
(ar
,nm) ->
2125 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2126 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2127 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2128 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2129 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2130 | Ast.MetaErrDecl
(ar
,nm) ->
2131 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2132 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2133 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2134 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2135 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2136 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2137 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2138 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2139 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2140 | Ast.MetaDeclDecl
(ar
,nm) ->
2141 (nm,function nm -> Ast.MetaDeclDecl
(ar
,nm))
2142 | Ast.MetaFieldListDecl
(ar
,nm,nm1
) ->
2143 (nm,function nm -> Ast.MetaFieldListDecl
(ar
,nm,nm1
))
2144 | Ast.MetaFieldDecl
(ar
,nm) ->
2145 (nm,function nm -> Ast.MetaFieldDecl
(ar
,nm))
2146 | Ast.MetaStmDecl
(ar
,nm) ->
2147 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2148 | Ast.MetaStmListDecl
(ar
,nm) ->
2149 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2150 | Ast.MetaFuncDecl
(ar
,nm) ->
2151 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2152 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2153 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2154 | Ast.MetaPosDecl
(ar
,nm) ->
2155 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2156 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2157 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2158 | Ast.MetaIteratorDecl
(ar
,nm) ->
2159 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2161 let make_new_metavars metavars bindings
=
2165 let (s,_
) = get_name mv
in
2166 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2171 let (s,rebuild
) = get_name mv
in
2172 let new_s = (!current_rule,new_mv s) in
2173 (rebuild
new_s, (s,new_s)))
2176 (* --------------------------------------------------------------------- *)
2178 let do_nothing x = x
2180 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2181 rebuild_mcodes name printer extra_plus update_others has_context
=
2182 let call_instantiate bindings mv_bindings alts pattern has_context
=
2185 (function (a
,_,_,_) ->
2187 (* no need to create duplicates when the bindings have no effect *)
2189 (function bindings
->
2191 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2193 if has_context
(* ie if pat is not just a metavara *)
2195 copy_plus printer minusify
e (extra_plus
e instantiated)
2196 else instantiated in
2199 else (* iso tracking *)
2200 Ast0.set_iso
plus_added
2201 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2204 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2205 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2206 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2208 whencode_allowed prev_ecount prev_icount prev_dcount
2209 ecount dcount icount rest
in
2210 (match matcher
true (context_required e) wc pattern
e init_env with
2212 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2215 (match matcher
false false wc pattern
e init_env with
2217 interpret_reason name
(Ast0.get_line
e) reason
2218 (function () -> printer
e)
2220 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2221 (prev_dcount
+ dcount
) rest
2222 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2224 (* apply update_others to all patterns other than the matched
2225 one. This is used to desigate the others as test
2226 expressions in the TestExpression case *)
2228 (function (x,e,i
,d
) as all
->
2231 else (update_others
x,e,i
,d
))
2232 (List.hd
all_alts)) ::
2234 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2235 (List.tl
all_alts)) in
2236 (match List.concat
all_alts with
2237 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2239 let (new_metavars,mv_bindings
) =
2240 make_new_metavars metavars
(nub(List.concat bindings
)) in
2243 call_instantiate bindings mv_bindings
all_alts pattern
2244 (has_context pattern
)))) in
2245 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2246 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2247 | (alts
::rest
) as all_alts ->
2248 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2249 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2250 outer_loop prev_ecount prev_icount prev_dcount rest
2251 | Common.Right
(new_metavars,res) ->
2253 copy_minus printer minusify
e (disj_maker
res)) in
2254 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2255 (count
, metavars
, e)
2257 (* no one should ever look at the information stored in these mcodes *)
2258 let disj_starter lst
=
2259 let old_info = Ast0.get_info
(List.hd lst
) in
2261 { old_info.Ast0.pos_info
with
2262 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2263 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2265 { Ast0.pos_info
= new_pos_info;
2266 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2267 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2268 Ast0.strings_before
= []; Ast0.strings_after
= [];
2269 Ast0.isSymbolIdent
= false; } in
2270 Ast0.make_mcode_info
"(" info
2272 let disj_ender lst
=
2273 let old_info = Ast0.get_info
(List.hd lst
) in
2275 { old_info.Ast0.pos_info
with
2276 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2277 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2279 { Ast0.pos_info
= new_pos_info;
2280 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2281 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2282 Ast0.strings_before
= []; Ast0.strings_after
= [];
2283 Ast0.isSymbolIdent
= false; } in
2284 Ast0.make_mcode_info
")" info
2286 let disj_mid _ = Ast0.make_mcode
"|"
2288 let make_disj_type tl
=
2291 [] -> failwith
"bad disjunction"
2292 | x::xs
-> List.map
disj_mid xs
in
2293 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2294 let make_disj_stmt_list tl
=
2297 [] -> failwith
"bad disjunction"
2298 | x::xs
-> List.map
disj_mid xs
in
2299 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2300 let make_disj_expr model el
=
2303 [] -> failwith
"bad disjunction"
2304 | x::xs
-> List.map
disj_mid xs
in
2306 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2308 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2309 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2310 let el = List.map
update_arg (List.map
update_test el) in
2311 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2312 let make_disj_decl dl
=
2315 [] -> failwith
"bad disjunction"
2316 | x::xs
-> List.map
disj_mid xs
in
2317 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2318 let make_disj_stmt sl
=
2319 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2322 [] -> failwith
"bad disjunction"
2323 | x::xs
-> List.map
disj_mid xs
in
2325 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2327 let transform_type (metavars
,alts
,name
) e =
2329 (Ast0.TypeCTag
(_)::_)::_ ->
2330 (* start line is given to any leaves in the iso code *)
2332 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2338 (p
,count_edots.VT0.combiner_rec_typeC p
,
2339 count_idots.VT0.combiner_rec_typeC p
,
2340 count_dots.VT0.combiner_rec_typeC p
)
2341 | _ -> failwith
"invalid alt"))
2343 mkdisj match_typeC metavars
alts e
2344 (function b
-> function mv_b
->
2345 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2346 (function t
-> Ast0.TypeCTag t
)
2347 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2348 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2349 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2351 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2355 let transform_expr (metavars
,alts,name
) e =
2356 let process update_others
=
2357 (* start line is given to any leaves in the iso code *)
2359 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2364 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2365 (p
,count_edots.VT0.combiner_rec_expression p
,
2366 count_idots.VT0.combiner_rec_expression p
,
2367 count_dots.VT0.combiner_rec_expression p
)
2368 | _ -> failwith
"invalid alt"))
2370 mkdisj match_expr metavars
alts e
2371 (function b
-> function mv_b
->
2372 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2373 (function e -> Ast0.ExprTag
e)
2375 make_minus.VT0.rebuilder_rec_expression
2376 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2377 name
Unparse_ast0.expression extra_copy_other_plus update_others
2379 match Ast0.unwrap
x with
2380 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2384 (Ast0.ExprTag
(_)::r
)::rs
->
2385 (* hack to accomodate ToTestExpression case, where the first pattern is
2386 a normal expression, but the others are test expressions *)
2387 let others = r
@ (List.concat rs
) in
2388 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2389 if List.for_all
is_test others then process Ast0.set_test_exp
2390 else if List.exists
is_test others then failwith
"inconsistent iso"
2391 else process do_nothing
2392 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2393 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2394 process Ast0.set_test_exp
2397 let transform_decl (metavars
,alts,name
) e =
2399 (Ast0.DeclTag
(_)::_)::_ ->
2400 (* start line is given to any leaves in the iso code *)
2402 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2408 (p
,count_edots.VT0.combiner_rec_declaration p
,
2409 count_idots.VT0.combiner_rec_declaration p
,
2410 count_dots.VT0.combiner_rec_declaration p
)
2411 | _ -> failwith
"invalid alt"))
2413 mkdisj match_decl metavars
alts e
2414 (function b
-> function mv_b
->
2415 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2416 (function d
-> Ast0.DeclTag d
)
2418 make_minus.VT0.rebuilder_rec_declaration
2419 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2420 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2421 (function _ -> true (* no metavars *))
2424 let transform_stmt (metavars
,alts,name
) e =
2426 (Ast0.StmtTag
(_)::_)::_ ->
2427 (* start line is given to any leaves in the iso code *)
2429 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2435 (p
,count_edots.VT0.combiner_rec_statement p
,
2436 count_idots.VT0.combiner_rec_statement p
,
2437 count_dots.VT0.combiner_rec_statement p
)
2438 | _ -> failwith
"invalid alt"))
2440 mkdisj match_statement metavars
alts e
2441 (function b
-> function mv_b
->
2442 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2443 (function s -> Ast0.StmtTag
s)
2444 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2445 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2446 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2448 match Ast0.unwrap
x with
2449 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2453 (* sort of a hack, because there is no disj at top level *)
2454 let transform_top (metavars
,alts,name
) e =
2455 match Ast0.unwrap
e with
2456 Ast0.NONDECL
(declstm
) ->
2462 Ast0.DotsStmtTag
(d
) ->
2463 (match Ast0.unwrap d
with
2464 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2465 | _ -> raise
(Failure
""))
2466 | _ -> raise
(Failure
"")))
2468 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2469 (count
,mv
,Ast0.rewrap
e (Ast0.NONDECL
(s)))
2470 with Failure
_ -> (0,[],e))
2471 | Ast0.CODE
(stmts
) ->
2472 let (count
,mv
,res) =
2474 (Ast0.DotsStmtTag
(_)::_)::_ ->
2475 (* start line is given to any leaves in the iso code *)
2477 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2482 Ast0.DotsStmtTag
(p
) ->
2483 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2484 count_idots.VT0.combiner_rec_statement_dots p
,
2485 count_dots.VT0.combiner_rec_statement_dots p
)
2486 | _ -> failwith
"invalid alt"))
2488 mkdisj match_statement_dots metavars
alts stmts
2489 (function b
-> function mv_b
->
2490 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2491 (function s -> Ast0.DotsStmtTag
s)
2493 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2495 make_minus.VT0.rebuilder_rec_statement_dots
x)
2496 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2497 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2498 (function _ -> true)
2499 | _ -> (0,[],stmts
) in
2500 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2503 (* --------------------------------------------------------------------- *)
2505 let transform (alts : isomorphism
) t
=
2506 (* the following ugliness is because rebuilder only returns a new term *)
2507 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2508 let in_limit n
= function
2512 ((if !Flag_parsing_cocci.show_iso_failures
2513 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2515 let bind x y
= x + y
in
2516 let option_default = 0 in
2518 let (e_count
,e) = k
e in
2519 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2521 let (count
,extra_meta
,exp
) = transform_expr alts e in
2522 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2523 (bind count e_count
,exp
)
2527 let (e_count
,e) = k
e in
2528 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2530 let (count
,extra_meta
,dec
) = transform_decl alts e in
2531 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2532 (bind count e_count
,dec
)
2536 let (e_count
,e) = k
e in
2537 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2539 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2540 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2541 (bind count e_count
,stm
)
2545 let (continue
,e_count
,e) =
2546 match Ast0.unwrap
e with
2547 Ast0.Signed
(signb
,tyb
) ->
2548 (* Hack! How else to prevent iso from applying under an
2552 let (e_count
,e) = k
e in
2553 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2554 then (true,e_count
,e)
2555 else (false,e_count
,e) in
2558 let (count
,extra_meta
,ty
) = transform_type alts e in
2559 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2560 (bind count e_count
,ty
)
2564 let (e_count
,e) = k
e in
2565 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2567 let (count
,extra_meta
,ty
) = transform_top alts e in
2568 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2569 (bind count e_count
,ty
)
2573 V0.combiner_rebuilder
bind option_default
2574 {V0.combiner_rebuilder_functions
with
2575 VT0.combiner_rebuilder_exprfn
= exprfn;
2576 VT0.combiner_rebuilder_tyfn
= typefn;
2577 VT0.combiner_rebuilder_declfn
= declfn;
2578 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2579 VT0.combiner_rebuilder_topfn
= topfn} in
2580 let (_,res) = res.VT0.top_level t
in
2581 (!extra_meta_decls,res)
2583 (* --------------------------------------------------------------------- *)
2585 (* should be done by functorizing the parser to use wrap or context_wrap *)
2587 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2588 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2590 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2591 donothing donothing donothing donothing donothing donothing
2592 donothing donothing donothing donothing donothing donothing donothing
2595 let rewrap_anything = function
2596 Ast0.DotsExprTag
(d
) ->
2597 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2598 | Ast0.DotsInitTag
(d
) ->
2599 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2600 | Ast0.DotsParamTag
(d
) ->
2601 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2602 | Ast0.DotsStmtTag
(d
) ->
2603 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2604 | Ast0.DotsDeclTag
(d
) ->
2605 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2606 | Ast0.DotsCaseTag
(d
) ->
2607 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2608 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2609 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2610 | Ast0.ArgExprTag
(d
) ->
2611 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2612 | Ast0.TestExprTag
(d
) ->
2613 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2614 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2615 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2616 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2617 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2618 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2619 | Ast0.CaseLineTag
(d
) ->
2620 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2621 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2622 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2623 failwith
"only for isos within iso phase"
2624 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2625 | Ast0.HiddenVarTag
(p
) -> Ast0.HiddenVarTag
(p
) (* not sure it is possible *)
2627 (* --------------------------------------------------------------------- *)
2629 let apply_isos isos rule rule_name
=
2634 current_rule := rule_name
;
2637 (function (metavars
,iso
,name
) ->
2638 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2640 let (extra_meta
,rule
) =
2645 (function (extra_meta
,t
) -> function iso
->
2646 let (new_extra_meta
,t
) = transform iso t
in
2647 (new_extra_meta
@extra_meta
,t
))
2650 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)