2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
24 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
25 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
26 * This file is part of Coccinelle.
28 * Coccinelle is free software: you can redistribute it and/or modify
29 * it under the terms of the GNU General Public License as published by
30 * the Free Software Foundation, according to version 2 of the License.
32 * Coccinelle is distributed in the hope that it will be useful,
33 * but WITHOUT ANY WARRANTY; without even the implied warranty of
34 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 * GNU General Public License for more details.
37 * You should have received a copy of the GNU General Public License
38 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
40 * The authors reserve the right to distribute this or future versions of
41 * Coccinelle under other licenses.
45 (* Potential problem: offset of mcode is not updated when an iso is
46 instantiated, implying that a term may end up with many mcodes with the
47 same offset. On the other hand, at the moment offset only seems to be used
48 before this phase. Furthermore add_dot_binding relies on the offset to
49 remain the same between matching an iso and instantiating it with bindings. *)
51 (* --------------------------------------------------------------------- *)
52 (* match a SmPL expression against a SmPL abstract syntax tree,
55 module Ast
= Ast_cocci
56 module Ast0
= Ast0_cocci
57 module V0
= Visitor_ast0
58 module VT0
= Visitor_ast0_types
60 let current_rule = ref ""
62 (* --------------------------------------------------------------------- *)
65 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
68 let mcode (term
,_
,_
,_
,_
,_
) =
69 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
70 ref Ast0.NoMetaPos
,-1) in
73 {(Ast0.wrap
(Ast0.unwrap
x)) with
74 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
75 Ast0.true_if_test
= x.Ast0.true_if_test
} in
77 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
78 donothing donothing donothing donothing donothing donothing
79 donothing donothing donothing donothing donothing donothing donothing
82 let anything_equal = function
83 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
84 failwith
"not a possible variable binding" (*not sure why these are pbs*)
85 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
86 failwith
"not a possible variable binding"
87 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
88 failwith
"not a possible variable binding"
89 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
90 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
91 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
92 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
93 failwith
"not a possible variable binding"
94 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
95 failwith
"not a possible variable binding"
96 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
97 (strip_info.VT0.rebuilder_rec_ident d1
) =
98 (strip_info.VT0.rebuilder_rec_ident d2
)
99 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
100 (strip_info.VT0.rebuilder_rec_expression d1
) =
101 (strip_info.VT0.rebuilder_rec_expression d2
)
102 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
103 failwith
"not possible - only in isos1"
104 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
105 failwith
"not possible - only in isos1"
106 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
107 (strip_info.VT0.rebuilder_rec_typeC d1
) =
108 (strip_info.VT0.rebuilder_rec_typeC d2
)
109 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
110 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
111 (strip_info.VT0.rebuilder_rec_initialiser d2
)
112 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
113 (strip_info.VT0.rebuilder_rec_parameter d1
) =
114 (strip_info.VT0.rebuilder_rec_parameter d2
)
115 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
116 (strip_info.VT0.rebuilder_rec_declaration d1
) =
117 (strip_info.VT0.rebuilder_rec_declaration d2
)
118 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
119 (strip_info.VT0.rebuilder_rec_statement d1
) =
120 (strip_info.VT0.rebuilder_rec_statement d2
)
121 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
122 (strip_info.VT0.rebuilder_rec_case_line d1
) =
123 (strip_info.VT0.rebuilder_rec_case_line d2
)
124 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
125 (strip_info.VT0.rebuilder_rec_top_level d1
) =
126 (strip_info.VT0.rebuilder_rec_top_level d2
)
127 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
128 failwith
"only for isos within iso phase"
129 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
130 failwith
"only for isos within iso phase"
131 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
132 failwith
"only for isos within iso phase"
135 let term (var1
,_
,_
,_
,_
,_
) = var1
136 let dot_term (var1
,_
,info
,_
,_
,_
) =
137 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
141 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
142 | NotPureLength
of Ast.meta_name
143 | ContextRequired
of Ast0.anything
145 | Braces
of Ast0.statement
146 | Position
of Ast.meta_name
147 | TypeMatch
of reason list
149 let rec interpret_reason name line reason printer
=
151 "warning: iso %s does not match the code below on line %d\n" name line
;
152 printer
(); Format.print_newline
();
154 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
156 "pure metavariable %s is matched against the following nonpure code:\n"
158 Unparse_ast0.unparse_anything nonpure
159 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
161 "context metavariable %s is matched against the following\nnoncontext code:\n"
163 Unparse_ast0.unparse_anything nonpure
164 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
166 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
168 Unparse_ast0.unparse_anything nonpure
169 | NotPureLength
((_
,var
)) ->
171 "pure metavariable %s is matched against too much or too little code\n"
173 | ContextRequired
(term) ->
175 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
176 Unparse_ast0.unparse_anything
term
178 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
179 Unparse_ast0.statement
"" s
;
180 Format.print_newline
()
181 | Position
(rule
,name
) ->
182 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
184 | TypeMatch reason_list
->
185 List.iter
(function r
-> interpret_reason name line r printer
)
187 | _
-> failwith
"not possible"
189 type 'a either
= OK
of 'a
| Fail
of reason
191 let add_binding var exp bindings
=
192 let var = term var in
193 let attempt bindings
=
195 let cur = List.assoc
var bindings
in
196 if anything_equal(exp
,cur) then [bindings
] else []
197 with Not_found
-> [((var,exp
)::bindings
)] in
198 match List.concat
(List.map
attempt bindings
) with
202 let add_dot_binding var exp bindings
=
203 let var = dot_term var in
204 let attempt bindings
=
206 let cur = List.assoc
var bindings
in
207 if anything_equal(exp
,cur) then [bindings
] else []
208 with Not_found
-> [((var,exp
)::bindings
)] in
209 match List.concat
(List.map
attempt bindings
) with
214 let add_multi_dot_binding var exp bindings
=
215 let var = dot_term var in
216 let attempt bindings
= [((var,exp
)::bindings
)] in
217 match List.concat
(List.map
attempt bindings
) with
224 | (x::xs
) when (List.mem
x xs
) -> nub xs
225 | (x::xs
) -> x::(nub xs
)
227 (* --------------------------------------------------------------------- *)
231 let debug str m binding
=
232 let res = m binding
in
234 None
-> Printf.printf
"%s: failed\n" str
238 Printf.printf
"%s: %s\n" str
239 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
243 let conjunct_bindings
244 (m1
: 'binding
-> 'binding either
)
245 (m2
: 'binding
-> 'binding either
)
246 (binding
: 'binding
) : 'binding either
=
247 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
249 let rec conjunct_many_bindings = function
250 [] -> failwith
"not possible"
252 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
254 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
256 let return b binding
= if b
then OK binding
else Fail NonMatch
257 let return_false reason binding
= Fail reason
259 let match_option f t1 t2
=
261 (Some t1
, Some t2
) -> f t1 t2
262 | (None
, None
) -> return true
265 let bool_match_option f t1 t2
=
267 (Some t1
, Some t2
) -> f t1 t2
268 | (None
, None
) -> true
271 (* context_required is for the example
275 where we can't change x == NULL to eg NULL == x. So there can either be
276 nothing attached to the root or the term has to be all removed.
277 if would be nice if we knew more about the relationship between the - and +
278 code, because in the case where the + code is a separate statement in a
279 sequence, this is not a problem. Perhaps something could be done in
282 The example seems strange. Why isn't the cast attached to x?
285 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
286 (match Ast0.get_mcodekind e
with
287 Ast0.CONTEXT
(cell
) -> true
290 (* needs a special case when there is a Disj or an empty DOTS
291 the following stops at the statement level, and gives true if one
292 statement is replaced by another *)
293 let rec is_pure_context s
=
294 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
295 (match Ast0.unwrap s
with
296 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
299 match Ast0.undots
x with
300 [s
] -> is_pure_context s
301 | _
-> false (* could we do better? *))
304 (match Ast0.get_mcodekind s
with
307 (Ast.NOTHING
,_
,_
) -> true
311 (* do better for the common case of replacing a stmt by another one *)
312 ([[Ast.StatementTag
(s
)]],_
) ->
313 (match Ast.unwrap s
with
314 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
320 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
322 let match_list matcher is_list_matcher do_list_match la lb
=
323 let rec loop = function
324 ([],[]) -> return true
325 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
326 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
327 | _
-> return false in
330 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
332 let match_maker checks_needed context_required whencode_allowed
=
334 let check_mcode pmc cmc binding
=
337 match Ast0.get_pos cmc
with
338 (Ast0.MetaPos
(name
,_
,_
)) as x ->
339 (match Ast0.get_pos pmc
with
340 Ast0.MetaPos
(name1
,_
,_
) ->
341 add_binding name1
(Ast0.MetaPosTag
x) binding
343 let (rule
,name
) = Ast0.unwrap_mcode name
in
344 Fail
(Position
(rule
,name
)))
345 | Ast0.NoMetaPos
-> OK binding
348 let match_dots matcher is_list_matcher do_list_match d1 d2
=
349 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
350 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
351 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
352 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
353 match_list matcher is_list_matcher
(do_list_match d2
) la lb
354 | _
-> return false in
356 let is_elist_matcher el
=
357 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
359 let is_plist_matcher pl
=
360 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
362 let is_slist_matcher pl
=
363 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
365 let no_list _
= false in
367 let build_dots pattern data
=
368 match Ast0.unwrap pattern
with
369 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
370 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
371 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
374 let bind = Ast0.lub_pure
in
375 let option_default = Ast0.Context
in
376 let pure_mcodekind mc
=
378 then Ast0.PureContext
383 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
386 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
387 | _
-> Ast0.Impure
in
388 let donothing r k e
=
389 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
391 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
393 (* a case for everything that has a metavariable *)
394 (* pure is supposed to match only unitary metavars, not anything that
395 contains only unitary metavars *)
397 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
398 (match Ast0.unwrap i
with
399 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
400 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
401 | _
-> Ast0.Impure
) in
403 let expression r k e
=
404 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
405 (match Ast0.unwrap e
with
406 Ast0.MetaErr
(name
,_
,pure
)
407 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
409 | _
-> Ast0.Impure
) in
412 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
413 (match Ast0.unwrap t
with
414 Ast0.MetaType
(name
,pure
) -> pure
415 | _
-> Ast0.Impure
) in
418 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
419 (match Ast0.unwrap t
with
420 Ast0.MetaInit
(name
,pure
) -> pure
421 | _
-> Ast0.Impure
) in
424 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
425 (match Ast0.unwrap p
with
426 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
427 | _
-> Ast0.Impure
) in
430 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
431 (match Ast0.unwrap s
with
432 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
433 | _
-> Ast0.Impure
) in
435 V0.flat_combiner
bind option_default
436 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
437 donothing donothing donothing donothing donothing donothing
438 ident expression typeC init param donothing stmt donothing
441 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
442 match (checks_needed
,pure
) with
443 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
446 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
447 then add_binding name
(builder1 lst
)
448 else return_false (NotPure
(pure
,term name
,builder1 lst
))
449 | _
-> return_false (NotPureLength
(term name
)))
450 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
452 let add_pure_binding name pure is_pure builder
x =
453 match (checks_needed
,pure
) with
454 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
455 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
456 then add_binding name
(builder
x)
457 else return_false (NotPure
(pure
,term name
, builder
x))
458 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
460 let do_elist_match builder el lst
=
461 match Ast0.unwrap el
with
462 Ast0.MetaExprList
(name
,lenname
,pure
) ->
463 (*how to handle lenname? should it be an option type and always None?*)
464 failwith
"expr list pattern not supported in iso"
465 (*add_pure_list_binding name pure
466 pure_sp_code.V0.combiner_expression
467 (function lst -> Ast0.ExprTag(List.hd lst))
468 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
470 | _
-> failwith
"not possible" in
472 let do_plist_match builder pl lst
=
473 match Ast0.unwrap pl
with
474 Ast0.MetaParamList
(name
,lename
,pure
) ->
475 failwith
"param list pattern not supported in iso"
476 (*add_pure_list_binding name pure
477 pure_sp_code.V0.combiner_parameter
478 (function lst -> Ast0.ParamTag(List.hd lst))
479 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
481 | _
-> failwith
"not possible" in
483 let do_slist_match builder sl lst
=
484 match Ast0.unwrap sl
with
485 Ast0.MetaStmtList
(name
,pure
) ->
486 add_pure_list_binding name pure
487 pure_sp_code.VT0.combiner_rec_statement
488 (function lst
-> Ast0.StmtTag
(List.hd lst
))
489 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
491 | _
-> failwith
"not possible" in
493 let do_nolist_match _ _
= failwith
"not possible" in
495 let rec match_ident pattern id
=
496 match Ast0.unwrap pattern
with
497 Ast0.MetaId
(name
,_
,pure
) ->
498 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
499 (function id
-> Ast0.IdentTag id
) id
)
500 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
501 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
503 if not
(checks_needed
) or not
(context_required
) or is_context id
505 match (up
,Ast0.unwrap id
) with
506 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
507 if mcode_equal namea nameb
508 then check_mcode namea nameb
510 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
511 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
513 | (_
,Ast0.OptIdent
(idb
))
514 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
516 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
518 (* should we do something about matching metavars against ...? *)
519 let rec match_expr pattern expr
=
520 match Ast0.unwrap pattern
with
521 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
523 match (form
,expr
) with
527 match Ast0.unwrap e
with
528 Ast0.Constant
(c
) -> true
530 (match Ast0.unwrap c
with
532 let nm = Ast0.unwrap_mcode
nm in
533 (* all caps is a const *)
534 Str.string_match
all_caps nm 0
536 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
537 | Ast0.SizeOfExpr
(se
,exp
) -> true
538 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
539 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
540 (Ast0.lub_pure p pure
) = pure
543 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
545 match Ast0.unwrap e
with
546 Ast0.Ident
(c
) -> true
547 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
548 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
549 (Ast0.lub_pure p pure
) = pure
557 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
561 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
563 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
564 (* easier than updating type inferencer to manage multiple
566 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
567 | (_
,Some ty
) -> Some
[ty
]
571 let tyname = Ast0.rewrap_mcode name
tyname in
573 (add_pure_binding name pure
574 pure_sp_code.VT0.combiner_rec_expression
575 (function expr
-> Ast0.ExprTag expr
)
577 (function bindings
->
582 add_pure_binding tyname Ast0.Impure
583 (function _
-> Ast0.Impure
)
584 (function ty
-> Ast0.TypeCTag ty
)
586 (Ast0.reverse_type
expty))
590 "warning: unconvertible type";
591 return false bindings
))
594 (function Fail _
-> false | OK
x -> true)
597 (* not sure why this is ok. can there be more
601 (function Fail _
-> [] | OK
x -> x)
609 | OK
x -> failwith
"not possible")
613 "warning: type metavar can only match one type";*)
617 "mixture of metatype and other types not supported")
619 let expty = Ast0.get_type expr
in
620 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
622 add_pure_binding name pure
623 pure_sp_code.VT0.combiner_rec_expression
624 (function expr
-> Ast0.ExprTag expr
)
628 add_pure_binding name pure
629 pure_sp_code.VT0.combiner_rec_expression
630 (function expr
-> Ast0.ExprTag expr
)
633 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
634 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
636 if not
(checks_needed
) or not
(context_required
) or is_context expr
638 match (up
,Ast0.unwrap expr
) with
639 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
641 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
642 if mcode_equal consta constb
643 then check_mcode consta constb
645 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
646 conjunct_many_bindings
647 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
648 match_dots match_expr is_elist_matcher do_elist_match
650 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
651 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
652 if mcode_equal opa opb
654 conjunct_many_bindings
655 [check_mcode opa opb
; match_expr lefta leftb
;
656 match_expr righta rightb
]
658 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
659 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
660 conjunct_many_bindings
661 [check_mcode lp1 lp
; check_mcode rp1 rp
;
662 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
663 match_expr exp3a exp3b
]
664 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
665 if mcode_equal opa opb
667 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
669 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
670 if mcode_equal opa opb
672 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
674 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
675 if mcode_equal opa opb
677 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
679 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
680 if mcode_equal opa opb
682 conjunct_many_bindings
683 [check_mcode opa opb
; match_expr lefta leftb
;
684 match_expr righta rightb
]
686 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
687 conjunct_many_bindings
688 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
689 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
690 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
691 conjunct_many_bindings
692 [check_mcode lb1 lb
; check_mcode rb1 rb
;
693 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
694 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
695 Ast0.RecordAccess
(expb
,op
,fieldb
))
696 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
697 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
698 conjunct_many_bindings
699 [check_mcode opa op
; match_expr expa expb
;
700 match_ident fielda fieldb
]
701 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
702 conjunct_many_bindings
703 [check_mcode lp1 lp
; check_mcode rp1 rp
;
704 match_typeC tya tyb
; match_expr expa expb
]
705 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
706 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
707 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
708 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
709 conjunct_many_bindings
710 [check_mcode lp1 lp
; check_mcode rp1 rp
;
711 check_mcode szf1 szf
; match_typeC tya tyb
]
712 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
714 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
715 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
716 failwith
"not allowed in the pattern of an isomorphism"
717 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
718 failwith
"not allowed in the pattern of an isomorphism"
719 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
720 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
721 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
722 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
723 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
724 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
725 (* hope that mcode of edots is unique somehow *)
726 conjunct_bindings (check_mcode ed ed1
)
727 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
728 if edots_whencode_allowed
729 then add_dot_binding ed
(Ast0.ExprTag wc
)
732 "warning: not applying iso because of whencode";
734 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
735 | (Ast0.Estars
(_
,Some _
),_
) ->
736 failwith
"whencode not allowed in a pattern1"
737 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
738 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
739 | (_
,Ast0.OptExp
(expb
))
740 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
742 else return_false (ContextRequired
(Ast0.ExprTag expr
))
744 (* the special case for function types prevents the eg T X; -> T X = E; iso
745 from applying, which doesn't seem very relevant, but it also avoids a
746 mysterious bug that is obtained with eg int attach(...); *)
747 and match_typeC pattern t
=
748 match Ast0.unwrap pattern
with
749 Ast0.MetaType
(name
,pure
) ->
750 (match Ast0.unwrap t
with
751 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
753 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
754 (function ty
-> Ast0.TypeCTag ty
)
757 if not
(checks_needed
) or not
(context_required
) or is_context t
759 match (up
,Ast0.unwrap t
) with
760 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
761 if mcode_equal cva cvb
763 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
765 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
768 match_list check_mcode
769 (function _
-> false) (function _
-> failwith
"")
772 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
773 if mcode_equal signa signb
775 conjunct_bindings (check_mcode signa signb
)
776 (match_option match_typeC tya tyb
)
778 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
779 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
780 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
781 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
782 conjunct_many_bindings
783 [check_mcode stara starb
; check_mcode lp1a lp1b
;
784 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
785 check_mcode rp2a rp2b
; match_typeC tya tyb
;
786 match_dots match_param
is_plist_matcher
787 do_plist_match paramsa paramsb
]
788 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
789 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
790 conjunct_many_bindings
791 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
792 match_option match_typeC tya tyb
;
793 match_dots match_param
is_plist_matcher do_plist_match
795 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
796 conjunct_many_bindings
797 [check_mcode lb1 lb
; check_mcode rb1 rb
;
798 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
799 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
800 conjunct_bindings (check_mcode kinda kindb
)
801 (match_ident namea nameb
)
802 | (Ast0.StructUnionName
(kinda
,Some namea
),
803 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
804 if mcode_equal kinda kindb
806 conjunct_bindings (check_mcode kinda kindb
)
807 (match_ident namea nameb
)
809 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
810 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
811 conjunct_many_bindings
812 [check_mcode lb1 lb
; check_mcode rb1 rb
;
814 match_dots match_decl
no_list do_nolist_match declsa declsb
]
815 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
816 if mcode_equal namea nameb
817 then check_mcode namea nameb
819 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
820 failwith
"not allowed in the pattern of an isomorphism"
821 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
822 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
823 | (_
,Ast0.OptType
(tyb
))
824 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
826 else return_false (ContextRequired
(Ast0.TypeCTag t
))
828 and match_decl pattern d
=
829 if not
(checks_needed
) or not
(context_required
) or is_context d
831 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
832 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
833 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
834 if bool_match_option mcode_equal stga stgb
836 conjunct_many_bindings
837 [check_mcode eq1 eq
; check_mcode sc1 sc
;
838 match_option check_mcode stga stgb
;
839 match_typeC tya tyb
; match_ident ida idb
;
840 match_init inia inib
]
842 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
843 if bool_match_option mcode_equal stga stgb
845 conjunct_many_bindings
846 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
847 match_typeC tya tyb
; match_ident ida idb
]
849 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
850 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
851 conjunct_many_bindings
852 [match_ident namea nameb
;
853 check_mcode lp1 lp
; check_mcode rp1 rp
;
855 match_dots match_expr is_elist_matcher do_elist_match
857 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
858 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
859 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
860 conjunct_bindings (check_mcode sc1 sc
)
861 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
862 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
863 failwith
"not allowed in the pattern of an isomorphism"
864 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
865 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
866 conjunct_bindings (check_mcode dd d
)
867 (* hope that mcode of ddots is unique somehow *)
868 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
869 if ddots_whencode_allowed
870 then add_dot_binding dd
(Ast0.DeclTag wc
)
872 (Printf.printf
"warning: not applying iso because of whencode";
874 | (Ast0.Ddots
(_
,Some _
),_
) ->
875 failwith
"whencode not allowed in a pattern1"
877 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
878 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
879 match_decl decla declb
880 | (_
,Ast0.OptDecl
(declb
))
881 | (_
,Ast0.UniqueDecl
(declb
)) ->
882 match_decl pattern declb
884 else return_false (ContextRequired
(Ast0.DeclTag d
))
886 and match_init pattern i
=
887 match Ast0.unwrap pattern
with
888 Ast0.MetaInit
(name
,pure
) ->
889 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
890 (function ini
-> Ast0.InitTag ini
)
893 if not
(checks_needed
) or not
(context_required
) or is_context i
895 match (up
,Ast0.unwrap i
) with
896 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
898 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
900 conjunct_many_bindings
901 [check_mcode lb1 lb
; check_mcode rb1 rb
;
902 match_dots match_init
no_list do_nolist_match
904 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
905 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
906 conjunct_many_bindings
907 [match_list match_designator
908 (function _
-> false) (function _
-> failwith
"")
909 designators1 designators2
;
911 match_init inia inib
]
912 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
913 conjunct_many_bindings
914 [check_mcode c1 c
; match_ident namea nameb
;
915 match_init inia inib
]
916 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
917 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
918 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
919 conjunct_bindings (check_mcode id d
)
920 (* hope that mcode of edots is unique somehow *)
921 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
922 if idots_whencode_allowed
923 then add_dot_binding id
(Ast0.InitTag wc
)
926 "warning: not applying iso because of whencode";
928 | (Ast0.Idots
(_
,Some _
),_
) ->
929 failwith
"whencode not allowed in a pattern2"
930 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
931 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
932 | (_
,Ast0.OptIni
(ib
))
933 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
935 else return_false (ContextRequired
(Ast0.InitTag i
))
937 and match_designator pattern d
=
938 match (pattern
,d
) with
939 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
940 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
941 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
942 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
943 conjunct_many_bindings
944 [check_mcode lba lbb
; match_expr expa expb
;
946 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
947 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
948 conjunct_many_bindings
949 [check_mcode lba lbb
; match_expr mina minb
;
950 check_mcode dotsa dotsb
; match_expr maxa maxb
;
954 and match_param pattern p
=
955 match Ast0.unwrap pattern
with
956 Ast0.MetaParam
(name
,pure
) ->
957 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
958 (function p
-> Ast0.ParamTag p
)
960 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
962 if not
(checks_needed
) or not
(context_required
) or is_context p
964 match (up
,Ast0.unwrap p
) with
965 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
966 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
967 conjunct_bindings (match_typeC tya tyb
)
968 (match_option match_ident ida idb
)
969 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
970 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
971 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
972 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
973 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
974 match_param parama paramb
975 | (_
,Ast0.OptParam
(paramb
))
976 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
978 else return_false (ContextRequired
(Ast0.ParamTag p
))
980 and match_statement pattern s
=
981 match Ast0.unwrap pattern
with
982 Ast0.MetaStmt
(name
,pure
) ->
983 (match Ast0.unwrap s
with
984 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
985 return false (* ... is not a single statement *)
987 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
988 (function ty
-> Ast0.StmtTag ty
)
990 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
992 if not
(checks_needed
) or not
(context_required
) or is_context s
994 match (up
,Ast0.unwrap s
) with
995 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
996 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
997 conjunct_many_bindings
998 [check_mcode lp1 lp
; check_mcode rp1 rp
;
999 check_mcode lb1 lb
; check_mcode rb1 rb
;
1000 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
1001 match_dots match_param
is_plist_matcher do_plist_match
1003 match_dots match_statement
is_slist_matcher do_slist_match
1005 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
1006 match_decl decla declb
1007 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
1008 (* seqs can only match if they are all minus (plus code
1009 allowed) or all context (plus code not allowed in the body).
1010 we could be more permissive if the expansions of the isos are
1011 also all seqs, but this would be hard to check except at top
1012 level, and perhaps not worth checking even in that case.
1013 Overall, the issue is that braces are used where single
1014 statements are required, and something not satisfying these
1015 conditions can cause a single statement to become a
1016 non-single statement after the transformation.
1018 example: if { ... -foo(); ... }
1019 if we let the sequence convert to just -foo();
1020 then we produce invalid code. For some reason,
1021 single_statement can't deal with this case, perhaps because
1022 it starts introducing too many braces? don't remember the
1025 conjunct_bindings (check_mcode lb1 lb
)
1026 (conjunct_bindings (check_mcode rb1 rb
)
1027 (if not
(checks_needed
) or is_minus s
or
1029 List.for_all
is_pure_context (Ast0.undots bodyb
))
1031 match_dots match_statement
is_slist_matcher do_slist_match
1033 else return_false (Braces
(s
))))
1034 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1035 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1036 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1037 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1038 conjunct_many_bindings
1039 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1040 check_mcode rp1 rp2
;
1041 match_expr expa expb
;
1042 match_statement branch1a branch1b
]
1043 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1044 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1045 conjunct_many_bindings
1046 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1047 check_mcode rp1 rp2
; check_mcode e1 e2
;
1048 match_expr expa expb
;
1049 match_statement branch1a branch1b
;
1050 match_statement branch2a branch2b
]
1051 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1052 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1053 conjunct_many_bindings
1054 [check_mcode w1 w
; check_mcode lp1 lp
;
1055 check_mcode rp1 rp
; match_expr expa expb
;
1056 match_statement bodya bodyb
]
1057 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1058 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1059 conjunct_many_bindings
1060 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1061 check_mcode rp1 rp
; match_statement bodya bodyb
;
1062 match_expr expa expb
]
1063 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1064 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1065 conjunct_many_bindings
1066 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1067 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1068 match_option match_expr e1a e1b
;
1069 match_option match_expr e2a e2b
;
1070 match_option match_expr e3a e3b
;
1071 match_statement bodya bodyb
]
1072 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1073 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1074 conjunct_many_bindings
1075 [match_ident nma nmb
;
1076 check_mcode lp1 lp
; check_mcode rp1 rp
;
1077 match_dots match_expr is_elist_matcher do_elist_match
1079 match_statement bodya bodyb
]
1080 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1081 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1082 conjunct_many_bindings
1083 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1084 check_mcode lb1 lb
; check_mcode rb1 rb
;
1085 match_expr expa expb
;
1086 match_dots match_statement
is_slist_matcher do_slist_match
1088 match_dots match_case_line
no_list do_nolist_match
1090 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1091 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1092 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1093 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1094 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1095 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1096 conjunct_many_bindings
1097 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1098 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1099 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1100 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1101 conjunct_many_bindings
1102 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1103 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1104 failwith
"disj not supported in patterns"
1105 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1106 failwith
"nest not supported in patterns"
1107 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1108 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1109 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1110 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1111 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1112 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1113 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1114 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1116 [] -> check_mcode d d1
1118 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1119 if dots_whencode_allowed
1121 conjunct_bindings (check_mcode d d1
)
1125 | Ast0.WhenNot wc
->
1126 conjunct_bindings prev
1127 (add_multi_dot_binding d
1128 (Ast0.DotsStmtTag wc
))
1129 | Ast0.WhenAlways wc
->
1130 conjunct_bindings prev
1131 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1132 | Ast0.WhenNotTrue wc
->
1133 conjunct_bindings prev
1134 (add_multi_dot_binding d
1135 (Ast0.IsoWhenTTag wc
))
1136 | Ast0.WhenNotFalse wc
->
1137 conjunct_bindings prev
1138 (add_multi_dot_binding d
1139 (Ast0.IsoWhenFTag wc
))
1140 | Ast0.WhenModifier
(x) ->
1141 conjunct_bindings prev
1142 (add_multi_dot_binding d
1143 (Ast0.IsoWhenTag
x)))
1147 "warning: not applying iso because of whencode";
1149 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1150 | (Ast0.Stars
(_
,_
::_
),_
) ->
1151 failwith
"whencode not allowed in a pattern3"
1152 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1153 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1154 match_statement rea reb
1155 | (_
,Ast0.OptStm
(reb
))
1156 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1158 else return_false (ContextRequired
(Ast0.StmtTag s
))
1160 (* first should provide a subset of the information in the second *)
1161 and match_fninfo patterninfo cinfo
=
1162 let patterninfo = List.sort compare
patterninfo in
1163 let cinfo = List.sort compare
cinfo in
1164 let rec loop = function
1165 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1166 if mcode_equal sta stb
1167 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1169 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1170 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1171 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1172 if mcode_equal ia ib
1173 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1175 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1176 if mcode_equal ia ib
1177 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1179 | (x::resta
,((y
::_
) as restb
)) ->
1180 (match compare
x y
with
1182 | 1 -> loop (resta
,restb
)
1183 | _
-> failwith
"not possible")
1184 | _
-> return false in
1185 loop (patterninfo,cinfo)
1187 and match_case_line pattern c
=
1188 if not
(checks_needed
) or not
(context_required
) or is_context c
1190 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1191 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1192 conjunct_many_bindings
1193 [check_mcode d1 d
; check_mcode c1 c
;
1194 match_dots match_statement
is_slist_matcher do_slist_match
1196 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1197 conjunct_many_bindings
1198 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1199 match_dots match_statement
is_slist_matcher do_slist_match
1201 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1202 failwith
"not allowed in the pattern of an isomorphism"
1203 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1204 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1206 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1208 let match_statement_dots x y
=
1209 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1211 (match_expr, match_decl
, match_statement
, match_typeC
,
1212 match_statement_dots)
1214 let match_expr dochecks context_required whencode_allowed
=
1215 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1218 let match_decl dochecks context_required whencode_allowed
=
1219 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1222 let match_statement dochecks context_required whencode_allowed
=
1223 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1226 let match_typeC dochecks context_required whencode_allowed
=
1227 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1230 let match_statement_dots dochecks context_required whencode_allowed
=
1231 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1234 (* --------------------------------------------------------------------- *)
1235 (* make an entire tree MINUS *)
1238 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1240 match mcodekind
with
1243 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1244 | _
-> failwith
"make_minus: unexpected befaft")
1245 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1246 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1247 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1249 let update_mc mcodekind e
=
1250 match !mcodekind
with
1253 (Ast.NOTHING
,_
,_
) ->
1254 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1255 | _
-> failwith
"make_minus: unexpected befaft")
1256 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1257 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1258 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1260 let donothing r k e
=
1261 let mcodekind = Ast0.get_mcodekind_ref e
in
1262 let e = k
e in update_mc mcodekind e; e in
1264 (* special case for whencode, because it isn't processed by contextneg,
1265 since it doesn't appear in the + code *)
1266 (* cases for dots and nests *)
1267 let expression r k
e =
1268 let mcodekind = Ast0.get_mcodekind_ref
e in
1269 match Ast0.unwrap
e with
1270 Ast0.Edots
(d
,whencode
) ->
1271 (*don't recurse because whencode hasn't been processed by context_neg*)
1272 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1273 | Ast0.Ecircles
(d
,whencode
) ->
1274 (*don't recurse because whencode hasn't been processed by context_neg*)
1275 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1276 | Ast0.Estars
(d
,whencode
) ->
1277 (*don't recurse because whencode hasn't been processed by context_neg*)
1278 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1279 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1280 update_mc mcodekind e;
1282 (Ast0.NestExpr
(mcode starter
,
1283 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1284 mcode ender
,whencode
,multi
))
1285 | _
-> donothing r k
e in
1287 let declaration r k
e =
1288 let mcodekind = Ast0.get_mcodekind_ref
e in
1289 match Ast0.unwrap
e with
1290 Ast0.Ddots
(d
,whencode
) ->
1291 (*don't recurse because whencode hasn't been processed by context_neg*)
1292 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1293 | _
-> donothing r k
e in
1295 let statement r k
e =
1296 let mcodekind = Ast0.get_mcodekind_ref
e in
1297 match Ast0.unwrap
e with
1298 Ast0.Dots
(d
,whencode
) ->
1299 (*don't recurse because whencode hasn't been processed by context_neg*)
1300 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1301 | Ast0.Circles
(d
,whencode
) ->
1302 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1303 | Ast0.Stars
(d
,whencode
) ->
1304 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1305 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1306 update_mc mcodekind e;
1309 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1310 mcode ender
,whencode
,multi
))
1311 | _
-> donothing r k
e in
1313 let initialiser r k
e =
1314 let mcodekind = Ast0.get_mcodekind_ref
e in
1315 match Ast0.unwrap
e with
1316 Ast0.Idots
(d
,whencode
) ->
1317 (*don't recurse because whencode hasn't been processed by context_neg*)
1318 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1319 | _
-> donothing r k
e in
1322 let info = Ast0.get_info
e in
1323 let mcodekind = Ast0.get_mcodekind_ref
e in
1324 match Ast0.unwrap
e with
1326 (* if context is - this should be - as well. There are no tokens
1327 here though, so the bottom-up minusifier in context_neg leaves it
1328 as mixed (or context for sgrep2). It would be better to fix
1329 context_neg, but that would
1330 require a special case for each term with a dots subterm. *)
1331 (match !mcodekind with
1332 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1334 (Ast.NOTHING
,_
,_
) ->
1335 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1337 | _
-> failwith
"make_minus: unexpected befaft")
1338 (* code already processed by an enclosing iso *)
1339 | Ast0.MINUS
(mc
) -> e
1343 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1344 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1345 | _
-> donothing r k
e in
1348 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1349 dots dots dots dots dots dots
1350 donothing expression donothing initialiser donothing declaration
1351 statement donothing donothing
1353 (* --------------------------------------------------------------------- *)
1354 (* rebuild mcode cells in an instantiated alt *)
1356 (* mcodes will be side effected later with plus code, so we have to copy
1357 them on instantiating an isomorphism. One could wonder whether it would
1358 be better not to use side-effects, but they are convenient for insert_plus
1359 where is it useful to manipulate a list of the mcodes but side-effect a
1361 (* hmm... Insert_plus is called before Iso_pattern... *)
1362 let rebuild_mcode start_line
=
1363 let copy_mcodekind = function
1364 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1365 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1366 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1367 | Ast0.PLUS count
->
1368 (* this function is used elsewhere where we need to rebuild the
1369 indices, and so we allow PLUS code as well *)
1372 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1374 match start_line
with
1377 {info.Ast0.pos_info
with
1378 Ast0.line_start
= x;
1379 Ast0.line_end
= x; } in
1380 {info with Ast0.pos_info
= new_pos_info}
1382 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1385 let old_info = Ast0.get_info
x in
1387 match start_line
with
1390 {old_info.Ast0.pos_info
with
1391 Ast0.line_start
= x;
1392 Ast0.line_end
= x; } in
1393 {old_info with Ast0.pos_info
= new_pos_info}
1394 | None
-> old_info in
1395 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1396 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1398 let donothing r k
e = copy_one (k
e) in
1400 (* case for control operators (if, etc) *)
1401 let statement r k
e =
1406 (match Ast0.unwrap
s with
1407 Ast0.Decl
((info,mc
),decl
) ->
1408 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1409 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1410 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1411 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1412 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1413 (info,copy_mcodekind mc
))
1414 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1415 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1416 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1417 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1418 (info,copy_mcodekind mc
))
1419 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1420 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1422 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1424 ((info,copy_mcodekind mc
),
1425 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1427 Ast0.set_dots_bef_aft
res
1428 (match Ast0.get_dots_bef_aft
res with
1429 Ast0.NoDots
-> Ast0.NoDots
1430 | Ast0.AddingBetweenDots
s ->
1431 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1432 | Ast0.DroppingBetweenDots
s ->
1433 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1436 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1437 donothing donothing donothing donothing donothing donothing
1438 donothing donothing donothing donothing donothing
1439 donothing statement donothing donothing
1441 (* --------------------------------------------------------------------- *)
1442 (* The problem of whencode. If an isomorphism contains dots in multiple
1443 rules, then the code that is matched cannot contain whencode, because we
1444 won't know which dots it goes with. Should worry about nests, but they
1445 aren't allowed in isomorphisms for the moment. *)
1448 let option_default = 0 in
1449 let bind x y
= x + y
in
1451 match Ast0.unwrap
e with
1452 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1455 V0.combiner
bind option_default
1456 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1459 let option_default = 0 in
1460 let bind x y
= x + y
in
1462 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1464 V0.combiner
bind option_default
1465 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1468 let option_default = 0 in
1469 let bind x y
= x + y
in
1471 match Ast0.unwrap
e with
1472 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1475 V0.combiner
bind option_default
1476 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1478 (* --------------------------------------------------------------------- *)
1480 let lookup name bindings mv_bindings
=
1481 try Common.Left
(List.assoc
(term name
) bindings
)
1484 (* failure is not possible anymore *)
1485 Common.Right
(List.assoc
(term name
) mv_bindings
)
1487 (* mv_bindings is for the fresh metavariables that are introduced by the
1489 let instantiate bindings mv_bindings
=
1491 match Ast0.get_pos
x with
1492 Ast0.MetaPos
(name
,_
,_
) ->
1494 match lookup name bindings mv_bindings
with
1495 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1496 | _
-> failwith
"not possible"
1497 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1499 let donothing r k
e = k
e in
1501 (* cases where metavariables can occur *)
1504 match Ast0.unwrap
e with
1505 Ast0.MetaId
(name
,constraints
,pure
) ->
1506 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1507 (match lookup name bindings mv_bindings
with
1508 Common.Left
(Ast0.IdentTag
(id
)) -> id
1509 | Common.Left
(_
) -> failwith
"not possible 1"
1510 | Common.Right
(new_mv
) ->
1513 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1514 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1515 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1518 (* case for list metavariables *)
1519 let rec elist r same_dots
= function
1522 (match Ast0.unwrap
x with
1523 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1524 failwith
"meta_expr_list in iso not supported"
1525 (*match lookup name bindings mv_bindings with
1526 Common.Left(Ast0.DotsExprTag(exp)) ->
1527 (match same_dots exp with
1529 | None -> failwith "dots put in incompatible context")
1530 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1531 | Common.Left(_) -> failwith "not possible 1"
1532 | Common.Right(new_mv) ->
1533 failwith "MetaExprList in SP not supported"*)
1534 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1535 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1537 let rec plist r same_dots
= function
1540 (match Ast0.unwrap
x with
1541 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1542 failwith
"meta_param_list in iso not supported"
1543 (*match lookup name bindings mv_bindings with
1544 Common.Left(Ast0.DotsParamTag(param)) ->
1545 (match same_dots param with
1547 | None -> failwith "dots put in incompatible context")
1548 | Common.Left(Ast0.ParamTag(param)) -> [param]
1549 | Common.Left(_) -> failwith "not possible 1"
1550 | Common.Right(new_mv) ->
1551 failwith "MetaExprList in SP not supported"*)
1552 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1553 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1555 let rec slist r same_dots
= function
1558 (match Ast0.unwrap
x with
1559 Ast0.MetaStmtList
(name
,pure
) ->
1560 (match lookup name bindings mv_bindings
with
1561 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1562 (match same_dots stm
with
1564 | None
-> failwith
"dots put in incompatible context")
1565 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1566 | Common.Left
(_
) -> failwith
"not possible 1"
1567 | Common.Right
(new_mv
) ->
1568 failwith
"MetaExprList in SP not supported")
1569 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1570 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1573 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1574 let same_circles d
=
1575 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1577 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1579 let dots list_fn r k d
=
1581 (match Ast0.unwrap d
with
1582 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1583 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1584 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1586 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1589 match Ast0.unwrap
e with
1590 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1591 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1592 (match lookup name bindings mv_bindings
with
1593 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1594 | Common.Left
(_
) -> failwith
"not possible 1"
1595 | Common.Right
(new_mv
) ->
1600 let rec renamer = function
1601 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1603 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1605 Common.Left
(Ast0.TypeCTag
(t
)) ->
1606 Ast0.ast0_type_to_type t
1608 failwith
"iso pattern: unexpected type"
1609 | Common.Right
(new_mv
) ->
1610 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1611 | Type_cocci.ConstVol
(cv
,ty
) ->
1612 Type_cocci.ConstVol
(cv
,renamer ty
)
1613 | Type_cocci.Pointer
(ty
) ->
1614 Type_cocci.Pointer
(renamer ty
)
1615 | Type_cocci.FunctionPointer
(ty
) ->
1616 Type_cocci.FunctionPointer
(renamer ty
)
1617 | Type_cocci.Array
(ty
) ->
1618 Type_cocci.Array
(renamer ty
)
1620 Some
(List.map
renamer types
) in
1623 (Ast0.set_mcode_data new_mv name
,constraints
,
1624 new_types,form
,pure
)))
1625 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1626 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1627 failwith
"metaexprlist not supported"
1628 | Ast0.Unary
(exp
,unop
) ->
1629 (match Ast0.unwrap_mcode unop
with
1630 (* propagate negation only when the propagated and the encountered
1631 negation have the same transformation, when there is nothing
1632 added to the original one, and when there is nothing added to
1633 the expression into which we are doing the propagation. This
1634 may be too conservative. *)
1637 (* k e doesn't change the outer structure of the term,
1638 only the metavars *)
1639 match Ast0.unwrap old_e
with
1640 Ast0.Unary
(exp
,_
) ->
1641 (match Ast0.unwrap exp
with
1642 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1644 | _
-> failwith
"not possible" in
1645 let nomodif = function
1650 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1652 (Ast.NOTHING
,_
,_
) -> true
1654 | _
-> failwith
"plus not possible" in
1655 let same_modif newop oldop
=
1656 (* only propagate ! is they have the same modification
1657 and no + code on the old one (the new one from the iso
1658 surely has no + code) *)
1659 match (newop
,oldop
) with
1660 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1661 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1662 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1667 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1668 (* k accumulates parens, to keep negation outside if no
1669 propagation is possible *)
1670 if nomodif (Ast0.get_mcodekind
e)
1672 match Ast0.unwrap
res with
1673 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1675 (Ast0.get_mcode_mcodekind unop
)
1676 (Ast0.get_mcode_mcodekind op
) ->
1678 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1679 | Ast0.Paren
(lp
,e1,rp
) ->
1682 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1683 | Ast0.Binary
(e1,op
,e2
) when
1685 (Ast0.get_mcode_mcodekind unop
)
1686 (Ast0.get_mcode_mcodekind op
) ->
1688 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1689 let k1 x = k
(Ast0.rewrap
e x) in
1690 (match Ast0.unwrap_mcode op
with
1691 Ast.Logical
(Ast.Inf
) ->
1692 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1693 | Ast.Logical
(Ast.Sup
) ->
1694 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1695 | Ast.Logical
(Ast.InfEq
) ->
1696 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1697 | Ast.Logical
(Ast.SupEq
) ->
1698 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1699 | Ast.Logical
(Ast.Eq
) ->
1700 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1701 | Ast.Logical
(Ast.NotEq
) ->
1702 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1703 | Ast.Logical
(Ast.AndLog
) ->
1704 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1706 negate_reb
e e2
idcont))
1707 | Ast.Logical
(Ast.OrLog
) ->
1708 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1710 negate_reb
e e2
idcont))
1714 Ast0.rewrap_mcode op
Ast.Not
)))
1715 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1716 (* use res because it is the transformed argument *)
1718 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1719 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1721 (*use e, because this might be the toplevel expression*)
1723 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1726 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1727 and negate_reb
e e1 k
=
1728 (* used when ! is propagated to multiple places, to avoid
1729 duplicating mcode cells *)
1731 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1732 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1737 | Ast0.Edots
(d
,_
) ->
1739 (match List.assoc
(dot_term d
) bindings
with
1740 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1741 | _
-> failwith
"unexpected binding")
1742 with Not_found
-> e)
1743 | Ast0.Ecircles
(d
,_
) ->
1745 (match List.assoc
(dot_term d
) bindings
with
1746 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1747 | _
-> failwith
"unexpected binding")
1748 with Not_found
-> e)
1749 | Ast0.Estars
(d
,_
) ->
1751 (match List.assoc
(dot_term d
) bindings
with
1752 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1753 | _
-> failwith
"unexpected binding")
1754 with Not_found
-> e)
1756 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1760 match Ast0.unwrap
e with
1761 Ast0.MetaType
(name
,pure
) ->
1762 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1763 (match lookup name bindings mv_bindings
with
1764 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1765 | Common.Left
(_
) -> failwith
"not possible 1"
1766 | Common.Right
(new_mv
) ->
1768 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1773 match Ast0.unwrap
e with
1774 Ast0.MetaInit
(name
,pure
) ->
1775 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1776 (match lookup name bindings mv_bindings
with
1777 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1778 | Common.Left
(_
) -> failwith
"not possible 1"
1779 | Common.Right
(new_mv
) ->
1781 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1786 match Ast0.unwrap
e with
1789 (match List.assoc
(dot_term d
) bindings
with
1790 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1791 | _
-> failwith
"unexpected binding")
1792 with Not_found
-> e)
1797 match Ast0.unwrap
e with
1798 Ast0.MetaParam
(name
,pure
) ->
1799 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1800 (match lookup name bindings mv_bindings
with
1801 Common.Left
(Ast0.ParamTag
(param)) -> param
1802 | Common.Left
(_
) -> failwith
"not possible 1"
1803 | Common.Right
(new_mv
) ->
1805 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1806 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1807 failwith
"metaparamlist not supported"
1812 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1813 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1814 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1815 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1816 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1817 | _
-> failwith
"unexpected binding" in
1821 match Ast0.unwrap
e with
1822 Ast0.MetaStmt
(name
,pure
) ->
1823 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1824 (match lookup name bindings mv_bindings
with
1825 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1826 | Common.Left
(_
) -> failwith
"not possible 1"
1827 | Common.Right
(new_mv
) ->
1829 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1830 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1836 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1837 | Ast0.Circles
(d
,_
) ->
1842 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1843 | Ast0.Stars
(d
,_
) ->
1848 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1852 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1853 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1854 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1856 (* --------------------------------------------------------------------- *)
1859 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1861 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1863 let disj_fail bindings
e =
1865 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1868 (* isomorphism code is by default CONTEXT *)
1869 let merge_plus model_mcode e_mcode
=
1870 match model_mcode
with
1872 (* add the replacement information at the root *)
1876 (match (!mc
,!emc
) with
1877 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1878 | _
-> failwith
"how can we combine minuses?")
1879 | _
-> failwith
"not possible 6")
1880 | Ast0.CONTEXT
(mc
) ->
1882 Ast0.CONTEXT
(emc
) ->
1883 (* keep the logical line info as in the model *)
1884 let (mba
,tb
,ta
) = !mc
in
1885 let (eba
,_
,_
) = !emc
in
1886 (* merging may be required when a term is replaced by a subterm *)
1888 match (mba
,eba
) with
1889 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1890 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1891 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1892 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1893 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1894 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1895 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1896 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1897 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1898 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1899 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1900 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1901 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1902 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1903 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1904 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1905 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1906 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1907 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1908 emc
:= (merged,tb
,ta
)
1909 | Ast0.MINUS
(emc
) ->
1910 let (anything_bef_aft
,_
,_
) = !mc
in
1911 let (anythings
,t
) = !emc
in
1913 (match anything_bef_aft
with
1914 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1915 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1916 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1917 | Ast.NOTHING
-> (anythings
,t
))
1918 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1919 | _
-> failwith
"not possible 7")
1920 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1921 | Ast0.PLUS _
-> failwith
"not possible 9"
1923 let copy_plus printer minusify model
e =
1924 if !Flag.sgrep_mode2
1925 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1929 match Ast0.get_mcodekind model
with
1930 Ast0.MINUS
(mc
) -> minusify
e
1931 | Ast0.CONTEXT
(mc
) -> e
1932 | _
-> failwith
"not possible: copy_plus\n" in
1933 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1937 let copy_minus printer minusify model
e =
1938 match Ast0.get_mcodekind model
with
1939 Ast0.MINUS
(mc
) -> minusify
e
1940 | Ast0.CONTEXT
(mc
) -> e
1942 if !Flag.sgrep_mode2
1944 else failwith
"not possible 8"
1945 | Ast0.PLUS _
-> failwith
"not possible 9"
1947 let whencode_allowed prev_ecount prev_icount prev_dcount
1948 ecount icount dcount rest
=
1949 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1951 let other_ecount = (* number of edots *)
1952 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1954 let other_icount = (* number of dots *)
1955 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1957 let other_dcount = (* number of dots *)
1958 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1960 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1961 dcount
= 0 or other_dcount = 0)
1963 (* copy the befores and afters to the instantiated code *)
1964 let extra_copy_stmt_plus model
e =
1965 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1967 (match Ast0.unwrap model
with
1968 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1969 | Ast0.Decl
((info,bef
),_
) ->
1970 (match Ast0.unwrap
e with
1971 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1972 | Ast0.Decl
((info,bef1
),_
) ->
1974 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1975 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1976 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1977 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1978 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1979 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1980 (match Ast0.unwrap
e with
1981 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1982 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1983 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1984 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1985 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1987 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1991 let extra_copy_other_plus model
e = e
1993 (* --------------------------------------------------------------------- *)
1995 let mv_count = ref 0
1997 let ct = !mv_count in
1998 mv_count := !mv_count + 1;
1999 "_"^
s^
"_"^
(string_of_int
ct)
2001 let get_name = function
2002 Ast.MetaIdDecl
(ar
,nm) ->
2003 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2004 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2005 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2006 | Ast.MetaTypeDecl
(ar
,nm) ->
2007 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2008 | Ast.MetaInitDecl
(ar
,nm) ->
2009 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2010 | Ast.MetaListlenDecl
(nm) ->
2011 failwith
"should not be rebuilt"
2012 | Ast.MetaParamDecl
(ar
,nm) ->
2013 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2014 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2015 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2016 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2017 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2018 | Ast.MetaErrDecl
(ar
,nm) ->
2019 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2020 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2021 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2022 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2023 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2024 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2025 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2026 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2027 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2028 | Ast.MetaStmDecl
(ar
,nm) ->
2029 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2030 | Ast.MetaStmListDecl
(ar
,nm) ->
2031 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2032 | Ast.MetaFuncDecl
(ar
,nm) ->
2033 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2034 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2035 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2036 | Ast.MetaPosDecl
(ar
,nm) ->
2037 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2038 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2039 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2040 | Ast.MetaIteratorDecl
(ar
,nm) ->
2041 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2043 let make_new_metavars metavars bindings
=
2047 let (s,_
) = get_name mv
in
2048 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2053 let (s,rebuild
) = get_name mv
in
2054 let new_s = (!current_rule,new_mv s) in
2055 (rebuild
new_s, (s,new_s)))
2058 (* --------------------------------------------------------------------- *)
2060 let do_nothing x = x
2062 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2063 rebuild_mcodes name printer extra_plus update_others has_context
=
2064 let call_instantiate bindings mv_bindings alts has_context
=
2067 (function (a
,_,_,_) ->
2069 (* no need to create duplicates when the bindings have no effect *)
2071 (function bindings
->
2073 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2075 if has_context
(* ie if pat is not just a metavara *)
2077 copy_plus printer minusify
e (extra_plus
e instantiated)
2078 else instantiated in
2079 Ast0.set_iso
plus_added
2080 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2083 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2084 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2085 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2087 whencode_allowed prev_ecount prev_icount prev_dcount
2088 ecount dcount icount rest
in
2089 (match matcher
true (context_required e) wc pattern
e init_env with
2091 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2094 (match matcher
false false wc pattern
e init_env with
2096 interpret_reason name
(Ast0.get_line
e) reason
2097 (function () -> printer
e)
2099 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2100 (prev_dcount
+ dcount
) rest
2101 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2103 (* apply update_others to all patterns other than the matched
2104 one. This is used to desigate the others as test
2105 expressions in the TestExpression case *)
2107 (function (x,e,i
,d
) as all
->
2110 else (update_others
x,e,i
,d
))
2111 (List.hd
all_alts)) ::
2113 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2114 (List.tl
all_alts)) in
2115 (match List.concat
all_alts with
2116 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2118 let (new_metavars,mv_bindings
) =
2119 make_new_metavars metavars
(nub(List.concat bindings
)) in
2122 call_instantiate bindings mv_bindings
all_alts
2123 (has_context pattern
)))) in
2124 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2125 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2126 | (alts
::rest
) as all_alts ->
2127 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2128 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2129 outer_loop prev_ecount prev_icount prev_dcount rest
2130 | Common.Right
(new_metavars,res) ->
2132 copy_minus printer minusify
e (disj_maker
res)) in
2133 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2134 (count
, metavars
, e)
2136 (* no one should ever look at the information stored in these mcodes *)
2137 let disj_starter lst
=
2138 let old_info = Ast0.get_info
(List.hd lst
) in
2140 { old_info.Ast0.pos_info
with
2141 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2142 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2144 { Ast0.pos_info
= new_pos_info;
2145 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2146 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2147 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2148 Ast0.make_mcode_info
"(" info
2150 let disj_ender lst
=
2151 let old_info = Ast0.get_info
(List.hd lst
) in
2153 { old_info.Ast0.pos_info
with
2154 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2155 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2157 { Ast0.pos_info
= new_pos_info;
2158 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2159 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2160 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2161 Ast0.make_mcode_info
")" info
2163 let disj_mid _ = Ast0.make_mcode
"|"
2165 let make_disj_type tl
=
2168 [] -> failwith
"bad disjunction"
2169 | x::xs
-> List.map
disj_mid xs
in
2170 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2171 let make_disj_stmt_list tl
=
2174 [] -> failwith
"bad disjunction"
2175 | x::xs
-> List.map
disj_mid xs
in
2176 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2177 let make_disj_expr model el
=
2180 [] -> failwith
"bad disjunction"
2181 | x::xs
-> List.map
disj_mid xs
in
2183 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2185 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2186 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2187 let el = List.map
update_arg (List.map
update_test el) in
2188 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2189 let make_disj_decl dl
=
2192 [] -> failwith
"bad disjunction"
2193 | x::xs
-> List.map
disj_mid xs
in
2194 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2195 let make_disj_stmt sl
=
2196 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2199 [] -> failwith
"bad disjunction"
2200 | x::xs
-> List.map
disj_mid xs
in
2202 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2204 let transform_type (metavars
,alts
,name
) e =
2206 (Ast0.TypeCTag
(_)::_)::_ ->
2207 (* start line is given to any leaves in the iso code *)
2209 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2215 (p
,count_edots.VT0.combiner_rec_typeC p
,
2216 count_idots.VT0.combiner_rec_typeC p
,
2217 count_dots.VT0.combiner_rec_typeC p
)
2218 | _ -> failwith
"invalid alt"))
2220 mkdisj match_typeC metavars
alts e
2221 (function b
-> function mv_b
->
2222 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2223 (function t
-> Ast0.TypeCTag t
)
2224 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2225 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2226 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2228 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2232 let transform_expr (metavars
,alts,name
) e =
2233 let process update_others
=
2234 (* start line is given to any leaves in the iso code *)
2236 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2241 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2242 (p
,count_edots.VT0.combiner_rec_expression p
,
2243 count_idots.VT0.combiner_rec_expression p
,
2244 count_dots.VT0.combiner_rec_expression p
)
2245 | _ -> failwith
"invalid alt"))
2247 mkdisj match_expr metavars
alts e
2248 (function b
-> function mv_b
->
2249 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2250 (function e -> Ast0.ExprTag
e)
2252 make_minus.VT0.rebuilder_rec_expression
2253 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2254 name
Unparse_ast0.expression extra_copy_other_plus update_others
2256 match Ast0.unwrap
x with
2257 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2261 (Ast0.ExprTag
(_)::r
)::rs
->
2262 (* hack to accomodate ToTestExpression case, where the first pattern is
2263 a normal expression, but the others are test expressions *)
2264 let others = r
@ (List.concat rs
) in
2265 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2266 if List.for_all
is_test others then process Ast0.set_test_exp
2267 else if List.exists
is_test others then failwith
"inconsistent iso"
2268 else process do_nothing
2269 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2270 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2271 process Ast0.set_test_exp
2274 let transform_decl (metavars
,alts,name
) e =
2276 (Ast0.DeclTag
(_)::_)::_ ->
2277 (* start line is given to any leaves in the iso code *)
2279 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2285 (p
,count_edots.VT0.combiner_rec_declaration p
,
2286 count_idots.VT0.combiner_rec_declaration p
,
2287 count_dots.VT0.combiner_rec_declaration p
)
2288 | _ -> failwith
"invalid alt"))
2290 mkdisj match_decl metavars
alts e
2291 (function b
-> function mv_b
->
2292 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2293 (function d
-> Ast0.DeclTag d
)
2295 make_minus.VT0.rebuilder_rec_declaration
2296 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2297 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2298 (function _ -> true (* no metavars *))
2301 let transform_stmt (metavars
,alts,name
) e =
2303 (Ast0.StmtTag
(_)::_)::_ ->
2304 (* start line is given to any leaves in the iso code *)
2306 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2312 (p
,count_edots.VT0.combiner_rec_statement p
,
2313 count_idots.VT0.combiner_rec_statement p
,
2314 count_dots.VT0.combiner_rec_statement p
)
2315 | _ -> failwith
"invalid alt"))
2317 mkdisj match_statement metavars
alts e
2318 (function b
-> function mv_b
->
2319 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2320 (function s -> Ast0.StmtTag
s)
2321 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2322 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2323 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2325 match Ast0.unwrap
x with
2326 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2330 (* sort of a hack, because there is no disj at top level *)
2331 let transform_top (metavars
,alts,name
) e =
2332 match Ast0.unwrap
e with
2333 Ast0.DECL
(declstm
) ->
2339 Ast0.DotsStmtTag
(d
) ->
2340 (match Ast0.unwrap d
with
2341 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2342 | _ -> raise
(Failure
""))
2343 | _ -> raise
(Failure
"")))
2345 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2346 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2347 with Failure
_ -> (0,[],e))
2348 | Ast0.CODE
(stmts
) ->
2349 let (count
,mv
,res) =
2351 (Ast0.DotsStmtTag
(_)::_)::_ ->
2352 (* start line is given to any leaves in the iso code *)
2354 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2359 Ast0.DotsStmtTag
(p
) ->
2360 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2361 count_idots.VT0.combiner_rec_statement_dots p
,
2362 count_dots.VT0.combiner_rec_statement_dots p
)
2363 | _ -> failwith
"invalid alt"))
2365 mkdisj match_statement_dots metavars
alts stmts
2366 (function b
-> function mv_b
->
2367 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2368 (function s -> Ast0.DotsStmtTag
s)
2370 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2372 make_minus.VT0.rebuilder_rec_statement_dots
x)
2373 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2374 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2375 (function _ -> true)
2376 | _ -> (0,[],stmts
) in
2377 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2380 (* --------------------------------------------------------------------- *)
2382 let transform (alts : isomorphism
) t
=
2383 (* the following ugliness is because rebuilder only returns a new term *)
2384 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2385 let in_limit n
= function
2389 ((if !Flag_parsing_cocci.show_iso_failures
2390 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2392 let bind x y
= x + y
in
2393 let option_default = 0 in
2395 let (e_count
,e) = k
e in
2396 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2398 let (count
,extra_meta
,exp
) = transform_expr alts e in
2399 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2400 (bind count e_count
,exp
)
2404 let (e_count
,e) = k
e in
2405 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2407 let (count
,extra_meta
,dec
) = transform_decl alts e in
2408 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2409 (bind count e_count
,dec
)
2413 let (e_count
,e) = k
e in
2414 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2416 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2417 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2418 (bind count e_count
,stm
)
2422 let (continue
,e_count
,e) =
2423 match Ast0.unwrap
e with
2424 Ast0.Signed
(signb
,tyb
) ->
2425 (* Hack! How else to prevent iso from applying under an
2429 let (e_count
,e) = k
e in
2430 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2431 then (true,e_count
,e)
2432 else (false,e_count
,e) in
2435 let (count
,extra_meta
,ty
) = transform_type alts e in
2436 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2437 (bind count e_count
,ty
)
2441 let (e_count
,e) = k
e in
2442 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2444 let (count
,extra_meta
,ty
) = transform_top alts e in
2445 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2446 (bind count e_count
,ty
)
2450 V0.combiner_rebuilder
bind option_default
2451 {V0.combiner_rebuilder_functions
with
2452 VT0.combiner_rebuilder_exprfn
= exprfn;
2453 VT0.combiner_rebuilder_tyfn
= typefn;
2454 VT0.combiner_rebuilder_declfn
= declfn;
2455 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2456 VT0.combiner_rebuilder_topfn
= topfn} in
2457 let (_,res) = res.VT0.top_level t
in
2458 (!extra_meta_decls,res)
2460 (* --------------------------------------------------------------------- *)
2462 (* should be done by functorizing the parser to use wrap or context_wrap *)
2464 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2465 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2467 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2468 donothing donothing donothing donothing donothing donothing
2469 donothing donothing donothing donothing donothing donothing donothing
2472 let rewrap_anything = function
2473 Ast0.DotsExprTag
(d
) ->
2474 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2475 | Ast0.DotsInitTag
(d
) ->
2476 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2477 | Ast0.DotsParamTag
(d
) ->
2478 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2479 | Ast0.DotsStmtTag
(d
) ->
2480 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2481 | Ast0.DotsDeclTag
(d
) ->
2482 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2483 | Ast0.DotsCaseTag
(d
) ->
2484 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2485 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2486 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2487 | Ast0.ArgExprTag
(d
) ->
2488 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2489 | Ast0.TestExprTag
(d
) ->
2490 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2491 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2492 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2493 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2494 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2495 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2496 | Ast0.CaseLineTag
(d
) ->
2497 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2498 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2499 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2500 failwith
"only for isos within iso phase"
2501 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2503 (* --------------------------------------------------------------------- *)
2505 let apply_isos isos rule rule_name
=
2510 current_rule := rule_name
;
2513 (function (metavars
,iso
,name
) ->
2514 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2516 let (extra_meta
,rule
) =
2521 (function (extra_meta
,t
) -> function iso
->
2522 let (new_extra_meta
,t
) = transform iso t
in
2523 (new_extra_meta
@extra_meta
,t
))
2526 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)
HCoop / bpt / coccinelle.git / blob