2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* Potential problem: offset of mcode is not updated when an iso is
26 instantiated, implying that a term may end up with many mcodes with the
27 same offset. On the other hand, at the moment offset only seems to be used
28 before this phase. Furthermore add_dot_binding relies on the offset to
29 remain the same between matching an iso and instantiating it with bindings. *)
31 (* Consider whether ... in iso should match <... ...> in smpl? *)
33 (* --------------------------------------------------------------------- *)
34 (* match a SmPL expression against a SmPL abstract syntax tree,
37 module Ast
= Ast_cocci
38 module Ast0
= Ast0_cocci
39 module V0
= Visitor_ast0
40 module VT0
= Visitor_ast0_types
42 let current_rule = ref ""
44 (* --------------------------------------------------------------------- *)
47 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
50 let mcode (term
,_
,_
,_
,_
,_
) =
51 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
52 ref Ast0.NoMetaPos
,-1) in
55 {(Ast0.wrap
(Ast0.unwrap
x)) with
56 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
57 Ast0.true_if_test
= x.Ast0.true_if_test
} in
59 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
60 donothing donothing donothing donothing donothing donothing
61 donothing donothing donothing donothing donothing donothing donothing
64 let anything_equal = function
65 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
66 failwith
"not a possible variable binding" (*not sure why these are pbs*)
67 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
68 failwith
"not a possible variable binding"
69 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
70 failwith
"not a possible variable binding"
71 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
72 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
73 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
74 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
75 failwith
"not a possible variable binding"
76 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
77 failwith
"not a possible variable binding"
78 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
79 (strip_info.VT0.rebuilder_rec_ident d1
) =
80 (strip_info.VT0.rebuilder_rec_ident d2
)
81 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
82 (strip_info.VT0.rebuilder_rec_expression d1
) =
83 (strip_info.VT0.rebuilder_rec_expression d2
)
84 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
85 failwith
"not possible - only in isos1"
86 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
87 failwith
"not possible - only in isos1"
88 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
89 (strip_info.VT0.rebuilder_rec_typeC d1
) =
90 (strip_info.VT0.rebuilder_rec_typeC d2
)
91 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
92 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
93 (strip_info.VT0.rebuilder_rec_initialiser d2
)
94 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
95 (strip_info.VT0.rebuilder_rec_parameter d1
) =
96 (strip_info.VT0.rebuilder_rec_parameter d2
)
97 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
98 (strip_info.VT0.rebuilder_rec_declaration d1
) =
99 (strip_info.VT0.rebuilder_rec_declaration d2
)
100 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
101 (strip_info.VT0.rebuilder_rec_statement d1
) =
102 (strip_info.VT0.rebuilder_rec_statement d2
)
103 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
104 (strip_info.VT0.rebuilder_rec_case_line d1
) =
105 (strip_info.VT0.rebuilder_rec_case_line d2
)
106 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
107 (strip_info.VT0.rebuilder_rec_top_level d1
) =
108 (strip_info.VT0.rebuilder_rec_top_level d2
)
109 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
110 failwith
"only for isos within iso phase"
111 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
112 failwith
"only for isos within iso phase"
113 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
114 failwith
"only for isos within iso phase"
117 let term (var1
,_
,_
,_
,_
,_
) = var1
118 let dot_term (var1
,_
,info
,_
,_
,_
) =
119 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
123 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
124 | NotPureLength
of Ast.meta_name
125 | ContextRequired
of Ast0.anything
127 | Braces
of Ast0.statement
128 | Position
of Ast.meta_name
129 | TypeMatch
of reason list
131 let rec interpret_reason name line reason printer
=
133 "warning: iso %s does not match the code below on line %d\n" name line
;
134 printer
(); Format.print_newline
();
136 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
138 "pure metavariable %s is matched against the following nonpure code:\n"
140 Unparse_ast0.unparse_anything nonpure
141 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
143 "context metavariable %s is matched against the following\nnoncontext code:\n"
145 Unparse_ast0.unparse_anything nonpure
146 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
148 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
150 Unparse_ast0.unparse_anything nonpure
151 | NotPureLength
((_
,var
)) ->
153 "pure metavariable %s is matched against too much or too little code\n"
155 | ContextRequired
(term) ->
157 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
158 Unparse_ast0.unparse_anything
term
160 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
161 Unparse_ast0.statement
"" s
;
162 Format.print_newline
()
163 | Position
(rule
,name
) ->
164 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
166 | TypeMatch reason_list
->
167 List.iter
(function r
-> interpret_reason name line r printer
)
169 | _
-> failwith
"not possible"
171 type 'a either
= OK
of 'a
| Fail
of reason
173 let add_binding var exp bindings
=
174 let var = term var in
175 let attempt bindings
=
177 let cur = List.assoc
var bindings
in
178 if anything_equal(exp
,cur) then [bindings
] else []
179 with Not_found
-> [((var,exp
)::bindings
)] in
180 match List.concat
(List.map
attempt bindings
) with
184 let add_dot_binding var exp bindings
=
185 let var = dot_term var in
186 let attempt bindings
=
188 let cur = List.assoc
var bindings
in
189 if anything_equal(exp
,cur) then [bindings
] else []
190 with Not_found
-> [((var,exp
)::bindings
)] in
191 match List.concat
(List.map
attempt bindings
) with
196 let add_multi_dot_binding var exp bindings
=
197 let var = dot_term var in
198 let attempt bindings
= [((var,exp
)::bindings
)] in
199 match List.concat
(List.map
attempt bindings
) with
206 | (x::xs
) when (List.mem
x xs
) -> nub xs
207 | (x::xs
) -> x::(nub xs
)
209 (* --------------------------------------------------------------------- *)
213 let debug str m binding
=
214 let res = m binding
in
216 None
-> Printf.printf
"%s: failed\n" str
220 Printf.printf
"%s: %s\n" str
221 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
225 let conjunct_bindings
226 (m1
: 'binding
-> 'binding either
)
227 (m2
: 'binding
-> 'binding either
)
228 (binding
: 'binding
) : 'binding either
=
229 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
231 let rec conjunct_many_bindings = function
232 [] -> failwith
"not possible"
234 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
236 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
238 let return b binding
= if b
then OK binding
else Fail NonMatch
239 let return_false reason binding
= Fail reason
241 let match_option f t1 t2
=
243 (Some t1
, Some t2
) -> f t1 t2
244 | (None
, None
) -> return true
247 let bool_match_option f t1 t2
=
249 (Some t1
, Some t2
) -> f t1 t2
250 | (None
, None
) -> true
253 (* context_required is for the example
257 where we can't change x == NULL to eg NULL == x. So there can either be
258 nothing attached to the root or the term has to be all removed.
259 if would be nice if we knew more about the relationship between the - and +
260 code, because in the case where the + code is a separate statement in a
261 sequence, this is not a problem. Perhaps something could be done in
264 The example seems strange. Why isn't the cast attached to x?
267 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
268 (match Ast0.get_mcodekind e
with
269 Ast0.CONTEXT
(cell
) -> true
272 (* needs a special case when there is a Disj or an empty DOTS
273 the following stops at the statement level, and gives true if one
274 statement is replaced by another *)
275 let rec is_pure_context s
=
276 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
277 (match Ast0.unwrap s
with
278 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
281 match Ast0.undots
x with
282 [s
] -> is_pure_context s
283 | _
-> false (* could we do better? *))
286 (match Ast0.get_mcodekind s
with
289 (Ast.NOTHING
,_
,_
) -> true
293 (* do better for the common case of replacing a stmt by another one *)
294 ([[Ast.StatementTag
(s
)]],_
) ->
295 (match Ast.unwrap s
with
296 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
302 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
304 let match_list matcher is_list_matcher do_list_match la lb
=
305 let rec loop = function
306 ([],[]) -> return true
307 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
308 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
309 | _
-> return false in
312 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
314 let match_maker checks_needed context_required whencode_allowed
=
316 let check_mcode pmc cmc binding
=
319 match Ast0.get_pos cmc
with
320 (Ast0.MetaPos
(name
,_
,_
)) as x ->
321 (match Ast0.get_pos pmc
with
322 Ast0.MetaPos
(name1
,_
,_
) ->
323 add_binding name1
(Ast0.MetaPosTag
x) binding
325 let (rule
,name
) = Ast0.unwrap_mcode name
in
326 Fail
(Position
(rule
,name
)))
327 | Ast0.NoMetaPos
-> OK binding
330 let match_dots matcher is_list_matcher do_list_match d1 d2
=
331 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
332 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
333 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
334 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
335 match_list matcher is_list_matcher
(do_list_match d2
) la lb
336 | _
-> return false in
338 let is_elist_matcher el
=
339 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
341 let is_plist_matcher pl
=
342 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
344 let is_slist_matcher pl
=
345 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
347 let no_list _
= false in
349 let build_dots pattern data
=
350 match Ast0.unwrap pattern
with
351 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
352 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
353 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
356 let bind = Ast0.lub_pure
in
357 let option_default = Ast0.Context
in
358 let pure_mcodekind mc
=
360 then Ast0.PureContext
365 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
368 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
369 | _
-> Ast0.Impure
in
370 let donothing r k e
=
371 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
373 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
375 (* a case for everything that has a metavariable *)
376 (* pure is supposed to match only unitary metavars, not anything that
377 contains only unitary metavars *)
379 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
380 (match Ast0.unwrap i
with
381 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
382 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
383 | _
-> Ast0.Impure
) in
385 let expression r k e
=
386 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
387 (match Ast0.unwrap e
with
388 Ast0.MetaErr
(name
,_
,pure
)
389 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
391 | _
-> Ast0.Impure
) in
394 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
395 (match Ast0.unwrap t
with
396 Ast0.MetaType
(name
,pure
) -> pure
397 | _
-> Ast0.Impure
) in
400 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
401 (match Ast0.unwrap t
with
402 Ast0.MetaInit
(name
,pure
) -> pure
403 | _
-> Ast0.Impure
) in
406 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
407 (match Ast0.unwrap p
with
408 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
409 | _
-> Ast0.Impure
) in
412 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
413 (match Ast0.unwrap s
with
414 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
415 | _
-> Ast0.Impure
) in
417 V0.flat_combiner
bind option_default
418 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
419 donothing donothing donothing donothing donothing donothing
420 ident expression typeC init param donothing stmt donothing
423 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
424 match (checks_needed
,pure
) with
425 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
428 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
429 then add_binding name
(builder1 lst
)
430 else return_false (NotPure
(pure
,term name
,builder1 lst
))
431 | _
-> return_false (NotPureLength
(term name
)))
432 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
434 let add_pure_binding name pure is_pure builder
x =
435 match (checks_needed
,pure
) with
436 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
437 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
438 then add_binding name
(builder
x)
439 else return_false (NotPure
(pure
,term name
, builder
x))
440 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
442 let do_elist_match builder el lst
=
443 match Ast0.unwrap el
with
444 Ast0.MetaExprList
(name
,lenname
,pure
) ->
445 (*how to handle lenname? should it be an option type and always None?*)
446 failwith
"expr list pattern not supported in iso"
447 (*add_pure_list_binding name pure
448 pure_sp_code.V0.combiner_expression
449 (function lst -> Ast0.ExprTag(List.hd lst))
450 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
452 | _
-> failwith
"not possible" in
454 let do_plist_match builder pl lst
=
455 match Ast0.unwrap pl
with
456 Ast0.MetaParamList
(name
,lename
,pure
) ->
457 failwith
"param list pattern not supported in iso"
458 (*add_pure_list_binding name pure
459 pure_sp_code.V0.combiner_parameter
460 (function lst -> Ast0.ParamTag(List.hd lst))
461 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
463 | _
-> failwith
"not possible" in
465 let do_slist_match builder sl lst
=
466 match Ast0.unwrap sl
with
467 Ast0.MetaStmtList
(name
,pure
) ->
468 add_pure_list_binding name pure
469 pure_sp_code.VT0.combiner_rec_statement
470 (function lst
-> Ast0.StmtTag
(List.hd lst
))
471 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
473 | _
-> failwith
"not possible" in
475 let do_nolist_match _ _
= failwith
"not possible" in
477 let rec match_ident pattern id
=
478 match Ast0.unwrap pattern
with
479 Ast0.MetaId
(name
,_
,pure
) ->
480 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
481 (function id
-> Ast0.IdentTag id
) id
)
482 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
483 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
485 if not
(checks_needed
) or not
(context_required
) or is_context id
487 match (up
,Ast0.unwrap id
) with
488 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
489 if mcode_equal namea nameb
490 then check_mcode namea nameb
492 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
493 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
495 | (_
,Ast0.OptIdent
(idb
))
496 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
498 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
500 (* should we do something about matching metavars against ...? *)
501 let rec match_expr pattern expr
=
502 match Ast0.unwrap pattern
with
503 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
505 match (form
,expr
) with
509 match Ast0.unwrap e
with
510 Ast0.Constant
(c
) -> true
512 (match Ast0.unwrap c
with
514 let nm = Ast0.unwrap_mcode
nm in
515 (* all caps is a const *)
516 Str.string_match
all_caps nm 0
518 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
519 | Ast0.SizeOfExpr
(se
,exp
) -> true
520 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
521 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
522 (Ast0.lub_pure p pure
) = pure
525 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
527 match Ast0.unwrap e
with
528 Ast0.Ident
(c
) -> true
529 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
530 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
531 (Ast0.lub_pure p pure
) = pure
539 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
543 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
545 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
546 (* easier than updating type inferencer to manage multiple
548 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
549 | (_
,Some ty
) -> Some
[ty
]
553 let tyname = Ast0.rewrap_mcode name
tyname in
555 (add_pure_binding name pure
556 pure_sp_code.VT0.combiner_rec_expression
557 (function expr
-> Ast0.ExprTag expr
)
559 (function bindings
->
564 add_pure_binding tyname Ast0.Impure
565 (function _
-> Ast0.Impure
)
566 (function ty
-> Ast0.TypeCTag ty
)
568 (Ast0.reverse_type
expty))
572 "warning: unconvertible type";
573 return false bindings
))
576 (function Fail _
-> false | OK
x -> true)
579 (* not sure why this is ok. can there be more
583 (function Fail _
-> [] | OK
x -> x)
591 | OK
x -> failwith
"not possible")
595 "warning: type metavar can only match one type";*)
599 "mixture of metatype and other types not supported")
601 let expty = Ast0.get_type expr
in
602 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
604 add_pure_binding name pure
605 pure_sp_code.VT0.combiner_rec_expression
606 (function expr
-> Ast0.ExprTag expr
)
610 add_pure_binding name pure
611 pure_sp_code.VT0.combiner_rec_expression
612 (function expr
-> Ast0.ExprTag expr
)
615 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
616 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
618 if not
(checks_needed
) or not
(context_required
) or is_context expr
620 match (up
,Ast0.unwrap expr
) with
621 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
623 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
624 if mcode_equal consta constb
625 then check_mcode consta constb
627 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
628 conjunct_many_bindings
629 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
630 match_dots match_expr is_elist_matcher do_elist_match
632 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
633 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
634 if mcode_equal opa opb
636 conjunct_many_bindings
637 [check_mcode opa opb
; match_expr lefta leftb
;
638 match_expr righta rightb
]
640 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
641 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
642 conjunct_many_bindings
643 [check_mcode lp1 lp
; check_mcode rp1 rp
;
644 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
645 match_expr exp3a exp3b
]
646 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
647 if mcode_equal opa opb
649 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
651 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
652 if mcode_equal opa opb
654 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
656 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
657 if mcode_equal opa opb
659 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
661 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
662 if mcode_equal opa opb
664 conjunct_many_bindings
665 [check_mcode opa opb
; match_expr lefta leftb
;
666 match_expr righta rightb
]
668 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
669 conjunct_many_bindings
670 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
671 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
672 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
673 conjunct_many_bindings
674 [check_mcode lb1 lb
; check_mcode rb1 rb
;
675 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
676 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
677 Ast0.RecordAccess
(expb
,op
,fieldb
))
678 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
679 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
680 conjunct_many_bindings
681 [check_mcode opa op
; match_expr expa expb
;
682 match_ident fielda fieldb
]
683 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
684 conjunct_many_bindings
685 [check_mcode lp1 lp
; check_mcode rp1 rp
;
686 match_typeC tya tyb
; match_expr expa expb
]
687 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
688 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
689 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
690 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
691 conjunct_many_bindings
692 [check_mcode lp1 lp
; check_mcode rp1 rp
;
693 check_mcode szf1 szf
; match_typeC tya tyb
]
694 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
696 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
697 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
698 failwith
"not allowed in the pattern of an isomorphism"
699 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
700 failwith
"not allowed in the pattern of an isomorphism"
701 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
702 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
703 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
704 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
705 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
706 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
707 (* hope that mcode of edots is unique somehow *)
708 conjunct_bindings (check_mcode ed ed1
)
709 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
710 if edots_whencode_allowed
711 then add_dot_binding ed
(Ast0.ExprTag wc
)
714 "warning: not applying iso because of whencode";
716 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
717 | (Ast0.Estars
(_
,Some _
),_
) ->
718 failwith
"whencode not allowed in a pattern1"
719 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
720 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
721 | (_
,Ast0.OptExp
(expb
))
722 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
724 else return_false (ContextRequired
(Ast0.ExprTag expr
))
726 (* the special case for function types prevents the eg T X; -> T X = E; iso
727 from applying, which doesn't seem very relevant, but it also avoids a
728 mysterious bug that is obtained with eg int attach(...); *)
729 and match_typeC pattern t
=
730 match Ast0.unwrap pattern
with
731 Ast0.MetaType
(name
,pure
) ->
732 (match Ast0.unwrap t
with
733 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
735 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
736 (function ty
-> Ast0.TypeCTag ty
)
739 if not
(checks_needed
) or not
(context_required
) or is_context t
741 match (up
,Ast0.unwrap t
) with
742 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
743 if mcode_equal cva cvb
745 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
747 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
750 match_list check_mcode
751 (function _
-> false) (function _
-> failwith
"")
754 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
755 if mcode_equal signa signb
757 conjunct_bindings (check_mcode signa signb
)
758 (match_option match_typeC tya tyb
)
760 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
761 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
762 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
763 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
764 conjunct_many_bindings
765 [check_mcode stara starb
; check_mcode lp1a lp1b
;
766 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
767 check_mcode rp2a rp2b
; match_typeC tya tyb
;
768 match_dots match_param
is_plist_matcher
769 do_plist_match paramsa paramsb
]
770 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
771 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
772 conjunct_many_bindings
773 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
774 match_option match_typeC tya tyb
;
775 match_dots match_param
is_plist_matcher do_plist_match
777 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
778 conjunct_many_bindings
779 [check_mcode lb1 lb
; check_mcode rb1 rb
;
780 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
781 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
782 conjunct_bindings (check_mcode kinda kindb
)
783 (match_ident namea nameb
)
784 | (Ast0.StructUnionName
(kinda
,Some namea
),
785 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
786 if mcode_equal kinda kindb
788 conjunct_bindings (check_mcode kinda kindb
)
789 (match_ident namea nameb
)
791 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
792 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
793 conjunct_many_bindings
794 [check_mcode lb1 lb
; check_mcode rb1 rb
;
796 match_dots match_decl
no_list do_nolist_match declsa declsb
]
797 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
798 if mcode_equal namea nameb
799 then check_mcode namea nameb
801 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
802 failwith
"not allowed in the pattern of an isomorphism"
803 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
804 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
805 | (_
,Ast0.OptType
(tyb
))
806 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
808 else return_false (ContextRequired
(Ast0.TypeCTag t
))
810 and match_decl pattern d
=
811 if not
(checks_needed
) or not
(context_required
) or is_context d
813 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
814 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
815 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
816 if bool_match_option mcode_equal stga stgb
818 conjunct_many_bindings
819 [check_mcode eq1 eq
; check_mcode sc1 sc
;
820 match_option check_mcode stga stgb
;
821 match_typeC tya tyb
; match_ident ida idb
;
822 match_init inia inib
]
824 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
825 if bool_match_option mcode_equal stga stgb
827 conjunct_many_bindings
828 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
829 match_typeC tya tyb
; match_ident ida idb
]
831 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
832 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
833 conjunct_many_bindings
834 [match_ident namea nameb
;
835 check_mcode lp1 lp
; check_mcode rp1 rp
;
837 match_dots match_expr is_elist_matcher do_elist_match
839 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
840 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
841 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
842 conjunct_bindings (check_mcode sc1 sc
)
843 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
844 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
845 failwith
"not allowed in the pattern of an isomorphism"
846 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
847 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
848 conjunct_bindings (check_mcode dd d
)
849 (* hope that mcode of ddots is unique somehow *)
850 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
851 if ddots_whencode_allowed
852 then add_dot_binding dd
(Ast0.DeclTag wc
)
854 (Printf.printf
"warning: not applying iso because of whencode";
856 | (Ast0.Ddots
(_
,Some _
),_
) ->
857 failwith
"whencode not allowed in a pattern1"
859 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
860 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
861 match_decl decla declb
862 | (_
,Ast0.OptDecl
(declb
))
863 | (_
,Ast0.UniqueDecl
(declb
)) ->
864 match_decl pattern declb
866 else return_false (ContextRequired
(Ast0.DeclTag d
))
868 and match_init pattern i
=
869 match Ast0.unwrap pattern
with
870 Ast0.MetaInit
(name
,pure
) ->
871 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
872 (function ini
-> Ast0.InitTag ini
)
875 if not
(checks_needed
) or not
(context_required
) or is_context i
877 match (up
,Ast0.unwrap i
) with
878 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
880 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
882 conjunct_many_bindings
883 [check_mcode lb1 lb
; check_mcode rb1 rb
;
884 match_dots match_init
no_list do_nolist_match
886 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
887 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
888 conjunct_many_bindings
889 [match_list match_designator
890 (function _
-> false) (function _
-> failwith
"")
891 designators1 designators2
;
893 match_init inia inib
]
894 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
895 conjunct_many_bindings
896 [check_mcode c1 c
; match_ident namea nameb
;
897 match_init inia inib
]
898 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
899 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
900 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
901 conjunct_bindings (check_mcode id d
)
902 (* hope that mcode of edots is unique somehow *)
903 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
904 if idots_whencode_allowed
905 then add_dot_binding id
(Ast0.InitTag wc
)
908 "warning: not applying iso because of whencode";
910 | (Ast0.Idots
(_
,Some _
),_
) ->
911 failwith
"whencode not allowed in a pattern2"
912 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
913 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
914 | (_
,Ast0.OptIni
(ib
))
915 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
917 else return_false (ContextRequired
(Ast0.InitTag i
))
919 and match_designator pattern d
=
920 match (pattern
,d
) with
921 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
922 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
923 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
924 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
925 conjunct_many_bindings
926 [check_mcode lba lbb
; match_expr expa expb
;
928 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
929 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
930 conjunct_many_bindings
931 [check_mcode lba lbb
; match_expr mina minb
;
932 check_mcode dotsa dotsb
; match_expr maxa maxb
;
936 and match_param pattern p
=
937 match Ast0.unwrap pattern
with
938 Ast0.MetaParam
(name
,pure
) ->
939 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
940 (function p
-> Ast0.ParamTag p
)
942 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
944 if not
(checks_needed
) or not
(context_required
) or is_context p
946 match (up
,Ast0.unwrap p
) with
947 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
948 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
949 conjunct_bindings (match_typeC tya tyb
)
950 (match_option match_ident ida idb
)
951 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
952 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
953 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
954 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
955 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
956 match_param parama paramb
957 | (_
,Ast0.OptParam
(paramb
))
958 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
960 else return_false (ContextRequired
(Ast0.ParamTag p
))
962 and match_statement pattern s
=
963 match Ast0.unwrap pattern
with
964 Ast0.MetaStmt
(name
,pure
) ->
965 (match Ast0.unwrap s
with
966 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
967 return false (* ... is not a single statement *)
969 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
970 (function ty
-> Ast0.StmtTag ty
)
972 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
974 if not
(checks_needed
) or not
(context_required
) or is_context s
976 match (up
,Ast0.unwrap s
) with
977 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
978 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
979 conjunct_many_bindings
980 [check_mcode lp1 lp
; check_mcode rp1 rp
;
981 check_mcode lb1 lb
; check_mcode rb1 rb
;
982 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
983 match_dots match_param
is_plist_matcher do_plist_match
985 match_dots match_statement
is_slist_matcher do_slist_match
987 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
988 match_decl decla declb
989 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
990 (* seqs can only match if they are all minus (plus code
991 allowed) or all context (plus code not allowed in the body).
992 we could be more permissive if the expansions of the isos are
993 also all seqs, but this would be hard to check except at top
994 level, and perhaps not worth checking even in that case.
995 Overall, the issue is that braces are used where single
996 statements are required, and something not satisfying these
997 conditions can cause a single statement to become a
998 non-single statement after the transformation.
1000 example: if { ... -foo(); ... }
1001 if we let the sequence convert to just -foo();
1002 then we produce invalid code. For some reason,
1003 single_statement can't deal with this case, perhaps because
1004 it starts introducing too many braces? don't remember the
1007 conjunct_bindings (check_mcode lb1 lb
)
1008 (conjunct_bindings (check_mcode rb1 rb
)
1009 (if not
(checks_needed
) or is_minus s
or
1011 List.for_all
is_pure_context (Ast0.undots bodyb
))
1013 match_dots match_statement
is_slist_matcher do_slist_match
1015 else return_false (Braces
(s
))))
1016 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1017 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1018 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1019 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1020 conjunct_many_bindings
1021 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1022 check_mcode rp1 rp2
;
1023 match_expr expa expb
;
1024 match_statement branch1a branch1b
]
1025 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1026 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1027 conjunct_many_bindings
1028 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1029 check_mcode rp1 rp2
; check_mcode e1 e2
;
1030 match_expr expa expb
;
1031 match_statement branch1a branch1b
;
1032 match_statement branch2a branch2b
]
1033 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1034 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1035 conjunct_many_bindings
1036 [check_mcode w1 w
; check_mcode lp1 lp
;
1037 check_mcode rp1 rp
; match_expr expa expb
;
1038 match_statement bodya bodyb
]
1039 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1040 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1041 conjunct_many_bindings
1042 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1043 check_mcode rp1 rp
; match_statement bodya bodyb
;
1044 match_expr expa expb
]
1045 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1046 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1047 conjunct_many_bindings
1048 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1049 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1050 match_option match_expr e1a e1b
;
1051 match_option match_expr e2a e2b
;
1052 match_option match_expr e3a e3b
;
1053 match_statement bodya bodyb
]
1054 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1055 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1056 conjunct_many_bindings
1057 [match_ident nma nmb
;
1058 check_mcode lp1 lp
; check_mcode rp1 rp
;
1059 match_dots match_expr is_elist_matcher do_elist_match
1061 match_statement bodya bodyb
]
1062 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1063 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1064 conjunct_many_bindings
1065 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1066 check_mcode lb1 lb
; check_mcode rb1 rb
;
1067 match_expr expa expb
;
1068 match_dots match_statement
is_slist_matcher do_slist_match
1070 match_dots match_case_line
no_list do_nolist_match
1072 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1073 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1074 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1075 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1076 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1077 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1078 conjunct_many_bindings
1079 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1080 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1081 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1082 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1083 conjunct_many_bindings
1084 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1085 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1086 failwith
"disj not supported in patterns"
1087 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1088 failwith
"nest not supported in patterns"
1089 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1090 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1091 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1092 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1093 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1094 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1095 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1096 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1098 [] -> check_mcode d d1
1100 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1101 if dots_whencode_allowed
1103 conjunct_bindings (check_mcode d d1
)
1107 | Ast0.WhenNot wc
->
1108 conjunct_bindings prev
1109 (add_multi_dot_binding d
1110 (Ast0.DotsStmtTag wc
))
1111 | Ast0.WhenAlways wc
->
1112 conjunct_bindings prev
1113 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1114 | Ast0.WhenNotTrue wc
->
1115 conjunct_bindings prev
1116 (add_multi_dot_binding d
1117 (Ast0.IsoWhenTTag wc
))
1118 | Ast0.WhenNotFalse wc
->
1119 conjunct_bindings prev
1120 (add_multi_dot_binding d
1121 (Ast0.IsoWhenFTag wc
))
1122 | Ast0.WhenModifier
(x) ->
1123 conjunct_bindings prev
1124 (add_multi_dot_binding d
1125 (Ast0.IsoWhenTag
x)))
1129 "warning: not applying iso because of whencode";
1131 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1132 | (Ast0.Stars
(_
,_
::_
),_
) ->
1133 failwith
"whencode not allowed in a pattern3"
1134 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1135 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1136 match_statement rea reb
1137 | (_
,Ast0.OptStm
(reb
))
1138 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1140 else return_false (ContextRequired
(Ast0.StmtTag s
))
1142 (* first should provide a subset of the information in the second *)
1143 and match_fninfo patterninfo cinfo
=
1144 let patterninfo = List.sort compare
patterninfo in
1145 let cinfo = List.sort compare
cinfo in
1146 let rec loop = function
1147 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1148 if mcode_equal sta stb
1149 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1151 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1152 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1153 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1154 if mcode_equal ia ib
1155 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1157 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1158 if mcode_equal ia ib
1159 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1161 | (x::resta
,((y
::_
) as restb
)) ->
1162 (match compare
x y
with
1164 | 1 -> loop (resta
,restb
)
1165 | _
-> failwith
"not possible")
1166 | _
-> return false in
1167 loop (patterninfo,cinfo)
1169 and match_case_line pattern c
=
1170 if not
(checks_needed
) or not
(context_required
) or is_context c
1172 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1173 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1174 conjunct_many_bindings
1175 [check_mcode d1 d
; check_mcode c1 c
;
1176 match_dots match_statement
is_slist_matcher do_slist_match
1178 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1179 conjunct_many_bindings
1180 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1181 match_dots match_statement
is_slist_matcher do_slist_match
1183 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1184 failwith
"not allowed in the pattern of an isomorphism"
1185 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1186 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1188 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1190 let match_statement_dots x y
=
1191 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1193 (match_expr, match_decl
, match_statement
, match_typeC
,
1194 match_statement_dots)
1196 let match_expr dochecks context_required whencode_allowed
=
1197 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1200 let match_decl dochecks context_required whencode_allowed
=
1201 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1204 let match_statement dochecks context_required whencode_allowed
=
1205 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1208 let match_typeC dochecks context_required whencode_allowed
=
1209 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1212 let match_statement_dots dochecks context_required whencode_allowed
=
1213 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1216 (* --------------------------------------------------------------------- *)
1217 (* make an entire tree MINUS *)
1220 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1222 match mcodekind
with
1225 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1226 | _
-> failwith
"make_minus: unexpected befaft")
1227 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1228 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1229 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1231 let update_mc mcodekind e
=
1232 match !mcodekind
with
1235 (Ast.NOTHING
,_
,_
) ->
1236 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1237 | _
-> failwith
"make_minus: unexpected befaft")
1238 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1239 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1240 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1242 let donothing r k e
=
1243 let mcodekind = Ast0.get_mcodekind_ref e
in
1244 let e = k
e in update_mc mcodekind e; e in
1246 (* special case for whencode, because it isn't processed by contextneg,
1247 since it doesn't appear in the + code *)
1248 (* cases for dots and nests *)
1249 let expression r k
e =
1250 let mcodekind = Ast0.get_mcodekind_ref
e in
1251 match Ast0.unwrap
e with
1252 Ast0.Edots
(d
,whencode
) ->
1253 (*don't recurse because whencode hasn't been processed by context_neg*)
1254 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1255 | Ast0.Ecircles
(d
,whencode
) ->
1256 (*don't recurse because whencode hasn't been processed by context_neg*)
1257 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1258 | Ast0.Estars
(d
,whencode
) ->
1259 (*don't recurse because whencode hasn't been processed by context_neg*)
1260 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1261 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1262 update_mc mcodekind e;
1264 (Ast0.NestExpr
(mcode starter
,
1265 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1266 mcode ender
,whencode
,multi
))
1267 | _
-> donothing r k
e in
1269 let declaration r k
e =
1270 let mcodekind = Ast0.get_mcodekind_ref
e in
1271 match Ast0.unwrap
e with
1272 Ast0.Ddots
(d
,whencode
) ->
1273 (*don't recurse because whencode hasn't been processed by context_neg*)
1274 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1275 | _
-> donothing r k
e in
1277 let statement r k
e =
1278 let mcodekind = Ast0.get_mcodekind_ref
e in
1279 match Ast0.unwrap
e with
1280 Ast0.Dots
(d
,whencode
) ->
1281 (*don't recurse because whencode hasn't been processed by context_neg*)
1282 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1283 | Ast0.Circles
(d
,whencode
) ->
1284 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1285 | Ast0.Stars
(d
,whencode
) ->
1286 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1287 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1288 update_mc mcodekind e;
1291 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1292 mcode ender
,whencode
,multi
))
1293 | _
-> donothing r k
e in
1295 let initialiser r k
e =
1296 let mcodekind = Ast0.get_mcodekind_ref
e in
1297 match Ast0.unwrap
e with
1298 Ast0.Idots
(d
,whencode
) ->
1299 (*don't recurse because whencode hasn't been processed by context_neg*)
1300 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1301 | _
-> donothing r k
e in
1304 let info = Ast0.get_info
e in
1305 let mcodekind = Ast0.get_mcodekind_ref
e in
1306 match Ast0.unwrap
e with
1308 (* if context is - this should be - as well. There are no tokens
1309 here though, so the bottom-up minusifier in context_neg leaves it
1310 as mixed (or context for sgrep2). It would be better to fix
1311 context_neg, but that would
1312 require a special case for each term with a dots subterm. *)
1313 (match !mcodekind with
1314 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1316 (Ast.NOTHING
,_
,_
) ->
1317 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1319 | _
-> failwith
"make_minus: unexpected befaft")
1320 (* code already processed by an enclosing iso *)
1321 | Ast0.MINUS
(mc
) -> e
1325 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1326 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1327 | _
-> donothing r k
e in
1330 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1331 dots dots dots dots dots dots
1332 donothing expression donothing initialiser donothing declaration
1333 statement donothing donothing
1335 (* --------------------------------------------------------------------- *)
1336 (* rebuild mcode cells in an instantiated alt *)
1338 (* mcodes will be side effected later with plus code, so we have to copy
1339 them on instantiating an isomorphism. One could wonder whether it would
1340 be better not to use side-effects, but they are convenient for insert_plus
1341 where is it useful to manipulate a list of the mcodes but side-effect a
1343 (* hmm... Insert_plus is called before Iso_pattern... *)
1344 let rebuild_mcode start_line
=
1345 let copy_mcodekind = function
1346 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1347 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1348 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1349 | Ast0.PLUS count
->
1350 (* this function is used elsewhere where we need to rebuild the
1351 indices, and so we allow PLUS code as well *)
1354 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1356 match start_line
with
1359 {info.Ast0.pos_info
with
1360 Ast0.line_start
= x;
1361 Ast0.line_end
= x; } in
1362 {info with Ast0.pos_info
= new_pos_info}
1364 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1367 let old_info = Ast0.get_info
x in
1369 match start_line
with
1372 {old_info.Ast0.pos_info
with
1373 Ast0.line_start
= x;
1374 Ast0.line_end
= x; } in
1375 {old_info with Ast0.pos_info
= new_pos_info}
1376 | None
-> old_info in
1377 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1378 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1380 let donothing r k
e = copy_one (k
e) in
1382 (* case for control operators (if, etc) *)
1383 let statement r k
e =
1388 (match Ast0.unwrap
s with
1389 Ast0.Decl
((info,mc
),decl
) ->
1390 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1391 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1392 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1393 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1394 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1395 (info,copy_mcodekind mc
))
1396 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1397 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1398 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1399 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1400 (info,copy_mcodekind mc
))
1401 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1402 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1404 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1406 ((info,copy_mcodekind mc
),
1407 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1409 Ast0.set_dots_bef_aft
res
1410 (match Ast0.get_dots_bef_aft
res with
1411 Ast0.NoDots
-> Ast0.NoDots
1412 | Ast0.AddingBetweenDots
s ->
1413 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1414 | Ast0.DroppingBetweenDots
s ->
1415 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1418 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1419 donothing donothing donothing donothing donothing donothing
1420 donothing donothing donothing donothing donothing
1421 donothing statement donothing donothing
1423 (* --------------------------------------------------------------------- *)
1424 (* The problem of whencode. If an isomorphism contains dots in multiple
1425 rules, then the code that is matched cannot contain whencode, because we
1426 won't know which dots it goes with. Should worry about nests, but they
1427 aren't allowed in isomorphisms for the moment. *)
1430 let option_default = 0 in
1431 let bind x y
= x + y
in
1433 match Ast0.unwrap
e with
1434 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1437 V0.combiner
bind option_default
1438 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1441 let option_default = 0 in
1442 let bind x y
= x + y
in
1444 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1446 V0.combiner
bind option_default
1447 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1450 let option_default = 0 in
1451 let bind x y
= x + y
in
1453 match Ast0.unwrap
e with
1454 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1457 V0.combiner
bind option_default
1458 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1460 (* --------------------------------------------------------------------- *)
1462 let lookup name bindings mv_bindings
=
1463 try Common.Left
(List.assoc
(term name
) bindings
)
1466 (* failure is not possible anymore *)
1467 Common.Right
(List.assoc
(term name
) mv_bindings
)
1469 (* mv_bindings is for the fresh metavariables that are introduced by the
1471 let instantiate bindings mv_bindings
=
1473 match Ast0.get_pos
x with
1474 Ast0.MetaPos
(name
,_
,_
) ->
1476 match lookup name bindings mv_bindings
with
1477 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1478 | _
-> failwith
"not possible"
1479 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1481 let donothing r k
e = k
e in
1483 (* cases where metavariables can occur *)
1486 match Ast0.unwrap
e with
1487 Ast0.MetaId
(name
,constraints
,pure
) ->
1488 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1489 (match lookup name bindings mv_bindings
with
1490 Common.Left
(Ast0.IdentTag
(id
)) -> id
1491 | Common.Left
(_
) -> failwith
"not possible 1"
1492 | Common.Right
(new_mv
) ->
1495 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1496 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1497 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1500 (* case for list metavariables *)
1501 let rec elist r same_dots
= function
1504 (match Ast0.unwrap
x with
1505 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1506 failwith
"meta_expr_list in iso not supported"
1507 (*match lookup name bindings mv_bindings with
1508 Common.Left(Ast0.DotsExprTag(exp)) ->
1509 (match same_dots exp with
1511 | None -> failwith "dots put in incompatible context")
1512 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1513 | Common.Left(_) -> failwith "not possible 1"
1514 | Common.Right(new_mv) ->
1515 failwith "MetaExprList in SP not supported"*)
1516 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1517 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1519 let rec plist r same_dots
= function
1522 (match Ast0.unwrap
x with
1523 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1524 failwith
"meta_param_list in iso not supported"
1525 (*match lookup name bindings mv_bindings with
1526 Common.Left(Ast0.DotsParamTag(param)) ->
1527 (match same_dots param with
1529 | None -> failwith "dots put in incompatible context")
1530 | Common.Left(Ast0.ParamTag(param)) -> [param]
1531 | Common.Left(_) -> failwith "not possible 1"
1532 | Common.Right(new_mv) ->
1533 failwith "MetaExprList in SP not supported"*)
1534 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1535 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1537 let rec slist r same_dots
= function
1540 (match Ast0.unwrap
x with
1541 Ast0.MetaStmtList
(name
,pure
) ->
1542 (match lookup name bindings mv_bindings
with
1543 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1544 (match same_dots stm
with
1546 | None
-> failwith
"dots put in incompatible context")
1547 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1548 | Common.Left
(_
) -> failwith
"not possible 1"
1549 | Common.Right
(new_mv
) ->
1550 failwith
"MetaExprList in SP not supported")
1551 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1552 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1555 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1556 let same_circles d
=
1557 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1559 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1561 let dots list_fn r k d
=
1563 (match Ast0.unwrap d
with
1564 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1565 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1566 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1568 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1571 match Ast0.unwrap
e with
1572 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1573 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1574 (match lookup name bindings mv_bindings
with
1575 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1576 | Common.Left
(_
) -> failwith
"not possible 1"
1577 | Common.Right
(new_mv
) ->
1582 let rec renamer = function
1583 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1585 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1587 Common.Left
(Ast0.TypeCTag
(t
)) ->
1588 Ast0.ast0_type_to_type t
1590 failwith
"iso pattern: unexpected type"
1591 | Common.Right
(new_mv
) ->
1592 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1593 | Type_cocci.ConstVol
(cv
,ty
) ->
1594 Type_cocci.ConstVol
(cv
,renamer ty
)
1595 | Type_cocci.Pointer
(ty
) ->
1596 Type_cocci.Pointer
(renamer ty
)
1597 | Type_cocci.FunctionPointer
(ty
) ->
1598 Type_cocci.FunctionPointer
(renamer ty
)
1599 | Type_cocci.Array
(ty
) ->
1600 Type_cocci.Array
(renamer ty
)
1602 Some
(List.map
renamer types
) in
1605 (Ast0.set_mcode_data new_mv name
,constraints
,
1606 new_types,form
,pure
)))
1607 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1608 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1609 failwith
"metaexprlist not supported"
1610 | Ast0.Unary
(exp
,unop
) ->
1611 (match Ast0.unwrap_mcode unop
with
1612 (* propagate negation only when the propagated and the encountered
1613 negation have the same transformation, when there is nothing
1614 added to the original one, and when there is nothing added to
1615 the expression into which we are doing the propagation. This
1616 may be too conservative. *)
1619 (* k e doesn't change the outer structure of the term,
1620 only the metavars *)
1621 match Ast0.unwrap old_e
with
1622 Ast0.Unary
(exp
,_
) ->
1623 (match Ast0.unwrap exp
with
1624 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1626 | _
-> failwith
"not possible" in
1627 let nomodif = function
1632 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1634 (Ast.NOTHING
,_
,_
) -> true
1636 | _
-> failwith
"plus not possible" in
1637 let same_modif newop oldop
=
1638 (* only propagate ! is they have the same modification
1639 and no + code on the old one (the new one from the iso
1640 surely has no + code) *)
1641 match (newop
,oldop
) with
1642 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1643 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1644 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1649 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1650 (* k accumulates parens, to keep negation outside if no
1651 propagation is possible *)
1652 if nomodif (Ast0.get_mcodekind
e)
1654 match Ast0.unwrap
res with
1655 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1657 (Ast0.get_mcode_mcodekind unop
)
1658 (Ast0.get_mcode_mcodekind op
) ->
1660 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1661 | Ast0.Paren
(lp
,e1,rp
) ->
1664 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1665 | Ast0.Binary
(e1,op
,e2
) when
1667 (Ast0.get_mcode_mcodekind unop
)
1668 (Ast0.get_mcode_mcodekind op
) ->
1670 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1671 let k1 x = k
(Ast0.rewrap
e x) in
1672 (match Ast0.unwrap_mcode op
with
1673 Ast.Logical
(Ast.Inf
) ->
1674 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1675 | Ast.Logical
(Ast.Sup
) ->
1676 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1677 | Ast.Logical
(Ast.InfEq
) ->
1678 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1679 | Ast.Logical
(Ast.SupEq
) ->
1680 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1681 | Ast.Logical
(Ast.Eq
) ->
1682 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1683 | Ast.Logical
(Ast.NotEq
) ->
1684 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1685 | Ast.Logical
(Ast.AndLog
) ->
1686 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1688 negate_reb
e e2
idcont))
1689 | Ast.Logical
(Ast.OrLog
) ->
1690 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1692 negate_reb
e e2
idcont))
1696 Ast0.rewrap_mcode op
Ast.Not
)))
1697 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1698 (* use res because it is the transformed argument *)
1700 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1701 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1703 (*use e, because this might be the toplevel expression*)
1705 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1708 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1709 and negate_reb
e e1 k
=
1710 (* used when ! is propagated to multiple places, to avoid
1711 duplicating mcode cells *)
1713 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1714 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1719 | Ast0.Edots
(d
,_
) ->
1721 (match List.assoc
(dot_term d
) bindings
with
1722 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1723 | _
-> failwith
"unexpected binding")
1724 with Not_found
-> e)
1725 | Ast0.Ecircles
(d
,_
) ->
1727 (match List.assoc
(dot_term d
) bindings
with
1728 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1729 | _
-> failwith
"unexpected binding")
1730 with Not_found
-> e)
1731 | Ast0.Estars
(d
,_
) ->
1733 (match List.assoc
(dot_term d
) bindings
with
1734 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1735 | _
-> failwith
"unexpected binding")
1736 with Not_found
-> e)
1738 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1742 match Ast0.unwrap
e with
1743 Ast0.MetaType
(name
,pure
) ->
1744 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1745 (match lookup name bindings mv_bindings
with
1746 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1747 | Common.Left
(_
) -> failwith
"not possible 1"
1748 | Common.Right
(new_mv
) ->
1750 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1755 match Ast0.unwrap
e with
1756 Ast0.MetaInit
(name
,pure
) ->
1757 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1758 (match lookup name bindings mv_bindings
with
1759 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1760 | Common.Left
(_
) -> failwith
"not possible 1"
1761 | Common.Right
(new_mv
) ->
1763 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1768 match Ast0.unwrap
e with
1771 (match List.assoc
(dot_term d
) bindings
with
1772 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1773 | _
-> failwith
"unexpected binding")
1774 with Not_found
-> e)
1779 match Ast0.unwrap
e with
1780 Ast0.MetaParam
(name
,pure
) ->
1781 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1782 (match lookup name bindings mv_bindings
with
1783 Common.Left
(Ast0.ParamTag
(param)) -> param
1784 | Common.Left
(_
) -> failwith
"not possible 1"
1785 | Common.Right
(new_mv
) ->
1787 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1788 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1789 failwith
"metaparamlist not supported"
1794 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1795 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1796 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1797 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1798 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1799 | _
-> failwith
"unexpected binding" in
1803 match Ast0.unwrap
e with
1804 Ast0.MetaStmt
(name
,pure
) ->
1805 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1806 (match lookup name bindings mv_bindings
with
1807 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1808 | Common.Left
(_
) -> failwith
"not possible 1"
1809 | Common.Right
(new_mv
) ->
1811 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1812 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1818 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1819 | Ast0.Circles
(d
,_
) ->
1824 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1825 | Ast0.Stars
(d
,_
) ->
1830 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1834 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1835 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1836 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1838 (* --------------------------------------------------------------------- *)
1841 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1843 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1845 let disj_fail bindings
e =
1847 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1850 (* isomorphism code is by default CONTEXT *)
1851 let merge_plus model_mcode e_mcode
=
1852 match model_mcode
with
1854 (* add the replacement information at the root *)
1858 (match (!mc
,!emc
) with
1859 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1860 | _
-> failwith
"how can we combine minuses?")
1861 | _
-> failwith
"not possible 6")
1862 | Ast0.CONTEXT
(mc
) ->
1864 Ast0.CONTEXT
(emc
) ->
1865 (* keep the logical line info as in the model *)
1866 let (mba
,tb
,ta
) = !mc
in
1867 let (eba
,_
,_
) = !emc
in
1868 (* merging may be required when a term is replaced by a subterm *)
1870 match (mba
,eba
) with
1871 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1872 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1873 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1874 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1875 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1876 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1877 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1878 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1879 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1880 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1881 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1882 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1883 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1884 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1885 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1886 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1887 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1888 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1889 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1890 emc
:= (merged,tb
,ta
)
1891 | Ast0.MINUS
(emc
) ->
1892 let (anything_bef_aft
,_
,_
) = !mc
in
1893 let (anythings
,t
) = !emc
in
1895 (match anything_bef_aft
with
1896 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1897 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1898 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1899 | Ast.NOTHING
-> (anythings
,t
))
1900 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1901 | _
-> failwith
"not possible 7")
1902 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1903 | Ast0.PLUS _
-> failwith
"not possible 9"
1905 let copy_plus printer minusify model
e =
1906 if !Flag.sgrep_mode2
1907 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1911 match Ast0.get_mcodekind model
with
1912 Ast0.MINUS
(mc
) -> minusify
e
1913 | Ast0.CONTEXT
(mc
) -> e
1914 | _
-> failwith
"not possible: copy_plus\n" in
1915 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1919 let copy_minus printer minusify model
e =
1920 match Ast0.get_mcodekind model
with
1921 Ast0.MINUS
(mc
) -> minusify
e
1922 | Ast0.CONTEXT
(mc
) -> e
1924 if !Flag.sgrep_mode2
1926 else failwith
"not possible 8"
1927 | Ast0.PLUS _
-> failwith
"not possible 9"
1929 let whencode_allowed prev_ecount prev_icount prev_dcount
1930 ecount icount dcount rest
=
1931 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1933 let other_ecount = (* number of edots *)
1934 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1936 let other_icount = (* number of dots *)
1937 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1939 let other_dcount = (* number of dots *)
1940 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1942 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1943 dcount
= 0 or other_dcount = 0)
1945 (* copy the befores and afters to the instantiated code *)
1946 let extra_copy_stmt_plus model
e =
1947 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1949 (match Ast0.unwrap model
with
1950 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1951 | Ast0.Decl
((info,bef
),_
) ->
1952 (match Ast0.unwrap
e with
1953 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1954 | Ast0.Decl
((info,bef1
),_
) ->
1956 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1957 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1958 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1959 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1960 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1961 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1962 (match Ast0.unwrap
e with
1963 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1964 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1965 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1966 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1967 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1969 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1973 let extra_copy_other_plus model
e = e
1975 (* --------------------------------------------------------------------- *)
1977 let mv_count = ref 0
1979 let ct = !mv_count in
1980 mv_count := !mv_count + 1;
1981 "_"^
s^
"_"^
(string_of_int
ct)
1983 let get_name = function
1984 Ast.MetaIdDecl
(ar
,nm) ->
1985 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
1986 | Ast.MetaFreshIdDecl
(nm,seed
) ->
1987 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
1988 | Ast.MetaTypeDecl
(ar
,nm) ->
1989 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
1990 | Ast.MetaInitDecl
(ar
,nm) ->
1991 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
1992 | Ast.MetaListlenDecl
(nm) ->
1993 failwith
"should not be rebuilt"
1994 | Ast.MetaParamDecl
(ar
,nm) ->
1995 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
1996 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
1997 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
1998 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
1999 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2000 | Ast.MetaErrDecl
(ar
,nm) ->
2001 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2002 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2003 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2004 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2005 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2006 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2007 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2008 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2009 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2010 | Ast.MetaStmDecl
(ar
,nm) ->
2011 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2012 | Ast.MetaStmListDecl
(ar
,nm) ->
2013 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2014 | Ast.MetaFuncDecl
(ar
,nm) ->
2015 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2016 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2017 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2018 | Ast.MetaPosDecl
(ar
,nm) ->
2019 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2020 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2021 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2022 | Ast.MetaIteratorDecl
(ar
,nm) ->
2023 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2025 let make_new_metavars metavars bindings
=
2029 let (s,_
) = get_name mv
in
2030 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2035 let (s,rebuild
) = get_name mv
in
2036 let new_s = (!current_rule,new_mv s) in
2037 (rebuild
new_s, (s,new_s)))
2040 (* --------------------------------------------------------------------- *)
2042 let do_nothing x = x
2044 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2045 rebuild_mcodes name printer extra_plus update_others has_context
=
2046 let call_instantiate bindings mv_bindings alts has_context
=
2049 (function (a
,_,_,_) ->
2051 (* no need to create duplicates when the bindings have no effect *)
2053 (function bindings
->
2055 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2057 if has_context
(* ie if pat is not just a metavara *)
2059 copy_plus printer minusify
e (extra_plus
e instantiated)
2060 else instantiated in
2061 Ast0.set_iso
plus_added
2062 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2065 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2066 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2067 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2069 whencode_allowed prev_ecount prev_icount prev_dcount
2070 ecount dcount icount rest
in
2071 (match matcher
true (context_required e) wc pattern
e init_env with
2073 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2076 (match matcher
false false wc pattern
e init_env with
2078 interpret_reason name
(Ast0.get_line
e) reason
2079 (function () -> printer
e)
2081 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2082 (prev_dcount
+ dcount
) rest
2083 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2085 (* apply update_others to all patterns other than the matched
2086 one. This is used to desigate the others as test
2087 expressions in the TestExpression case *)
2089 (function (x,e,i
,d
) as all
->
2092 else (update_others
x,e,i
,d
))
2093 (List.hd
all_alts)) ::
2095 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2096 (List.tl
all_alts)) in
2097 (match List.concat
all_alts with
2098 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2100 let (new_metavars,mv_bindings
) =
2101 make_new_metavars metavars
(nub(List.concat bindings
)) in
2104 call_instantiate bindings mv_bindings
all_alts
2105 (has_context pattern
)))) in
2106 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2107 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2108 | (alts
::rest
) as all_alts ->
2109 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2110 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2111 outer_loop prev_ecount prev_icount prev_dcount rest
2112 | Common.Right
(new_metavars,res) ->
2114 copy_minus printer minusify
e (disj_maker
res)) in
2115 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2116 (count
, metavars
, e)
2118 (* no one should ever look at the information stored in these mcodes *)
2119 let disj_starter lst
=
2120 let old_info = Ast0.get_info
(List.hd lst
) in
2122 { old_info.Ast0.pos_info
with
2123 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2124 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2126 { Ast0.pos_info
= new_pos_info;
2127 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2128 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2129 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2130 Ast0.make_mcode_info
"(" info
2132 let disj_ender lst
=
2133 let old_info = Ast0.get_info
(List.hd lst
) in
2135 { old_info.Ast0.pos_info
with
2136 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2137 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2139 { Ast0.pos_info
= new_pos_info;
2140 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2141 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2142 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2143 Ast0.make_mcode_info
")" info
2145 let disj_mid _ = Ast0.make_mcode
"|"
2147 let make_disj_type tl
=
2150 [] -> failwith
"bad disjunction"
2151 | x::xs
-> List.map
disj_mid xs
in
2152 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2153 let make_disj_stmt_list tl
=
2156 [] -> failwith
"bad disjunction"
2157 | x::xs
-> List.map
disj_mid xs
in
2158 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2159 let make_disj_expr model el
=
2162 [] -> failwith
"bad disjunction"
2163 | x::xs
-> List.map
disj_mid xs
in
2165 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2167 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2168 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2169 let el = List.map
update_arg (List.map
update_test el) in
2170 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2171 let make_disj_decl dl
=
2174 [] -> failwith
"bad disjunction"
2175 | x::xs
-> List.map
disj_mid xs
in
2176 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2177 let make_disj_stmt sl
=
2178 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2181 [] -> failwith
"bad disjunction"
2182 | x::xs
-> List.map
disj_mid xs
in
2184 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2186 let transform_type (metavars
,alts
,name
) e =
2188 (Ast0.TypeCTag
(_)::_)::_ ->
2189 (* start line is given to any leaves in the iso code *)
2191 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2197 (p
,count_edots.VT0.combiner_rec_typeC p
,
2198 count_idots.VT0.combiner_rec_typeC p
,
2199 count_dots.VT0.combiner_rec_typeC p
)
2200 | _ -> failwith
"invalid alt"))
2202 mkdisj match_typeC metavars
alts e
2203 (function b
-> function mv_b
->
2204 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2205 (function t
-> Ast0.TypeCTag t
)
2206 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2207 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2208 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2210 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2214 let transform_expr (metavars
,alts,name
) e =
2215 let process update_others
=
2216 (* start line is given to any leaves in the iso code *)
2218 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2223 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2224 (p
,count_edots.VT0.combiner_rec_expression p
,
2225 count_idots.VT0.combiner_rec_expression p
,
2226 count_dots.VT0.combiner_rec_expression p
)
2227 | _ -> failwith
"invalid alt"))
2229 mkdisj match_expr metavars
alts e
2230 (function b
-> function mv_b
->
2231 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2232 (function e -> Ast0.ExprTag
e)
2234 make_minus.VT0.rebuilder_rec_expression
2235 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2236 name
Unparse_ast0.expression extra_copy_other_plus update_others
2238 match Ast0.unwrap
x with
2239 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2243 (Ast0.ExprTag
(_)::r
)::rs
->
2244 (* hack to accomodate ToTestExpression case, where the first pattern is
2245 a normal expression, but the others are test expressions *)
2246 let others = r
@ (List.concat rs
) in
2247 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2248 if List.for_all
is_test others then process Ast0.set_test_exp
2249 else if List.exists
is_test others then failwith
"inconsistent iso"
2250 else process do_nothing
2251 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2252 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2253 process Ast0.set_test_exp
2256 let transform_decl (metavars
,alts,name
) e =
2258 (Ast0.DeclTag
(_)::_)::_ ->
2259 (* start line is given to any leaves in the iso code *)
2261 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2267 (p
,count_edots.VT0.combiner_rec_declaration p
,
2268 count_idots.VT0.combiner_rec_declaration p
,
2269 count_dots.VT0.combiner_rec_declaration p
)
2270 | _ -> failwith
"invalid alt"))
2272 mkdisj match_decl metavars
alts e
2273 (function b
-> function mv_b
->
2274 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2275 (function d
-> Ast0.DeclTag d
)
2277 make_minus.VT0.rebuilder_rec_declaration
2278 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2279 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2280 (function _ -> true (* no metavars *))
2283 let transform_stmt (metavars
,alts,name
) e =
2285 (Ast0.StmtTag
(_)::_)::_ ->
2286 (* start line is given to any leaves in the iso code *)
2288 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2294 (p
,count_edots.VT0.combiner_rec_statement p
,
2295 count_idots.VT0.combiner_rec_statement p
,
2296 count_dots.VT0.combiner_rec_statement p
)
2297 | _ -> failwith
"invalid alt"))
2299 mkdisj match_statement metavars
alts e
2300 (function b
-> function mv_b
->
2301 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2302 (function s -> Ast0.StmtTag
s)
2303 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2304 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2305 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2307 match Ast0.unwrap
x with
2308 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2312 (* sort of a hack, because there is no disj at top level *)
2313 let transform_top (metavars
,alts,name
) e =
2314 match Ast0.unwrap
e with
2315 Ast0.DECL
(declstm
) ->
2321 Ast0.DotsStmtTag
(d
) ->
2322 (match Ast0.unwrap d
with
2323 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2324 | _ -> raise
(Failure
""))
2325 | _ -> raise
(Failure
"")))
2327 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2328 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2329 with Failure
_ -> (0,[],e))
2330 | Ast0.CODE
(stmts
) ->
2331 let (count
,mv
,res) =
2333 (Ast0.DotsStmtTag
(_)::_)::_ ->
2334 (* start line is given to any leaves in the iso code *)
2336 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2341 Ast0.DotsStmtTag
(p
) ->
2342 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2343 count_idots.VT0.combiner_rec_statement_dots p
,
2344 count_dots.VT0.combiner_rec_statement_dots p
)
2345 | _ -> failwith
"invalid alt"))
2347 mkdisj match_statement_dots metavars
alts stmts
2348 (function b
-> function mv_b
->
2349 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2350 (function s -> Ast0.DotsStmtTag
s)
2352 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2354 make_minus.VT0.rebuilder_rec_statement_dots
x)
2355 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2356 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2357 (function _ -> true)
2358 | _ -> (0,[],stmts
) in
2359 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2362 (* --------------------------------------------------------------------- *)
2364 let transform (alts : isomorphism
) t
=
2365 (* the following ugliness is because rebuilder only returns a new term *)
2366 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2367 let in_limit n
= function
2371 ((if !Flag_parsing_cocci.show_iso_failures
2372 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2374 let bind x y
= x + y
in
2375 let option_default = 0 in
2377 let (e_count
,e) = k
e in
2378 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2380 let (count
,extra_meta
,exp
) = transform_expr alts e in
2381 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2382 (bind count e_count
,exp
)
2386 let (e_count
,e) = k
e in
2387 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2389 let (count
,extra_meta
,dec
) = transform_decl alts e in
2390 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2391 (bind count e_count
,dec
)
2395 let (e_count
,e) = k
e in
2396 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2398 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2399 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2400 (bind count e_count
,stm
)
2404 let (continue
,e_count
,e) =
2405 match Ast0.unwrap
e with
2406 Ast0.Signed
(signb
,tyb
) ->
2407 (* Hack! How else to prevent iso from applying under an
2411 let (e_count
,e) = k
e in
2412 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2413 then (true,e_count
,e)
2414 else (false,e_count
,e) in
2417 let (count
,extra_meta
,ty
) = transform_type alts e in
2418 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2419 (bind count e_count
,ty
)
2423 let (e_count
,e) = k
e in
2424 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2426 let (count
,extra_meta
,ty
) = transform_top alts e in
2427 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2428 (bind count e_count
,ty
)
2432 V0.combiner_rebuilder
bind option_default
2433 {V0.combiner_rebuilder_functions
with
2434 VT0.combiner_rebuilder_exprfn
= exprfn;
2435 VT0.combiner_rebuilder_tyfn
= typefn;
2436 VT0.combiner_rebuilder_declfn
= declfn;
2437 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2438 VT0.combiner_rebuilder_topfn
= topfn} in
2439 let (_,res) = res.VT0.top_level t
in
2440 (!extra_meta_decls,res)
2442 (* --------------------------------------------------------------------- *)
2444 (* should be done by functorizing the parser to use wrap or context_wrap *)
2446 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2447 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2449 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2450 donothing donothing donothing donothing donothing donothing
2451 donothing donothing donothing donothing donothing donothing donothing
2454 let rewrap_anything = function
2455 Ast0.DotsExprTag
(d
) ->
2456 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2457 | Ast0.DotsInitTag
(d
) ->
2458 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2459 | Ast0.DotsParamTag
(d
) ->
2460 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2461 | Ast0.DotsStmtTag
(d
) ->
2462 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2463 | Ast0.DotsDeclTag
(d
) ->
2464 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2465 | Ast0.DotsCaseTag
(d
) ->
2466 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2467 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2468 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2469 | Ast0.ArgExprTag
(d
) ->
2470 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2471 | Ast0.TestExprTag
(d
) ->
2472 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2473 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2474 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2475 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2476 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2477 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2478 | Ast0.CaseLineTag
(d
) ->
2479 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2480 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2481 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2482 failwith
"only for isos within iso phase"
2483 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2485 (* --------------------------------------------------------------------- *)
2487 let apply_isos isos rule rule_name
=
2492 current_rule := rule_name
;
2495 (function (metavars
,iso
,name
) ->
2496 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2498 let (extra_meta
,rule
) =
2503 (function (extra_meta
,t
) -> function iso
->
2504 let (new_extra_meta
,t
) = transform iso t
in
2505 (new_extra_meta
@extra_meta
,t
))
2508 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)