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
65 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 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
,firsta
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1112 Ast0.For
(f
,lp
,firstb
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1114 match (Ast0.unwrap firsta
,Ast0.unwrap firstb
) with
1115 (Ast0.ForExp
(e1a
,sc1a
),Ast0.ForExp
(e1b
,sc1b
)) ->
1117 (check_mcode sc2a sc2b
)
1118 (match_option match_expr e1a e1b
)
1119 | (Ast0.ForDecl
(_
,decla
),Ast0.ForDecl
(_
,declb
)) ->
1120 match_decl decla declb
1121 | _
-> return false in
1122 conjunct_many_bindings
1123 [check_mcode f1 f
; check_mcode lp1 lp
; first;
1124 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1125 match_option match_expr e2a e2b
;
1126 match_option match_expr e3a e3b
;
1127 match_statement bodya bodyb
]
1128 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1129 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1130 conjunct_many_bindings
1131 [match_ident nma nmb
;
1132 check_mcode lp1 lp
; check_mcode rp1 rp
;
1133 match_dots match_expr is_elist_matcher do_elist_match
1135 match_statement bodya bodyb
]
1136 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1137 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1138 conjunct_many_bindings
1139 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1140 check_mcode lb1 lb
; check_mcode rb1 rb
;
1141 match_expr expa expb
;
1142 match_dots match_statement
is_slist_matcher do_slist_match
1144 match_dots match_case_line
no_list do_nolist_match
1146 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1147 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1148 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1149 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1150 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1151 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1152 conjunct_many_bindings
1153 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1154 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1155 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1156 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1157 conjunct_many_bindings
1158 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1159 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1160 failwith
"disj not supported in patterns"
1161 | (Ast0.Nest
(_
,stmt_dotsa
,_
,[],multia
),
1162 Ast0.Nest
(_
,stmt_dotsb
,_
,wc
,multib
)) ->
1167 (* not sure this is correct, perhaps too restrictive *)
1168 if not
(checks_needed
) or is_minus s
or
1170 List.for_all
is_pure_context (Ast0.undots stmt_dotsb
))
1172 match_dots match_statement
1173 is_slist_matcher do_slist_match
1174 stmt_dotsa stmt_dotsb
1175 else return_false (Braces
(s
))
1176 | _
-> return_false (Nest
(s
)))
1177 else return false (* diff kind of nest *)
1178 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1179 failwith
"nest with whencode not supported in patterns"
1180 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1181 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1182 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1183 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1184 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1185 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1186 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1187 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1189 [] -> check_mcode d d1
1191 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1192 if dots_whencode_allowed
1194 conjunct_bindings (check_mcode d d1
)
1198 | Ast0.WhenNot wc
->
1199 conjunct_bindings prev
1200 (add_multi_dot_binding d
1201 (Ast0.DotsStmtTag wc
))
1202 | Ast0.WhenAlways wc
->
1203 conjunct_bindings prev
1204 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1205 | Ast0.WhenNotTrue wc
->
1206 conjunct_bindings prev
1207 (add_multi_dot_binding d
1208 (Ast0.IsoWhenTTag wc
))
1209 | Ast0.WhenNotFalse wc
->
1210 conjunct_bindings prev
1211 (add_multi_dot_binding d
1212 (Ast0.IsoWhenFTag wc
))
1213 | Ast0.WhenModifier
(x) ->
1214 conjunct_bindings prev
1215 (add_multi_dot_binding d
1216 (Ast0.IsoWhenTag
x)))
1220 "warning: not applying iso because of whencode";
1222 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1223 | (Ast0.Stars
(_
,_
::_
),_
) ->
1224 failwith
"whencode not allowed in a pattern3"
1225 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1226 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1227 match_statement rea reb
1228 | (_
,Ast0.OptStm
(reb
))
1229 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1231 else return_false (ContextRequired
(Ast0.StmtTag s
))
1233 (* first should provide a subset of the information in the second *)
1234 and match_fninfo patterninfo cinfo
=
1235 let patterninfo = List.sort compare
patterninfo in
1236 let cinfo = List.sort compare
cinfo in
1237 let rec loop = function
1238 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1239 if mcode_equal sta stb
1240 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1242 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1243 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1244 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1245 if mcode_equal ia ib
1246 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1248 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1249 if mcode_equal ia ib
1250 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1252 | (x::resta
,((y
::_
) as restb
)) ->
1253 (match compare
x y
with
1255 | 1 -> loop (resta
,restb
)
1256 | _
-> failwith
"not possible")
1257 | _
-> return false in
1258 loop (patterninfo,cinfo)
1260 and match_case_line pattern c
=
1261 if not
(checks_needed
) or not
(context_required
) or is_context c
1263 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1264 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1265 conjunct_many_bindings
1266 [check_mcode d1 d
; check_mcode c1 c
;
1267 match_dots match_statement
is_slist_matcher do_slist_match
1269 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1270 conjunct_many_bindings
1271 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1272 match_dots match_statement
is_slist_matcher do_slist_match
1274 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1275 failwith
"not allowed in the pattern of an isomorphism"
1276 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1277 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1279 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1281 let match_statement_dots x y
=
1282 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1284 (match_expr, match_decl
, match_statement
, match_typeC
,
1285 match_statement_dots)
1287 let match_expr dochecks context_required whencode_allowed
=
1288 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1291 let match_decl dochecks context_required whencode_allowed
=
1292 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1295 let match_statement dochecks context_required whencode_allowed
=
1296 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1299 let match_typeC dochecks context_required whencode_allowed
=
1300 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1303 let match_statement_dots dochecks context_required whencode_allowed
=
1304 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1307 (* --------------------------------------------------------------------- *)
1308 (* make an entire tree MINUS *)
1311 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1313 match mcodekind
with
1316 (Ast.NOTHING
,_
,_
) ->
1317 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1318 | _
-> failwith
"make_minus: unexpected befaft")
1319 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1320 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1321 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1323 let update_mc mcodekind e
=
1324 match !mcodekind
with
1327 (Ast.NOTHING
,_
,_
) ->
1329 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
))
1330 | _
-> failwith
"make_minus: unexpected befaft")
1331 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1332 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1333 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1335 let donothing r k e
=
1336 let mcodekind = Ast0.get_mcodekind_ref e
in
1337 let e = k
e in update_mc mcodekind e; e in
1339 (* special case for whencode, because it isn't processed by contextneg,
1340 since it doesn't appear in the + code *)
1341 (* cases for dots and nests *)
1342 let expression r k
e =
1343 let mcodekind = Ast0.get_mcodekind_ref
e in
1344 match Ast0.unwrap
e with
1345 Ast0.Edots
(d
,whencode
) ->
1346 (*don't recurse because whencode hasn't been processed by context_neg*)
1347 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1348 | Ast0.Ecircles
(d
,whencode
) ->
1349 (*don't recurse because whencode hasn't been processed by context_neg*)
1350 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1351 | Ast0.Estars
(d
,whencode
) ->
1352 (*don't recurse because whencode hasn't been processed by context_neg*)
1353 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1354 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1355 update_mc mcodekind e;
1357 (Ast0.NestExpr
(mcode starter
,
1358 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1359 mcode ender
,whencode
,multi
))
1360 | _
-> donothing r k
e in
1362 let declaration r k
e =
1363 let mcodekind = Ast0.get_mcodekind_ref
e in
1364 match Ast0.unwrap
e with
1365 Ast0.Ddots
(d
,whencode
) ->
1366 (*don't recurse because whencode hasn't been processed by context_neg*)
1367 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1368 | _
-> donothing r k
e in
1370 let statement r k
e =
1371 let mcodekind = Ast0.get_mcodekind_ref
e in
1372 match Ast0.unwrap
e with
1373 Ast0.Dots
(d
,whencode
) ->
1374 (*don't recurse because whencode hasn't been processed by context_neg*)
1375 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1376 | Ast0.Circles
(d
,whencode
) ->
1377 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1378 | Ast0.Stars
(d
,whencode
) ->
1379 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1380 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1381 update_mc mcodekind e;
1384 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1385 mcode ender
,whencode
,multi
))
1386 | _
-> donothing r k
e in
1388 let initialiser r k
e =
1389 let mcodekind = Ast0.get_mcodekind_ref
e in
1390 match Ast0.unwrap
e with
1391 Ast0.Idots
(d
,whencode
) ->
1392 (*don't recurse because whencode hasn't been processed by context_neg*)
1393 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1394 | _
-> donothing r k
e in
1397 let info = Ast0.get_info
e in
1398 let mcodekind = Ast0.get_mcodekind_ref
e in
1399 match Ast0.unwrap
e with
1401 (* if context is - this should be - as well. There are no tokens
1402 here though, so the bottom-up minusifier in context_neg leaves it
1403 as mixed (or context for sgrep2). It would be better to fix
1404 context_neg, but that would
1405 require a special case for each term with a dots subterm. *)
1406 (match !mcodekind with
1407 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1409 (Ast.NOTHING
,_
,_
) ->
1411 Ast0.MINUS
(ref(Ast.NOREPLACEMENT
,Ast0.default_token_info
));
1413 | _
-> failwith
"make_minus: unexpected befaft")
1414 (* code already processed by an enclosing iso *)
1415 | Ast0.MINUS
(mc
) -> e
1419 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1420 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1421 | _
-> donothing r k
e in
1424 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1425 dots dots dots dots dots dots
1426 donothing expression donothing initialiser donothing declaration
1427 statement donothing donothing donothing
1429 (* --------------------------------------------------------------------- *)
1430 (* rebuild mcode cells in an instantiated alt *)
1432 (* mcodes will be side effected later with plus code, so we have to copy
1433 them on instantiating an isomorphism. One could wonder whether it would
1434 be better not to use side-effects, but they are convenient for insert_plus
1435 where is it useful to manipulate a list of the mcodes but side-effect a
1437 (* hmm... Insert_plus is called before Iso_pattern... *)
1438 let rebuild_mcode start_line
=
1439 let copy_mcodekind = function
1440 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1441 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1442 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1443 | Ast0.PLUS count
->
1444 (* this function is used elsewhere where we need to rebuild the
1445 indices, and so we allow PLUS code as well *)
1448 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1450 match start_line
with
1453 {info.Ast0.pos_info
with
1454 Ast0.line_start
= x;
1455 Ast0.line_end
= x; } in
1456 {info with Ast0.pos_info
= new_pos_info}
1458 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1461 let old_info = Ast0.get_info
x in
1463 match start_line
with
1466 {old_info.Ast0.pos_info
with
1467 Ast0.line_start
= x;
1468 Ast0.line_end
= x; } in
1469 {old_info with Ast0.pos_info
= new_pos_info}
1470 | None
-> old_info in
1471 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1472 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1474 let donothing r k
e = copy_one (k
e) in
1476 (* case for control operators (if, etc) *)
1477 let statement r k
e =
1482 (match Ast0.unwrap
s with
1483 Ast0.Decl
((info,mc
),decl) ->
1484 Ast0.Decl
((info,copy_mcodekind mc
),decl)
1485 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1486 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1487 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1488 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1489 (info,copy_mcodekind mc
))
1490 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1491 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1492 | Ast0.For
(fr
,lp
,first,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1493 Ast0.For
(fr
,lp
,first,e2
,sem2
,e3
,rp
,body
,
1494 (info,copy_mcodekind mc
))
1495 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1496 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1498 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1500 ((info,copy_mcodekind mc
),
1501 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1503 Ast0.set_dots_bef_aft
res
1504 (match Ast0.get_dots_bef_aft
res with
1505 Ast0.NoDots
-> Ast0.NoDots
1506 | Ast0.AddingBetweenDots
s ->
1507 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1508 | Ast0.DroppingBetweenDots
s ->
1509 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1512 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1513 donothing donothing donothing donothing donothing donothing
1514 donothing donothing donothing donothing donothing
1515 donothing statement donothing donothing donothing
1517 (* --------------------------------------------------------------------- *)
1518 (* The problem of whencode. If an isomorphism contains dots in multiple
1519 rules, then the code that is matched cannot contain whencode, because we
1520 won't know which dots it goes with. Should worry about nests, but they
1521 aren't allowed in isomorphisms for the moment. *)
1524 let option_default = 0 in
1525 let bind x y
= x + y
in
1527 match Ast0.unwrap
e with
1528 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1531 V0.combiner
bind option_default
1532 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1535 let option_default = 0 in
1536 let bind x y
= x + y
in
1538 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1540 V0.combiner
bind option_default
1541 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1544 let option_default = 0 in
1545 let bind x y
= x + y
in
1547 match Ast0.unwrap
e with
1548 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1551 V0.combiner
bind option_default
1552 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1554 (* --------------------------------------------------------------------- *)
1556 let lookup name bindings mv_bindings
=
1557 try Common.Left
(List.assoc
(term name
) bindings
)
1560 (* failure is not possible anymore *)
1561 Common.Right
(List.assoc
(term name
) mv_bindings
)
1563 (* mv_bindings is for the fresh metavariables that are introduced by the
1565 let instantiate bindings mv_bindings
=
1567 let (hidden
,others
) =
1569 (function Ast0.HiddenVarTag _
-> true | _
-> false)
1573 [Ast0.HiddenVarTag
([Ast0.MetaPosTag
(Ast0.MetaPos
(name
,_
,_
))])] ->
1575 (* not at all sure that this is good enough *)
1576 match lookup name bindings mv_bindings
with
1577 Common.Left
(Ast0.HiddenVarTag
(ids
)) -> ids
1578 | _
-> failwith
"not possible"
1580 (*can't fail because checks_needed could be false?*)
1582 | [] -> [] (* no hidden metavars allowed *)
1583 | _
-> failwith
"badly compiled mcode" in
1584 Ast0.set_pos
(new_names@others
) x in
1585 let donothing r k
e = k
e in
1587 (* cases where metavariables can occur *)
1590 match Ast0.unwrap
e with
1591 Ast0.MetaId
(name
,constraints
,seed
,pure
) ->
1592 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1593 (match lookup name bindings mv_bindings
with
1594 Common.Left
(Ast0.IdentTag
(id
)) -> id
1595 | Common.Left
(_
) -> failwith
"not possible 1"
1596 | Common.Right
(new_mv
) ->
1599 (Ast0.set_mcode_data new_mv name
,constraints
,seed
,pure
)))
1600 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1601 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1604 (* case for list metavariables *)
1605 let rec elist r same_dots
= function
1608 (match Ast0.unwrap
x with
1609 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1610 failwith
"meta_expr_list in iso not supported"
1611 (*match lookup name bindings mv_bindings with
1612 Common.Left(Ast0.DotsExprTag(exp)) ->
1613 (match same_dots exp with
1615 | None -> failwith "dots put in incompatible context")
1616 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1617 | Common.Left(_) -> failwith "not possible 1"
1618 | Common.Right(new_mv) ->
1619 failwith "MetaExprList in SP not supported"*)
1620 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1621 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1623 let rec plist r same_dots
= function
1626 (match Ast0.unwrap
x with
1627 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1628 failwith
"meta_param_list in iso not supported"
1629 (*match lookup name bindings mv_bindings with
1630 Common.Left(Ast0.DotsParamTag(param)) ->
1631 (match same_dots param with
1633 | None -> failwith "dots put in incompatible context")
1634 | Common.Left(Ast0.ParamTag(param)) -> [param]
1635 | Common.Left(_) -> failwith "not possible 1"
1636 | Common.Right(new_mv) ->
1637 failwith "MetaExprList in SP not supported"*)
1638 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1639 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1641 let rec slist r same_dots
= function
1644 (match Ast0.unwrap
x with
1645 Ast0.MetaStmtList
(name
,pure
) ->
1646 (match lookup name bindings mv_bindings
with
1647 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1648 (match same_dots stm
with
1650 | None
-> failwith
"dots put in incompatible context")
1651 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1652 | Common.Left
(_
) -> failwith
"not possible 1"
1653 | Common.Right
(new_mv
) ->
1654 failwith
"MetaExprList in SP not supported")
1655 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1656 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1659 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1660 let same_circles d
=
1661 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1663 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1665 let dots list_fn r k d
=
1667 (match Ast0.unwrap d
with
1668 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1669 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1670 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1672 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1675 match Ast0.unwrap
e with
1676 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1677 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1678 (match lookup name bindings mv_bindings
with
1679 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1680 | Common.Left
(_
) -> failwith
"not possible 1"
1681 | Common.Right
(new_mv
) ->
1686 let rec renamer = function
1687 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1689 lookup (name
,(),(),(),None
,-1)
1690 bindings mv_bindings
1692 Common.Left
(Ast0.TypeCTag
(t
)) ->
1693 Ast0.ast0_type_to_type t
1695 failwith
"iso pattern: unexpected type"
1696 | Common.Right
(new_mv
) ->
1697 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1698 | Type_cocci.ConstVol
(cv
,ty
) ->
1699 Type_cocci.ConstVol
(cv
,renamer ty
)
1700 | Type_cocci.Pointer
(ty
) ->
1701 Type_cocci.Pointer
(renamer ty
)
1702 | Type_cocci.FunctionPointer
(ty
) ->
1703 Type_cocci.FunctionPointer
(renamer ty
)
1704 | Type_cocci.Array
(ty
) ->
1705 Type_cocci.Array
(renamer ty
)
1707 Some
(List.map
renamer types
) in
1710 (Ast0.set_mcode_data new_mv name
,constraints
,
1711 new_types,form
,pure
)))
1712 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1713 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1714 failwith
"metaexprlist not supported"
1715 | Ast0.Unary
(exp
,unop
) ->
1716 (match Ast0.unwrap_mcode unop
with
1717 (* propagate negation only when the propagated and the encountered
1718 negation have the same transformation, when there is nothing
1719 added to the original one, and when there is nothing added to
1720 the expression into which we are doing the propagation. This
1721 may be too conservative. *)
1724 (* k e doesn't change the outer structure of the term,
1725 only the metavars *)
1726 match Ast0.unwrap old_e
with
1727 Ast0.Unary
(exp
,_
) ->
1728 (match Ast0.unwrap exp
with
1729 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1731 | _
-> failwith
"not possible" in
1732 let nomodif = function
1735 (Ast.NOREPLACEMENT
,_
) -> true
1737 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1739 (Ast.NOTHING
,_
,_
) -> true
1741 | _
-> failwith
"plus not possible" in
1742 let same_modif newop oldop
=
1743 (* only propagate ! is they have the same modification
1744 and no + code on the old one (the new one from the iso
1745 surely has no + code) *)
1746 match (newop
,oldop
) with
1747 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1748 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1749 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1754 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1755 (* k accumulates parens, to keep negation outside if no
1756 propagation is possible *)
1757 if nomodif (Ast0.get_mcodekind
e)
1759 match Ast0.unwrap
res with
1760 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1762 (Ast0.get_mcode_mcodekind unop
)
1763 (Ast0.get_mcode_mcodekind op
) ->
1765 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1766 | Ast0.Paren
(lp
,e1,rp
) ->
1769 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1770 | Ast0.Binary
(e1,op
,e2
) when
1772 (Ast0.get_mcode_mcodekind unop
)
1773 (Ast0.get_mcode_mcodekind op
) ->
1775 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1776 let k1 x = k
(Ast0.rewrap
e x) in
1777 (match Ast0.unwrap_mcode op
with
1778 Ast.Logical
(Ast.Inf
) ->
1779 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1780 | Ast.Logical
(Ast.Sup
) ->
1781 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1782 | Ast.Logical
(Ast.InfEq
) ->
1783 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1784 | Ast.Logical
(Ast.SupEq
) ->
1785 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1786 | Ast.Logical
(Ast.Eq
) ->
1787 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1788 | Ast.Logical
(Ast.NotEq
) ->
1789 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1790 | Ast.Logical
(Ast.AndLog
) ->
1791 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1793 negate_reb
e e2
idcont))
1794 | Ast.Logical
(Ast.OrLog
) ->
1795 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1797 negate_reb
e e2
idcont))
1801 Ast0.rewrap_mcode op
Ast.Not
)))
1802 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1803 (* use res because it is the transformed argument *)
1805 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1806 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1808 (*use e, because this might be the toplevel expression*)
1810 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1813 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1814 and negate_reb
e e1 k
=
1815 (* used when ! is propagated to multiple places, to avoid
1816 duplicating mcode cells *)
1818 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1819 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1824 | Ast0.Edots
(d
,_
) ->
1826 (match List.assoc
(dot_term d
) bindings
with
1827 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1828 | _
-> failwith
"unexpected binding")
1829 with Not_found
-> e)
1830 | Ast0.Ecircles
(d
,_
) ->
1832 (match List.assoc
(dot_term d
) bindings
with
1833 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1834 | _
-> failwith
"unexpected binding")
1835 with Not_found
-> e)
1836 | Ast0.Estars
(d
,_
) ->
1838 (match List.assoc
(dot_term d
) bindings
with
1839 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1840 | _
-> failwith
"unexpected binding")
1841 with Not_found
-> e)
1843 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1847 match Ast0.unwrap
e with
1848 Ast0.MetaType
(name
,pure
) ->
1849 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1850 (match lookup name bindings mv_bindings
with
1851 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1852 | Common.Left
(_
) -> failwith
"not possible 1"
1853 | Common.Right
(new_mv
) ->
1855 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1860 match Ast0.unwrap
e with
1861 Ast0.MetaInit
(name
,pure
) ->
1862 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1863 (match lookup name bindings mv_bindings
with
1864 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1865 | Common.Left
(_
) -> failwith
"not possible 1"
1866 | Common.Right
(new_mv
) ->
1868 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1873 match Ast0.unwrap
e with
1874 Ast0.MetaDecl
(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.MetaDecl
(Ast0.set_mcode_data new_mv name
, pure
)))
1882 | Ast0.MetaField
(name
,pure
) ->
1883 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1884 (match lookup name bindings mv_bindings
with
1885 Common.Left
(Ast0.DeclTag
(d
)) -> d
1886 | Common.Left
(_
) -> failwith
"not possible 1"
1887 | Common.Right
(new_mv
) ->
1889 (Ast0.MetaField
(Ast0.set_mcode_data new_mv name
, pure
)))
1890 | Ast0.MetaFieldList
(name
,lenname
,pure
) ->
1891 failwith
"metafieldlist not supported"
1892 | Ast0.Ddots
(d
,_
) ->
1894 (match List.assoc
(dot_term d
) bindings
with
1895 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1896 | _
-> failwith
"unexpected binding")
1897 with Not_found
-> e)
1902 match Ast0.unwrap
e with
1903 Ast0.MetaParam
(name
,pure
) ->
1904 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1905 (match lookup name bindings mv_bindings
with
1906 Common.Left
(Ast0.ParamTag
(param)) -> param
1907 | Common.Left
(_
) -> failwith
"not possible 1"
1908 | Common.Right
(new_mv
) ->
1910 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1911 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1912 failwith
"metaparamlist not supported"
1917 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1918 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1919 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1920 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1921 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1922 | _
-> failwith
"unexpected binding" in
1926 match Ast0.unwrap
e with
1927 Ast0.MetaStmt
(name
,pure
) ->
1928 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1929 (match lookup name bindings mv_bindings
with
1930 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1931 | Common.Left
(_
) -> failwith
"not possible 1"
1932 | Common.Right
(new_mv
) ->
1934 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1935 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1941 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1942 | Ast0.Circles
(d
,_
) ->
1947 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1948 | Ast0.Stars
(d
,_
) ->
1953 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1957 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1958 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1959 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1962 (* --------------------------------------------------------------------- *)
1965 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1967 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1969 let disj_fail bindings
e =
1971 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1974 (* isomorphism code is by default CONTEXT *)
1975 let merge_plus model_mcode e_mcode
=
1976 match model_mcode
with
1978 (* add the replacement information at the root *)
1982 (match (!mc
,!emc
) with
1983 ((Ast.NOREPLACEMENT
,_
),(x,t
))
1984 | ((x,_
),(Ast.NOREPLACEMENT
,t
)) -> (x,t
)
1985 | _
-> failwith
"how can we combine minuses?")
1986 | _
-> failwith
"not possible 6")
1987 | Ast0.CONTEXT
(mc
) ->
1989 Ast0.CONTEXT
(emc
) ->
1990 (* keep the logical line info as in the model *)
1991 let (mba
,tb
,ta
) = !mc
in
1992 let (eba
,_
,_
) = !emc
in
1993 (* merging may be required when a term is replaced by a subterm *)
1995 match (mba
,eba
) with
1996 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1997 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1998 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1999 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
2000 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
2001 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
2002 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
2003 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
2004 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
2005 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
2006 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
2007 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
2008 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
2009 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
2010 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
2011 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
2012 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
2013 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
2014 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
2015 emc
:= (merged,tb
,ta
)
2016 | Ast0.MINUS
(emc
) ->
2017 let (anything_bef_aft
,_
,_
) = !mc
in
2018 let (anythings
,t
) = !emc
in
2019 (match (anything_bef_aft
,anythings
) with
2020 (Ast.BEFORE
(b1
,it1
),Ast.NOREPLACEMENT
) ->
2021 emc
:= (Ast.REPLACEMENT
(b1
,it1
),t
)
2022 | (Ast.AFTER
(a1
,it1
),Ast.NOREPLACEMENT
) ->
2023 emc
:= (Ast.REPLACEMENT
(a1
,it1
),t
)
2024 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.NOREPLACEMENT
) ->
2025 emc
:= (Ast.REPLACEMENT
(b1
@a1
,it1
),t
)
2026 | (Ast.NOTHING
,Ast.NOREPLACEMENT
) ->
2027 emc
:= (Ast.NOREPLACEMENT
,t
)
2028 | (Ast.BEFORE
(b1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2029 emc
:= (Ast.REPLACEMENT
(b1
@a2
,Ast.lub_count it1 it2
),t
)
2030 | (Ast.AFTER
(a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2031 emc
:= (Ast.REPLACEMENT
(a2
@a1
,Ast.lub_count it1 it2
),t
)
2032 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.REPLACEMENT
(a2
,it2
)) ->
2033 emc
:= (Ast.REPLACEMENT
(b1
@a2
@a1
,Ast.lub_count it1 it2
),t
)
2034 | (Ast.NOTHING
,Ast.REPLACEMENT
(a2
,it2
)) -> ()) (* no change *)
2035 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
2036 | _
-> failwith
"not possible 7")
2037 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
2038 | Ast0.PLUS _
-> failwith
"not possible 9"
2040 let copy_plus printer minusify model
e =
2041 if !Flag.sgrep_mode2
2042 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
2046 match Ast0.get_mcodekind model
with
2047 Ast0.MINUS
(mc
) -> minusify
e
2048 | Ast0.CONTEXT
(mc
) -> e
2049 | _
-> failwith
"not possible: copy_plus\n" in
2050 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
2054 let copy_minus printer minusify model
e =
2055 match Ast0.get_mcodekind model
with
2056 Ast0.MINUS
(mc
) -> minusify
e
2057 | Ast0.CONTEXT
(mc
) -> e
2059 if !Flag.sgrep_mode2
2061 else failwith
"not possible 8"
2062 | Ast0.PLUS _
-> failwith
"not possible 9"
2064 let whencode_allowed prev_ecount prev_icount prev_dcount
2065 ecount icount dcount rest
=
2066 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
2068 let other_ecount = (* number of edots *)
2069 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
2071 let other_icount = (* number of dots *)
2072 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
2074 let other_dcount = (* number of dots *)
2075 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
2077 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
2078 dcount
= 0 or other_dcount = 0)
2080 (* copy the befores and afters to the instantiated code *)
2081 let extra_copy_stmt_plus model
e =
2082 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
2084 (match Ast0.unwrap model
with
2085 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
2086 | Ast0.Decl
((info,bef
),_
) ->
2087 (match Ast0.unwrap
e with
2088 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
2089 | Ast0.Decl
((info,bef1
),_
) ->
2091 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
2092 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
2093 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2094 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
2095 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2096 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
2097 (match Ast0.unwrap
e with
2098 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
2099 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2100 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
2101 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2102 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
2104 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
2108 let extra_copy_other_plus model
e = e
2110 (* --------------------------------------------------------------------- *)
2112 let mv_count = ref 0
2114 let ct = !mv_count in
2115 mv_count := !mv_count + 1;
2116 "_"^
s^
"_"^
(string_of_int
ct)
2118 let get_name = function
2119 Ast.MetaMetaDecl
(ar
,nm) ->
2120 (nm,function nm -> Ast.MetaMetaDecl
(ar
,nm))
2121 | Ast.MetaIdDecl
(ar
,nm) ->
2122 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2123 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2124 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2125 | Ast.MetaTypeDecl
(ar
,nm) ->
2126 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2127 | Ast.MetaInitDecl
(ar
,nm) ->
2128 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2129 | Ast.MetaInitListDecl
(ar
,nm,nm1
) ->
2130 (nm,function nm -> Ast.MetaInitListDecl
(ar
,nm,nm1
))
2131 | Ast.MetaListlenDecl
(nm) ->
2132 failwith
"should not be rebuilt"
2133 | Ast.MetaParamDecl
(ar
,nm) ->
2134 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2135 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2136 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2137 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2138 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2139 | Ast.MetaErrDecl
(ar
,nm) ->
2140 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2141 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2142 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2143 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2144 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2145 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2146 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2147 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2148 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2149 | Ast.MetaDeclDecl
(ar
,nm) ->
2150 (nm,function nm -> Ast.MetaDeclDecl
(ar
,nm))
2151 | Ast.MetaFieldListDecl
(ar
,nm,nm1
) ->
2152 (nm,function nm -> Ast.MetaFieldListDecl
(ar
,nm,nm1
))
2153 | Ast.MetaFieldDecl
(ar
,nm) ->
2154 (nm,function nm -> Ast.MetaFieldDecl
(ar
,nm))
2155 | Ast.MetaStmDecl
(ar
,nm) ->
2156 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2157 | Ast.MetaStmListDecl
(ar
,nm) ->
2158 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2159 | Ast.MetaFuncDecl
(ar
,nm) ->
2160 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2161 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2162 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2163 | Ast.MetaPosDecl
(ar
,nm) ->
2164 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2165 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2166 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2167 | Ast.MetaIteratorDecl
(ar
,nm) ->
2168 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2170 let make_new_metavars metavars bindings
=
2174 let (s,_
) = get_name mv
in
2175 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2180 let (s,rebuild
) = get_name mv
in
2181 let new_s = (!current_rule,new_mv s) in
2182 (rebuild
new_s, (s,new_s)))
2185 (* --------------------------------------------------------------------- *)
2187 let do_nothing x = x
2189 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2190 rebuild_mcodes name printer extra_plus update_others has_context
=
2191 let call_instantiate bindings mv_bindings alts pattern has_context
=
2194 (function (a
,_,_,_) ->
2196 (* no need to create duplicates when the bindings have no effect *)
2198 (function bindings
->
2200 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2202 if has_context
(* ie if pat is not just a metavara *)
2204 copy_plus printer minusify
e (extra_plus
e instantiated)
2205 else instantiated in
2208 else (* iso tracking *)
2209 Ast0.set_iso
plus_added
2210 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2213 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2214 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2215 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2217 whencode_allowed prev_ecount prev_icount prev_dcount
2218 ecount dcount icount rest
in
2219 (match matcher
true (context_required e) wc pattern
e init_env with
2221 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2224 (match matcher
false false wc pattern
e init_env with
2226 interpret_reason name
(Ast0.get_line
e) reason
2227 (function () -> printer
e)
2229 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2230 (prev_dcount
+ dcount
) rest
2231 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2233 (* apply update_others to all patterns other than the matched
2234 one. This is used to desigate the others as test
2235 expressions in the TestExpression case *)
2237 (function (x,e,i
,d
) as all
->
2240 else (update_others
x,e,i
,d
))
2241 (List.hd
all_alts)) ::
2243 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2244 (List.tl
all_alts)) in
2245 (match List.concat
all_alts with
2246 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2248 let (new_metavars,mv_bindings
) =
2249 make_new_metavars metavars
(nub(List.concat bindings
)) in
2252 call_instantiate bindings mv_bindings
all_alts pattern
2253 (has_context pattern
)))) in
2254 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2255 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2256 | (alts
::rest
) as all_alts ->
2257 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2258 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2259 outer_loop prev_ecount prev_icount prev_dcount rest
2260 | Common.Right
(new_metavars,res) ->
2262 copy_minus printer minusify
e (disj_maker
res)) in
2263 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2264 (count
, metavars
, e)
2266 (* no one should ever look at the information stored in these mcodes *)
2267 let disj_starter lst
=
2268 let old_info = Ast0.get_info
(List.hd lst
) in
2270 { old_info.Ast0.pos_info
with
2271 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2272 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2274 { Ast0.pos_info
= new_pos_info;
2275 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2276 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2277 Ast0.strings_before
= []; Ast0.strings_after
= [];
2278 Ast0.isSymbolIdent
= false; } in
2279 Ast0.make_mcode_info
"(" info
2281 let disj_ender lst
=
2282 let old_info = Ast0.get_info
(List.hd lst
) in
2284 { old_info.Ast0.pos_info
with
2285 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2286 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2288 { Ast0.pos_info
= new_pos_info;
2289 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2290 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2291 Ast0.strings_before
= []; Ast0.strings_after
= [];
2292 Ast0.isSymbolIdent
= false; } in
2293 Ast0.make_mcode_info
")" info
2295 let disj_mid _ = Ast0.make_mcode
"|"
2297 let make_disj_type tl
=
2300 [] -> failwith
"bad disjunction"
2301 | x::xs
-> List.map
disj_mid xs
in
2302 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2303 let make_disj_stmt_list tl
=
2306 [] -> failwith
"bad disjunction"
2307 | x::xs
-> List.map
disj_mid xs
in
2308 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2309 let make_disj_expr model el
=
2312 [] -> failwith
"bad disjunction"
2313 | x::xs
-> List.map
disj_mid xs
in
2315 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2317 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2318 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2319 let el = List.map
update_arg (List.map
update_test el) in
2320 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2321 let make_disj_decl dl
=
2324 [] -> failwith
"bad disjunction"
2325 | x::xs
-> List.map
disj_mid xs
in
2326 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2327 let make_disj_stmt sl
=
2328 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2331 [] -> failwith
"bad disjunction"
2332 | x::xs
-> List.map
disj_mid xs
in
2334 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2336 let transform_type (metavars
,alts
,name
) e =
2338 (Ast0.TypeCTag
(_)::_)::_ ->
2339 (* start line is given to any leaves in the iso code *)
2341 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2347 (p
,count_edots.VT0.combiner_rec_typeC p
,
2348 count_idots.VT0.combiner_rec_typeC p
,
2349 count_dots.VT0.combiner_rec_typeC p
)
2350 | _ -> failwith
"invalid alt"))
2352 mkdisj match_typeC metavars
alts e
2353 (function b
-> function mv_b
->
2354 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2355 (function t
-> Ast0.TypeCTag t
)
2356 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2357 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2358 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2360 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2364 let transform_expr (metavars
,alts,name
) e =
2365 let process update_others
=
2366 (* start line is given to any leaves in the iso code *)
2368 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2373 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2374 (p
,count_edots.VT0.combiner_rec_expression p
,
2375 count_idots.VT0.combiner_rec_expression p
,
2376 count_dots.VT0.combiner_rec_expression p
)
2377 | _ -> failwith
"invalid alt"))
2379 mkdisj match_expr metavars
alts e
2380 (function b
-> function mv_b
->
2381 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2382 (function e -> Ast0.ExprTag
e)
2384 make_minus.VT0.rebuilder_rec_expression
2385 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2386 name
Unparse_ast0.expression extra_copy_other_plus update_others
2388 match Ast0.unwrap
x with
2389 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2393 (Ast0.ExprTag
(_)::r
)::rs
->
2394 (* hack to accomodate ToTestExpression case, where the first pattern is
2395 a normal expression, but the others are test expressions *)
2396 let others = r
@ (List.concat rs
) in
2397 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2398 if List.for_all
is_test others then process Ast0.set_test_exp
2399 else if List.exists
is_test others then failwith
"inconsistent iso"
2400 else process do_nothing
2401 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2402 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2403 process Ast0.set_test_exp
2406 let transform_decl (metavars
,alts,name
) e =
2408 (Ast0.DeclTag
(_)::_)::_ ->
2409 (* start line is given to any leaves in the iso code *)
2411 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2417 (p
,count_edots.VT0.combiner_rec_declaration p
,
2418 count_idots.VT0.combiner_rec_declaration p
,
2419 count_dots.VT0.combiner_rec_declaration p
)
2420 | _ -> failwith
"invalid alt"))
2422 mkdisj match_decl metavars
alts e
2423 (function b
-> function mv_b
->
2424 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2425 (function d
-> Ast0.DeclTag d
)
2427 make_minus.VT0.rebuilder_rec_declaration
2428 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2429 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2430 (function _ -> true (* no metavars *))
2433 let transform_stmt (metavars
,alts,name
) e =
2435 (Ast0.StmtTag
(_)::_)::_ ->
2436 (* start line is given to any leaves in the iso code *)
2438 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2444 (p
,count_edots.VT0.combiner_rec_statement p
,
2445 count_idots.VT0.combiner_rec_statement p
,
2446 count_dots.VT0.combiner_rec_statement p
)
2447 | _ -> failwith
"invalid alt"))
2449 mkdisj match_statement metavars
alts e
2450 (function b
-> function mv_b
->
2451 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2452 (function s -> Ast0.StmtTag
s)
2453 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2454 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2455 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2457 match Ast0.unwrap
x with
2458 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2462 (* sort of a hack, because there is no disj at top level *)
2463 let transform_top (metavars
,alts,name
) e =
2464 match Ast0.unwrap
e with
2465 Ast0.NONDECL
(declstm
) ->
2471 Ast0.DotsStmtTag
(d
) ->
2472 (match Ast0.unwrap d
with
2473 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2474 | _ -> raise
(Failure
""))
2475 | _ -> raise
(Failure
"")))
2477 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2478 (count
,mv
,Ast0.rewrap
e (Ast0.NONDECL
(s)))
2479 with Failure
_ -> (0,[],e))
2480 | Ast0.CODE
(stmts
) ->
2481 let (count
,mv
,res) =
2483 (Ast0.DotsStmtTag
(_)::_)::_ ->
2484 (* start line is given to any leaves in the iso code *)
2486 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2491 Ast0.DotsStmtTag
(p
) ->
2492 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2493 count_idots.VT0.combiner_rec_statement_dots p
,
2494 count_dots.VT0.combiner_rec_statement_dots p
)
2495 | _ -> failwith
"invalid alt"))
2497 mkdisj match_statement_dots metavars
alts stmts
2498 (function b
-> function mv_b
->
2499 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2500 (function s -> Ast0.DotsStmtTag
s)
2502 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2504 make_minus.VT0.rebuilder_rec_statement_dots
x)
2505 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2506 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2507 (function _ -> true)
2508 | _ -> (0,[],stmts
) in
2509 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2512 (* --------------------------------------------------------------------- *)
2514 let transform (alts : isomorphism
) t
=
2515 (* the following ugliness is because rebuilder only returns a new term *)
2516 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2517 let in_limit n
= function
2521 ((if !Flag_parsing_cocci.show_iso_failures
2522 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2524 let bind x y
= x + y
in
2525 let option_default = 0 in
2527 let (e_count
,e) = k
e in
2528 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2530 let (count
,extra_meta
,exp
) = transform_expr alts e in
2531 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2532 (bind count e_count
,exp
)
2536 let (e_count
,e) = k
e in
2537 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2539 let (count
,extra_meta
,dec
) = transform_decl alts e in
2540 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2541 (bind count e_count
,dec
)
2545 let (e_count
,e) = k
e in
2546 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2548 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2549 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2550 (bind count e_count
,stm
)
2554 let (continue
,e_count
,e) =
2555 match Ast0.unwrap
e with
2556 Ast0.Signed
(signb
,tyb
) ->
2557 (* Hack! How else to prevent iso from applying under an
2561 let (e_count
,e) = k
e in
2562 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2563 then (true,e_count
,e)
2564 else (false,e_count
,e) in
2567 let (count
,extra_meta
,ty
) = transform_type alts e in
2568 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2569 (bind count e_count
,ty
)
2573 let (e_count
,e) = k
e in
2574 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2576 let (count
,extra_meta
,ty
) = transform_top alts e in
2577 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2578 (bind count e_count
,ty
)
2582 V0.combiner_rebuilder
bind option_default
2583 {V0.combiner_rebuilder_functions
with
2584 VT0.combiner_rebuilder_exprfn
= exprfn;
2585 VT0.combiner_rebuilder_tyfn
= typefn;
2586 VT0.combiner_rebuilder_declfn
= declfn;
2587 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2588 VT0.combiner_rebuilder_topfn
= topfn} in
2589 let (_,res) = res.VT0.top_level t
in
2590 (!extra_meta_decls,res)
2592 (* --------------------------------------------------------------------- *)
2594 (* should be done by functorizing the parser to use wrap or context_wrap *)
2596 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2597 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2599 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2600 donothing donothing donothing donothing donothing donothing
2601 donothing donothing donothing donothing donothing donothing donothing
2602 donothing donothing donothing
2604 let rewrap_anything = function
2605 Ast0.DotsExprTag
(d
) ->
2606 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2607 | Ast0.DotsInitTag
(d
) ->
2608 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2609 | Ast0.DotsParamTag
(d
) ->
2610 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2611 | Ast0.DotsStmtTag
(d
) ->
2612 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2613 | Ast0.DotsDeclTag
(d
) ->
2614 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2615 | Ast0.DotsCaseTag
(d
) ->
2616 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2617 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2618 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2619 | Ast0.ArgExprTag
(d
) ->
2620 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2621 | Ast0.TestExprTag
(d
) ->
2622 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2623 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2624 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2625 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2626 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2627 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2628 | Ast0.ForInfoTag
(d
) -> Ast0.ForInfoTag
(rewrap.VT0.rebuilder_rec_forinfo d
)
2629 | Ast0.CaseLineTag
(d
) ->
2630 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2631 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2632 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2633 failwith
"only for isos within iso phase"
2634 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2635 | Ast0.HiddenVarTag
(p
) -> Ast0.HiddenVarTag
(p
) (* not sure it is possible *)
2637 (* --------------------------------------------------------------------- *)
2639 let apply_isos isos rule rule_name
=
2644 current_rule := rule_name
;
2647 (function (metavars
,iso
,name
) ->
2648 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2650 let (extra_meta
,rule
) =
2655 (function (extra_meta
,t
) -> function iso
->
2656 let (new_extra_meta
,t
) = transform iso t
in
2657 (new_extra_meta
@extra_meta
,t
))
2660 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)