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.
23 (* Potential problem: offset of mcode is not updated when an iso is
24 instantiated, implying that a term may end up with many mcodes with the
25 same offset. On the other hand, at the moment offset only seems to be used
26 before this phase. Furthermore add_dot_binding relies on the offset to
27 remain the same between matching an iso and instantiating it with bindings. *)
29 (* --------------------------------------------------------------------- *)
30 (* match a SmPL expression against a SmPL abstract syntax tree,
33 module Ast
= Ast_cocci
34 module Ast0
= Ast0_cocci
35 module V0
= Visitor_ast0
36 module VT0
= Visitor_ast0_types
38 let current_rule = ref ""
40 (* --------------------------------------------------------------------- *)
43 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
46 let mcode (term
,_
,_
,_
,_
,_
) =
47 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
48 ref Ast0.NoMetaPos
,-1) in
51 {(Ast0.wrap
(Ast0.unwrap
x)) with
52 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
53 Ast0.true_if_test
= x.Ast0.true_if_test
} in
55 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
56 donothing donothing donothing donothing donothing donothing
57 donothing donothing donothing donothing donothing donothing donothing
60 let anything_equal = function
61 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
62 failwith
"not a possible variable binding" (*not sure why these are pbs*)
63 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
64 failwith
"not a possible variable binding"
65 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
66 failwith
"not a possible variable binding"
67 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
68 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
69 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
70 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
71 failwith
"not a possible variable binding"
72 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
73 failwith
"not a possible variable binding"
74 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
75 (strip_info.VT0.rebuilder_rec_ident d1
) =
76 (strip_info.VT0.rebuilder_rec_ident d2
)
77 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
78 (strip_info.VT0.rebuilder_rec_expression d1
) =
79 (strip_info.VT0.rebuilder_rec_expression d2
)
80 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
81 failwith
"not possible - only in isos1"
82 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
83 failwith
"not possible - only in isos1"
84 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
85 (strip_info.VT0.rebuilder_rec_typeC d1
) =
86 (strip_info.VT0.rebuilder_rec_typeC d2
)
87 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
88 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
89 (strip_info.VT0.rebuilder_rec_initialiser d2
)
90 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
91 (strip_info.VT0.rebuilder_rec_parameter d1
) =
92 (strip_info.VT0.rebuilder_rec_parameter d2
)
93 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
94 (strip_info.VT0.rebuilder_rec_declaration d1
) =
95 (strip_info.VT0.rebuilder_rec_declaration d2
)
96 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
97 (strip_info.VT0.rebuilder_rec_statement d1
) =
98 (strip_info.VT0.rebuilder_rec_statement d2
)
99 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
100 (strip_info.VT0.rebuilder_rec_case_line d1
) =
101 (strip_info.VT0.rebuilder_rec_case_line d2
)
102 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
103 (strip_info.VT0.rebuilder_rec_top_level d1
) =
104 (strip_info.VT0.rebuilder_rec_top_level d2
)
105 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
106 failwith
"only for isos within iso phase"
107 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
108 failwith
"only for isos within iso phase"
109 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
110 failwith
"only for isos within iso phase"
113 let term (var1
,_
,_
,_
,_
,_
) = var1
114 let dot_term (var1
,_
,info
,_
,_
,_
) =
115 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
119 NotPure
of Ast0.pure
* Ast.meta_name
* Ast0.anything
120 | NotPureLength
of Ast.meta_name
121 | ContextRequired
of Ast0.anything
123 | Braces
of Ast0.statement
124 | Position
of Ast.meta_name
125 | TypeMatch
of reason list
127 let rec interpret_reason name line reason printer
=
129 "warning: iso %s does not match the code below on line %d\n" name line
;
130 printer
(); Format.print_newline
();
132 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
134 "pure metavariable %s is matched against the following nonpure code:\n"
136 Unparse_ast0.unparse_anything nonpure
137 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
139 "context metavariable %s is matched against the following\nnoncontext code:\n"
141 Unparse_ast0.unparse_anything nonpure
142 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
144 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
146 Unparse_ast0.unparse_anything nonpure
147 | NotPureLength
((_
,var
)) ->
149 "pure metavariable %s is matched against too much or too little code\n"
151 | ContextRequired
(term) ->
153 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
154 Unparse_ast0.unparse_anything
term
156 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
157 Unparse_ast0.statement
"" s
;
158 Format.print_newline
()
159 | Position
(rule
,name
) ->
160 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
162 | TypeMatch reason_list
->
163 List.iter
(function r
-> interpret_reason name line r printer
)
165 | _
-> failwith
"not possible"
167 type 'a either
= OK
of 'a
| Fail
of reason
169 let add_binding var exp bindings
=
170 let var = term var in
171 let attempt bindings
=
173 let cur = List.assoc
var bindings
in
174 if anything_equal(exp
,cur) then [bindings
] else []
175 with Not_found
-> [((var,exp
)::bindings
)] in
176 match List.concat
(List.map
attempt bindings
) with
180 let add_dot_binding var exp bindings
=
181 let var = dot_term var in
182 let attempt bindings
=
184 let cur = List.assoc
var bindings
in
185 if anything_equal(exp
,cur) then [bindings
] else []
186 with Not_found
-> [((var,exp
)::bindings
)] in
187 match List.concat
(List.map
attempt bindings
) with
192 let add_multi_dot_binding var exp bindings
=
193 let var = dot_term var in
194 let attempt bindings
= [((var,exp
)::bindings
)] in
195 match List.concat
(List.map
attempt bindings
) with
202 | (x::xs
) when (List.mem
x xs
) -> nub xs
203 | (x::xs
) -> x::(nub xs
)
205 (* --------------------------------------------------------------------- *)
209 let debug str m binding
=
210 let res = m binding
in
212 None
-> Printf.printf
"%s: failed\n" str
216 Printf.printf
"%s: %s\n" str
217 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
221 let conjunct_bindings
222 (m1
: 'binding
-> 'binding either
)
223 (m2
: 'binding
-> 'binding either
)
224 (binding
: 'binding
) : 'binding either
=
225 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
227 let rec conjunct_many_bindings = function
228 [] -> failwith
"not possible"
230 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
232 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
234 let return b binding
= if b
then OK binding
else Fail NonMatch
235 let return_false reason binding
= Fail reason
237 let match_option f t1 t2
=
239 (Some t1
, Some t2
) -> f t1 t2
240 | (None
, None
) -> return true
243 let bool_match_option f t1 t2
=
245 (Some t1
, Some t2
) -> f t1 t2
246 | (None
, None
) -> true
249 (* context_required is for the example
253 where we can't change x == NULL to eg NULL == x. So there can either be
254 nothing attached to the root or the term has to be all removed.
255 if would be nice if we knew more about the relationship between the - and +
256 code, because in the case where the + code is a separate statement in a
257 sequence, this is not a problem. Perhaps something could be done in
260 The example seems strange. Why isn't the cast attached to x?
263 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
264 (match Ast0.get_mcodekind e
with
265 Ast0.CONTEXT
(cell
) -> true
268 (* needs a special case when there is a Disj or an empty DOTS
269 the following stops at the statement level, and gives true if one
270 statement is replaced by another *)
271 let rec is_pure_context s
=
272 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
273 (match Ast0.unwrap s
with
274 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
277 match Ast0.undots
x with
278 [s
] -> is_pure_context s
279 | _
-> false (* could we do better? *))
282 (match Ast0.get_mcodekind s
with
285 (Ast.NOTHING
,_
,_
) -> true
289 (* do better for the common case of replacing a stmt by another one *)
290 ([[Ast.StatementTag
(s
)]],_
) ->
291 (match Ast.unwrap s
with
292 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
298 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
300 let match_list matcher is_list_matcher do_list_match la lb
=
301 let rec loop = function
302 ([],[]) -> return true
303 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
304 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
305 | _
-> return false in
308 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
310 let match_maker checks_needed context_required whencode_allowed
=
312 let check_mcode pmc cmc binding
=
315 match Ast0.get_pos cmc
with
316 (Ast0.MetaPos
(name
,_
,_
)) as x ->
317 (match Ast0.get_pos pmc
with
318 Ast0.MetaPos
(name1
,_
,_
) ->
319 add_binding name1
(Ast0.MetaPosTag
x) binding
321 let (rule
,name
) = Ast0.unwrap_mcode name
in
322 Fail
(Position
(rule
,name
)))
323 | Ast0.NoMetaPos
-> OK binding
326 let match_dots matcher is_list_matcher do_list_match d1 d2
=
327 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
328 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
329 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
330 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
331 match_list matcher is_list_matcher
(do_list_match d2
) la lb
332 | _
-> return false in
334 let is_elist_matcher el
=
335 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
337 let is_plist_matcher pl
=
338 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
340 let is_slist_matcher pl
=
341 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
343 let no_list _
= false in
345 let build_dots pattern data
=
346 match Ast0.unwrap pattern
with
347 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
348 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
349 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
352 let bind = Ast0.lub_pure
in
353 let option_default = Ast0.Context
in
354 let pure_mcodekind mc
=
356 then Ast0.PureContext
361 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
364 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
365 | _
-> Ast0.Impure
in
366 let donothing r k e
=
367 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
369 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
371 (* a case for everything that has a metavariable *)
372 (* pure is supposed to match only unitary metavars, not anything that
373 contains only unitary metavars *)
375 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
376 (match Ast0.unwrap i
with
377 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
378 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
379 | _
-> Ast0.Impure
) in
381 let expression r k e
=
382 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
383 (match Ast0.unwrap e
with
384 Ast0.MetaErr
(name
,_
,pure
)
385 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
387 | _
-> Ast0.Impure
) in
390 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
391 (match Ast0.unwrap t
with
392 Ast0.MetaType
(name
,pure
) -> pure
393 | _
-> Ast0.Impure
) in
396 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
397 (match Ast0.unwrap t
with
398 Ast0.MetaInit
(name
,pure
) -> pure
399 | _
-> Ast0.Impure
) in
402 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
403 (match Ast0.unwrap p
with
404 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
405 | _
-> Ast0.Impure
) in
408 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
409 (match Ast0.unwrap s
with
410 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
411 | _
-> Ast0.Impure
) in
413 V0.flat_combiner
bind option_default
414 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
415 donothing donothing donothing donothing donothing donothing
416 ident expression typeC init param donothing stmt donothing
419 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
420 match (checks_needed
,pure
) with
421 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
424 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
425 then add_binding name
(builder1 lst
)
426 else return_false (NotPure
(pure
,term name
,builder1 lst
))
427 | _
-> return_false (NotPureLength
(term name
)))
428 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
430 let add_pure_binding name pure is_pure builder
x =
431 match (checks_needed
,pure
) with
432 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
433 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
434 then add_binding name
(builder
x)
435 else return_false (NotPure
(pure
,term name
, builder
x))
436 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
438 let do_elist_match builder el lst
=
439 match Ast0.unwrap el
with
440 Ast0.MetaExprList
(name
,lenname
,pure
) ->
441 (*how to handle lenname? should it be an option type and always None?*)
442 failwith
"expr list pattern not supported in iso"
443 (*add_pure_list_binding name pure
444 pure_sp_code.V0.combiner_expression
445 (function lst -> Ast0.ExprTag(List.hd lst))
446 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
448 | _
-> failwith
"not possible" in
450 let do_plist_match builder pl lst
=
451 match Ast0.unwrap pl
with
452 Ast0.MetaParamList
(name
,lename
,pure
) ->
453 failwith
"param list pattern not supported in iso"
454 (*add_pure_list_binding name pure
455 pure_sp_code.V0.combiner_parameter
456 (function lst -> Ast0.ParamTag(List.hd lst))
457 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
459 | _
-> failwith
"not possible" in
461 let do_slist_match builder sl lst
=
462 match Ast0.unwrap sl
with
463 Ast0.MetaStmtList
(name
,pure
) ->
464 add_pure_list_binding name pure
465 pure_sp_code.VT0.combiner_rec_statement
466 (function lst
-> Ast0.StmtTag
(List.hd lst
))
467 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
469 | _
-> failwith
"not possible" in
471 let do_nolist_match _ _
= failwith
"not possible" in
473 let rec match_ident pattern id
=
474 match Ast0.unwrap pattern
with
475 Ast0.MetaId
(name
,_
,pure
) ->
476 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
477 (function id
-> Ast0.IdentTag id
) id
)
478 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
479 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
481 if not
(checks_needed
) or not
(context_required
) or is_context id
483 match (up
,Ast0.unwrap id
) with
484 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
485 if mcode_equal namea nameb
486 then check_mcode namea nameb
488 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
489 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
491 | (_
,Ast0.OptIdent
(idb
))
492 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
494 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
496 (* should we do something about matching metavars against ...? *)
497 let rec match_expr pattern expr
=
498 match Ast0.unwrap pattern
with
499 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
501 match (form
,expr
) with
505 match Ast0.unwrap e
with
506 Ast0.Constant
(c
) -> true
508 (match Ast0.unwrap c
with
510 let nm = Ast0.unwrap_mcode
nm in
511 (* all caps is a const *)
512 Str.string_match
all_caps nm 0
514 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
515 | Ast0.SizeOfExpr
(se
,exp
) -> true
516 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
517 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
518 (Ast0.lub_pure p pure
) = pure
521 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
523 match Ast0.unwrap e
with
524 Ast0.Ident
(c
) -> true
525 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
526 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
527 (Ast0.lub_pure p pure
) = pure
535 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
539 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
541 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
542 (* easier than updating type inferencer to manage multiple
544 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
545 | (_
,Some ty
) -> Some
[ty
]
549 let tyname = Ast0.rewrap_mcode name
tyname in
551 (add_pure_binding name pure
552 pure_sp_code.VT0.combiner_rec_expression
553 (function expr
-> Ast0.ExprTag expr
)
555 (function bindings
->
560 add_pure_binding tyname Ast0.Impure
561 (function _
-> Ast0.Impure
)
562 (function ty
-> Ast0.TypeCTag ty
)
564 (Ast0.reverse_type
expty))
568 "warning: unconvertible type";
569 return false bindings
))
572 (function Fail _
-> false | OK
x -> true)
575 (* not sure why this is ok. can there be more
579 (function Fail _
-> [] | OK
x -> x)
587 | OK
x -> failwith
"not possible")
591 "warning: type metavar can only match one type";*)
595 "mixture of metatype and other types not supported")
597 let expty = Ast0.get_type expr
in
598 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
600 add_pure_binding name pure
601 pure_sp_code.VT0.combiner_rec_expression
602 (function expr
-> Ast0.ExprTag expr
)
606 add_pure_binding name pure
607 pure_sp_code.VT0.combiner_rec_expression
608 (function expr
-> Ast0.ExprTag expr
)
611 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
612 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
614 if not
(checks_needed
) or not
(context_required
) or is_context expr
616 match (up
,Ast0.unwrap expr
) with
617 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
619 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
620 if mcode_equal consta constb
621 then check_mcode consta constb
623 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
624 conjunct_many_bindings
625 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
626 match_dots match_expr is_elist_matcher do_elist_match
628 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
629 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
630 if mcode_equal opa opb
632 conjunct_many_bindings
633 [check_mcode opa opb
; match_expr lefta leftb
;
634 match_expr righta rightb
]
636 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
637 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
638 conjunct_many_bindings
639 [check_mcode lp1 lp
; check_mcode rp1 rp
;
640 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
641 match_expr exp3a exp3b
]
642 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
643 if mcode_equal opa opb
645 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
647 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
648 if mcode_equal opa opb
650 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
652 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
653 if mcode_equal opa opb
655 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
657 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
658 if mcode_equal opa opb
660 conjunct_many_bindings
661 [check_mcode opa opb
; match_expr lefta leftb
;
662 match_expr righta rightb
]
664 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
665 conjunct_many_bindings
666 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
667 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
668 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
669 conjunct_many_bindings
670 [check_mcode lb1 lb
; check_mcode rb1 rb
;
671 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
672 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
673 Ast0.RecordAccess
(expb
,op
,fieldb
))
674 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
675 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
676 conjunct_many_bindings
677 [check_mcode opa op
; match_expr expa expb
;
678 match_ident fielda fieldb
]
679 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
680 conjunct_many_bindings
681 [check_mcode lp1 lp
; check_mcode rp1 rp
;
682 match_typeC tya tyb
; match_expr expa expb
]
683 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
684 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
685 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
686 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
687 conjunct_many_bindings
688 [check_mcode lp1 lp
; check_mcode rp1 rp
;
689 check_mcode szf1 szf
; match_typeC tya tyb
]
690 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
692 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
693 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
694 failwith
"not allowed in the pattern of an isomorphism"
695 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
696 failwith
"not allowed in the pattern of an isomorphism"
697 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
698 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
699 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
700 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
701 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
702 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
703 (* hope that mcode of edots is unique somehow *)
704 conjunct_bindings (check_mcode ed ed1
)
705 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
706 if edots_whencode_allowed
707 then add_dot_binding ed
(Ast0.ExprTag wc
)
710 "warning: not applying iso because of whencode";
712 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
713 | (Ast0.Estars
(_
,Some _
),_
) ->
714 failwith
"whencode not allowed in a pattern1"
715 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
716 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
717 | (_
,Ast0.OptExp
(expb
))
718 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
720 else return_false (ContextRequired
(Ast0.ExprTag expr
))
722 (* the special case for function types prevents the eg T X; -> T X = E; iso
723 from applying, which doesn't seem very relevant, but it also avoids a
724 mysterious bug that is obtained with eg int attach(...); *)
725 and match_typeC pattern t
=
726 match Ast0.unwrap pattern
with
727 Ast0.MetaType
(name
,pure
) ->
728 (match Ast0.unwrap t
with
729 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
731 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
732 (function ty
-> Ast0.TypeCTag ty
)
735 if not
(checks_needed
) or not
(context_required
) or is_context t
737 match (up
,Ast0.unwrap t
) with
738 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
739 if mcode_equal cva cvb
741 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
743 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
746 match_list check_mcode
747 (function _
-> false) (function _
-> failwith
"")
750 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
751 if mcode_equal signa signb
753 conjunct_bindings (check_mcode signa signb
)
754 (match_option match_typeC tya tyb
)
756 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
757 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
758 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
759 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
760 conjunct_many_bindings
761 [check_mcode stara starb
; check_mcode lp1a lp1b
;
762 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
763 check_mcode rp2a rp2b
; match_typeC tya tyb
;
764 match_dots match_param
is_plist_matcher
765 do_plist_match paramsa paramsb
]
766 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
767 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
768 conjunct_many_bindings
769 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
770 match_option match_typeC tya tyb
;
771 match_dots match_param
is_plist_matcher do_plist_match
773 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
774 conjunct_many_bindings
775 [check_mcode lb1 lb
; check_mcode rb1 rb
;
776 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
777 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
778 conjunct_bindings (check_mcode kinda kindb
)
779 (match_ident namea nameb
)
780 | (Ast0.StructUnionName
(kinda
,Some namea
),
781 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
782 if mcode_equal kinda kindb
784 conjunct_bindings (check_mcode kinda kindb
)
785 (match_ident namea nameb
)
787 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
788 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
789 conjunct_many_bindings
790 [check_mcode lb1 lb
; check_mcode rb1 rb
;
792 match_dots match_decl
no_list do_nolist_match declsa declsb
]
793 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
794 if mcode_equal namea nameb
795 then check_mcode namea nameb
797 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
798 failwith
"not allowed in the pattern of an isomorphism"
799 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
800 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
801 | (_
,Ast0.OptType
(tyb
))
802 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
804 else return_false (ContextRequired
(Ast0.TypeCTag t
))
806 and match_decl pattern d
=
807 if not
(checks_needed
) or not
(context_required
) or is_context d
809 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
810 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
811 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
812 if bool_match_option mcode_equal stga stgb
814 conjunct_many_bindings
815 [check_mcode eq1 eq
; check_mcode sc1 sc
;
816 match_option check_mcode stga stgb
;
817 match_typeC tya tyb
; match_ident ida idb
;
818 match_init inia inib
]
820 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
821 if bool_match_option mcode_equal stga stgb
823 conjunct_many_bindings
824 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
825 match_typeC tya tyb
; match_ident ida idb
]
827 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
828 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
829 conjunct_many_bindings
830 [match_ident namea nameb
;
831 check_mcode lp1 lp
; check_mcode rp1 rp
;
833 match_dots match_expr is_elist_matcher do_elist_match
835 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
836 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
837 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
838 conjunct_bindings (check_mcode sc1 sc
)
839 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
840 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
841 failwith
"not allowed in the pattern of an isomorphism"
842 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
843 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
844 conjunct_bindings (check_mcode dd d
)
845 (* hope that mcode of ddots is unique somehow *)
846 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
847 if ddots_whencode_allowed
848 then add_dot_binding dd
(Ast0.DeclTag wc
)
850 (Printf.printf
"warning: not applying iso because of whencode";
852 | (Ast0.Ddots
(_
,Some _
),_
) ->
853 failwith
"whencode not allowed in a pattern1"
855 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
856 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
857 match_decl decla declb
858 | (_
,Ast0.OptDecl
(declb
))
859 | (_
,Ast0.UniqueDecl
(declb
)) ->
860 match_decl pattern declb
862 else return_false (ContextRequired
(Ast0.DeclTag d
))
864 and match_init pattern i
=
865 match Ast0.unwrap pattern
with
866 Ast0.MetaInit
(name
,pure
) ->
867 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
868 (function ini
-> Ast0.InitTag ini
)
871 if not
(checks_needed
) or not
(context_required
) or is_context i
873 match (up
,Ast0.unwrap i
) with
874 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
876 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
878 conjunct_many_bindings
879 [check_mcode lb1 lb
; check_mcode rb1 rb
;
880 match_dots match_init
no_list do_nolist_match
882 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
883 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
884 conjunct_many_bindings
885 [match_list match_designator
886 (function _
-> false) (function _
-> failwith
"")
887 designators1 designators2
;
889 match_init inia inib
]
890 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
891 conjunct_many_bindings
892 [check_mcode c1 c
; match_ident namea nameb
;
893 match_init inia inib
]
894 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
895 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
896 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
897 conjunct_bindings (check_mcode id d
)
898 (* hope that mcode of edots is unique somehow *)
899 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
900 if idots_whencode_allowed
901 then add_dot_binding id
(Ast0.InitTag wc
)
904 "warning: not applying iso because of whencode";
906 | (Ast0.Idots
(_
,Some _
),_
) ->
907 failwith
"whencode not allowed in a pattern2"
908 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
909 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
910 | (_
,Ast0.OptIni
(ib
))
911 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
913 else return_false (ContextRequired
(Ast0.InitTag i
))
915 and match_designator pattern d
=
916 match (pattern
,d
) with
917 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
918 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
919 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
920 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
921 conjunct_many_bindings
922 [check_mcode lba lbb
; match_expr expa expb
;
924 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
925 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
926 conjunct_many_bindings
927 [check_mcode lba lbb
; match_expr mina minb
;
928 check_mcode dotsa dotsb
; match_expr maxa maxb
;
932 and match_param pattern p
=
933 match Ast0.unwrap pattern
with
934 Ast0.MetaParam
(name
,pure
) ->
935 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
936 (function p
-> Ast0.ParamTag p
)
938 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
940 if not
(checks_needed
) or not
(context_required
) or is_context p
942 match (up
,Ast0.unwrap p
) with
943 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
944 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
945 conjunct_bindings (match_typeC tya tyb
)
946 (match_option match_ident ida idb
)
947 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
948 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
949 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
950 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
951 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
952 match_param parama paramb
953 | (_
,Ast0.OptParam
(paramb
))
954 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
956 else return_false (ContextRequired
(Ast0.ParamTag p
))
958 and match_statement pattern s
=
959 match Ast0.unwrap pattern
with
960 Ast0.MetaStmt
(name
,pure
) ->
961 (match Ast0.unwrap s
with
962 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
963 return false (* ... is not a single statement *)
965 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
966 (function ty
-> Ast0.StmtTag ty
)
968 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
970 if not
(checks_needed
) or not
(context_required
) or is_context s
972 match (up
,Ast0.unwrap s
) with
973 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
974 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
975 conjunct_many_bindings
976 [check_mcode lp1 lp
; check_mcode rp1 rp
;
977 check_mcode lb1 lb
; check_mcode rb1 rb
;
978 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
979 match_dots match_param
is_plist_matcher do_plist_match
981 match_dots match_statement
is_slist_matcher do_slist_match
983 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
984 match_decl decla declb
985 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
986 (* seqs can only match if they are all minus (plus code
987 allowed) or all context (plus code not allowed in the body).
988 we could be more permissive if the expansions of the isos are
989 also all seqs, but this would be hard to check except at top
990 level, and perhaps not worth checking even in that case.
991 Overall, the issue is that braces are used where single
992 statements are required, and something not satisfying these
993 conditions can cause a single statement to become a
994 non-single statement after the transformation.
996 example: if { ... -foo(); ... }
997 if we let the sequence convert to just -foo();
998 then we produce invalid code. For some reason,
999 single_statement can't deal with this case, perhaps because
1000 it starts introducing too many braces? don't remember the
1003 conjunct_bindings (check_mcode lb1 lb
)
1004 (conjunct_bindings (check_mcode rb1 rb
)
1005 (if not
(checks_needed
) or is_minus s
or
1007 List.for_all
is_pure_context (Ast0.undots bodyb
))
1009 match_dots match_statement
is_slist_matcher do_slist_match
1011 else return_false (Braces
(s
))))
1012 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1013 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1014 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1015 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1016 conjunct_many_bindings
1017 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1018 check_mcode rp1 rp2
;
1019 match_expr expa expb
;
1020 match_statement branch1a branch1b
]
1021 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1022 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1023 conjunct_many_bindings
1024 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1025 check_mcode rp1 rp2
; check_mcode e1 e2
;
1026 match_expr expa expb
;
1027 match_statement branch1a branch1b
;
1028 match_statement branch2a branch2b
]
1029 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1030 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1031 conjunct_many_bindings
1032 [check_mcode w1 w
; check_mcode lp1 lp
;
1033 check_mcode rp1 rp
; match_expr expa expb
;
1034 match_statement bodya bodyb
]
1035 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1036 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1037 conjunct_many_bindings
1038 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1039 check_mcode rp1 rp
; match_statement bodya bodyb
;
1040 match_expr expa expb
]
1041 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1042 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1043 conjunct_many_bindings
1044 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1045 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1046 match_option match_expr e1a e1b
;
1047 match_option match_expr e2a e2b
;
1048 match_option match_expr e3a e3b
;
1049 match_statement bodya bodyb
]
1050 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1051 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1052 conjunct_many_bindings
1053 [match_ident nma nmb
;
1054 check_mcode lp1 lp
; check_mcode rp1 rp
;
1055 match_dots match_expr is_elist_matcher do_elist_match
1057 match_statement bodya bodyb
]
1058 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1059 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1060 conjunct_many_bindings
1061 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1062 check_mcode lb1 lb
; check_mcode rb1 rb
;
1063 match_expr expa expb
;
1064 match_dots match_statement
is_slist_matcher do_slist_match
1066 match_dots match_case_line
no_list do_nolist_match
1068 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1069 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1070 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1071 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1072 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1073 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1074 conjunct_many_bindings
1075 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1076 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1077 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1078 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1079 conjunct_many_bindings
1080 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1081 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1082 failwith
"disj not supported in patterns"
1083 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1084 failwith
"nest not supported in patterns"
1085 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1086 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1087 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1088 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1089 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1090 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1091 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1092 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1094 [] -> check_mcode d d1
1096 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1097 if dots_whencode_allowed
1099 conjunct_bindings (check_mcode d d1
)
1103 | Ast0.WhenNot wc
->
1104 conjunct_bindings prev
1105 (add_multi_dot_binding d
1106 (Ast0.DotsStmtTag wc
))
1107 | Ast0.WhenAlways wc
->
1108 conjunct_bindings prev
1109 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1110 | Ast0.WhenNotTrue wc
->
1111 conjunct_bindings prev
1112 (add_multi_dot_binding d
1113 (Ast0.IsoWhenTTag wc
))
1114 | Ast0.WhenNotFalse wc
->
1115 conjunct_bindings prev
1116 (add_multi_dot_binding d
1117 (Ast0.IsoWhenFTag wc
))
1118 | Ast0.WhenModifier
(x) ->
1119 conjunct_bindings prev
1120 (add_multi_dot_binding d
1121 (Ast0.IsoWhenTag
x)))
1125 "warning: not applying iso because of whencode";
1127 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1128 | (Ast0.Stars
(_
,_
::_
),_
) ->
1129 failwith
"whencode not allowed in a pattern3"
1130 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1131 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1132 match_statement rea reb
1133 | (_
,Ast0.OptStm
(reb
))
1134 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1136 else return_false (ContextRequired
(Ast0.StmtTag s
))
1138 (* first should provide a subset of the information in the second *)
1139 and match_fninfo patterninfo cinfo
=
1140 let patterninfo = List.sort compare
patterninfo in
1141 let cinfo = List.sort compare
cinfo in
1142 let rec loop = function
1143 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1144 if mcode_equal sta stb
1145 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1147 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1148 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1149 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1150 if mcode_equal ia ib
1151 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1153 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1154 if mcode_equal ia ib
1155 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1157 | (x::resta
,((y
::_
) as restb
)) ->
1158 (match compare
x y
with
1160 | 1 -> loop (resta
,restb
)
1161 | _
-> failwith
"not possible")
1162 | _
-> return false in
1163 loop (patterninfo,cinfo)
1165 and match_case_line pattern c
=
1166 if not
(checks_needed
) or not
(context_required
) or is_context c
1168 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1169 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1170 conjunct_many_bindings
1171 [check_mcode d1 d
; check_mcode c1 c
;
1172 match_dots match_statement
is_slist_matcher do_slist_match
1174 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1175 conjunct_many_bindings
1176 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1177 match_dots match_statement
is_slist_matcher do_slist_match
1179 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1180 failwith
"not allowed in the pattern of an isomorphism"
1181 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1182 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1184 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1186 let match_statement_dots x y
=
1187 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1189 (match_expr, match_decl
, match_statement
, match_typeC
,
1190 match_statement_dots)
1192 let match_expr dochecks context_required whencode_allowed
=
1193 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1196 let match_decl dochecks context_required whencode_allowed
=
1197 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1200 let match_statement dochecks context_required whencode_allowed
=
1201 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1204 let match_typeC dochecks context_required whencode_allowed
=
1205 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1208 let match_statement_dots dochecks context_required whencode_allowed
=
1209 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1212 (* --------------------------------------------------------------------- *)
1213 (* make an entire tree MINUS *)
1216 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1218 match mcodekind
with
1221 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1222 | _
-> failwith
"make_minus: unexpected befaft")
1223 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1224 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1225 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1227 let update_mc mcodekind e
=
1228 match !mcodekind
with
1231 (Ast.NOTHING
,_
,_
) ->
1232 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1233 | _
-> failwith
"make_minus: unexpected befaft")
1234 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1235 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1236 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1238 let donothing r k e
=
1239 let mcodekind = Ast0.get_mcodekind_ref e
in
1240 let e = k
e in update_mc mcodekind e; e in
1242 (* special case for whencode, because it isn't processed by contextneg,
1243 since it doesn't appear in the + code *)
1244 (* cases for dots and nests *)
1245 let expression r k
e =
1246 let mcodekind = Ast0.get_mcodekind_ref
e in
1247 match Ast0.unwrap
e with
1248 Ast0.Edots
(d
,whencode
) ->
1249 (*don't recurse because whencode hasn't been processed by context_neg*)
1250 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1251 | Ast0.Ecircles
(d
,whencode
) ->
1252 (*don't recurse because whencode hasn't been processed by context_neg*)
1253 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1254 | Ast0.Estars
(d
,whencode
) ->
1255 (*don't recurse because whencode hasn't been processed by context_neg*)
1256 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1257 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1258 update_mc mcodekind e;
1260 (Ast0.NestExpr
(mcode starter
,
1261 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1262 mcode ender
,whencode
,multi
))
1263 | _
-> donothing r k
e in
1265 let declaration r k
e =
1266 let mcodekind = Ast0.get_mcodekind_ref
e in
1267 match Ast0.unwrap
e with
1268 Ast0.Ddots
(d
,whencode
) ->
1269 (*don't recurse because whencode hasn't been processed by context_neg*)
1270 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1271 | _
-> donothing r k
e in
1273 let statement r k
e =
1274 let mcodekind = Ast0.get_mcodekind_ref
e in
1275 match Ast0.unwrap
e with
1276 Ast0.Dots
(d
,whencode
) ->
1277 (*don't recurse because whencode hasn't been processed by context_neg*)
1278 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1279 | Ast0.Circles
(d
,whencode
) ->
1280 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1281 | Ast0.Stars
(d
,whencode
) ->
1282 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1283 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1284 update_mc mcodekind e;
1287 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1288 mcode ender
,whencode
,multi
))
1289 | _
-> donothing r k
e in
1291 let initialiser r k
e =
1292 let mcodekind = Ast0.get_mcodekind_ref
e in
1293 match Ast0.unwrap
e with
1294 Ast0.Idots
(d
,whencode
) ->
1295 (*don't recurse because whencode hasn't been processed by context_neg*)
1296 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1297 | _
-> donothing r k
e in
1300 let info = Ast0.get_info
e in
1301 let mcodekind = Ast0.get_mcodekind_ref
e in
1302 match Ast0.unwrap
e with
1304 (* if context is - this should be - as well. There are no tokens
1305 here though, so the bottom-up minusifier in context_neg leaves it
1306 as mixed (or context for sgrep2). It would be better to fix
1307 context_neg, but that would
1308 require a special case for each term with a dots subterm. *)
1309 (match !mcodekind with
1310 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1312 (Ast.NOTHING
,_
,_
) ->
1313 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1315 | _
-> failwith
"make_minus: unexpected befaft")
1316 (* code already processed by an enclosing iso *)
1317 | Ast0.MINUS
(mc
) -> e
1321 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1322 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1323 | _
-> donothing r k
e in
1326 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1327 dots dots dots dots dots dots
1328 donothing expression donothing initialiser donothing declaration
1329 statement donothing donothing
1331 (* --------------------------------------------------------------------- *)
1332 (* rebuild mcode cells in an instantiated alt *)
1334 (* mcodes will be side effected later with plus code, so we have to copy
1335 them on instantiating an isomorphism. One could wonder whether it would
1336 be better not to use side-effects, but they are convenient for insert_plus
1337 where is it useful to manipulate a list of the mcodes but side-effect a
1339 (* hmm... Insert_plus is called before Iso_pattern... *)
1340 let rebuild_mcode start_line
=
1341 let copy_mcodekind = function
1342 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1343 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1344 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1345 | Ast0.PLUS count
->
1346 (* this function is used elsewhere where we need to rebuild the
1347 indices, and so we allow PLUS code as well *)
1350 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1352 match start_line
with
1355 {info.Ast0.pos_info
with
1356 Ast0.line_start
= x;
1357 Ast0.line_end
= x; } in
1358 {info with Ast0.pos_info
= new_pos_info}
1360 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1363 let old_info = Ast0.get_info
x in
1365 match start_line
with
1368 {old_info.Ast0.pos_info
with
1369 Ast0.line_start
= x;
1370 Ast0.line_end
= x; } in
1371 {old_info with Ast0.pos_info
= new_pos_info}
1372 | None
-> old_info in
1373 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1374 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1376 let donothing r k
e = copy_one (k
e) in
1378 (* case for control operators (if, etc) *)
1379 let statement r k
e =
1384 (match Ast0.unwrap
s with
1385 Ast0.Decl
((info,mc
),decl
) ->
1386 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1387 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1388 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1389 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1390 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1391 (info,copy_mcodekind mc
))
1392 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1393 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1394 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1395 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1396 (info,copy_mcodekind mc
))
1397 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1398 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1400 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1402 ((info,copy_mcodekind mc
),
1403 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1405 Ast0.set_dots_bef_aft
res
1406 (match Ast0.get_dots_bef_aft
res with
1407 Ast0.NoDots
-> Ast0.NoDots
1408 | Ast0.AddingBetweenDots
s ->
1409 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1410 | Ast0.DroppingBetweenDots
s ->
1411 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1414 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1415 donothing donothing donothing donothing donothing donothing
1416 donothing donothing donothing donothing donothing
1417 donothing statement donothing donothing
1419 (* --------------------------------------------------------------------- *)
1420 (* The problem of whencode. If an isomorphism contains dots in multiple
1421 rules, then the code that is matched cannot contain whencode, because we
1422 won't know which dots it goes with. Should worry about nests, but they
1423 aren't allowed in isomorphisms for the moment. *)
1426 let option_default = 0 in
1427 let bind x y
= x + y
in
1429 match Ast0.unwrap
e with
1430 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1433 V0.combiner
bind option_default
1434 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1437 let option_default = 0 in
1438 let bind x y
= x + y
in
1440 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1442 V0.combiner
bind option_default
1443 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1446 let option_default = 0 in
1447 let bind x y
= x + y
in
1449 match Ast0.unwrap
e with
1450 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1453 V0.combiner
bind option_default
1454 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1456 (* --------------------------------------------------------------------- *)
1458 let lookup name bindings mv_bindings
=
1459 try Common.Left
(List.assoc
(term name
) bindings
)
1462 (* failure is not possible anymore *)
1463 Common.Right
(List.assoc
(term name
) mv_bindings
)
1465 (* mv_bindings is for the fresh metavariables that are introduced by the
1467 let instantiate bindings mv_bindings
=
1469 match Ast0.get_pos
x with
1470 Ast0.MetaPos
(name
,_
,_
) ->
1472 match lookup name bindings mv_bindings
with
1473 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1474 | _
-> failwith
"not possible"
1475 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1477 let donothing r k
e = k
e in
1479 (* cases where metavariables can occur *)
1482 match Ast0.unwrap
e with
1483 Ast0.MetaId
(name
,constraints
,pure
) ->
1484 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1485 (match lookup name bindings mv_bindings
with
1486 Common.Left
(Ast0.IdentTag
(id
)) -> id
1487 | Common.Left
(_
) -> failwith
"not possible 1"
1488 | Common.Right
(new_mv
) ->
1491 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1492 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1493 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1496 (* case for list metavariables *)
1497 let rec elist r same_dots
= function
1500 (match Ast0.unwrap
x with
1501 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1502 failwith
"meta_expr_list in iso not supported"
1503 (*match lookup name bindings mv_bindings with
1504 Common.Left(Ast0.DotsExprTag(exp)) ->
1505 (match same_dots exp with
1507 | None -> failwith "dots put in incompatible context")
1508 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1509 | Common.Left(_) -> failwith "not possible 1"
1510 | Common.Right(new_mv) ->
1511 failwith "MetaExprList in SP not supported"*)
1512 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1513 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1515 let rec plist r same_dots
= function
1518 (match Ast0.unwrap
x with
1519 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1520 failwith
"meta_param_list in iso not supported"
1521 (*match lookup name bindings mv_bindings with
1522 Common.Left(Ast0.DotsParamTag(param)) ->
1523 (match same_dots param with
1525 | None -> failwith "dots put in incompatible context")
1526 | Common.Left(Ast0.ParamTag(param)) -> [param]
1527 | Common.Left(_) -> failwith "not possible 1"
1528 | Common.Right(new_mv) ->
1529 failwith "MetaExprList in SP not supported"*)
1530 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1531 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1533 let rec slist r same_dots
= function
1536 (match Ast0.unwrap
x with
1537 Ast0.MetaStmtList
(name
,pure
) ->
1538 (match lookup name bindings mv_bindings
with
1539 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1540 (match same_dots stm
with
1542 | None
-> failwith
"dots put in incompatible context")
1543 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1544 | Common.Left
(_
) -> failwith
"not possible 1"
1545 | Common.Right
(new_mv
) ->
1546 failwith
"MetaExprList in SP not supported")
1547 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1548 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1551 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1552 let same_circles d
=
1553 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1555 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1557 let dots list_fn r k d
=
1559 (match Ast0.unwrap d
with
1560 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1561 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1562 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1564 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1567 match Ast0.unwrap
e with
1568 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1569 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1570 (match lookup name bindings mv_bindings
with
1571 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1572 | Common.Left
(_
) -> failwith
"not possible 1"
1573 | Common.Right
(new_mv
) ->
1578 let rec renamer = function
1579 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1581 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1583 Common.Left
(Ast0.TypeCTag
(t
)) ->
1584 Ast0.ast0_type_to_type t
1586 failwith
"iso pattern: unexpected type"
1587 | Common.Right
(new_mv
) ->
1588 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1589 | Type_cocci.ConstVol
(cv
,ty
) ->
1590 Type_cocci.ConstVol
(cv
,renamer ty
)
1591 | Type_cocci.Pointer
(ty
) ->
1592 Type_cocci.Pointer
(renamer ty
)
1593 | Type_cocci.FunctionPointer
(ty
) ->
1594 Type_cocci.FunctionPointer
(renamer ty
)
1595 | Type_cocci.Array
(ty
) ->
1596 Type_cocci.Array
(renamer ty
)
1598 Some
(List.map
renamer types
) in
1601 (Ast0.set_mcode_data new_mv name
,constraints
,
1602 new_types,form
,pure
)))
1603 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1604 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1605 failwith
"metaexprlist not supported"
1606 | Ast0.Unary
(exp
,unop
) ->
1607 (match Ast0.unwrap_mcode unop
with
1608 (* propagate negation only when the propagated and the encountered
1609 negation have the same transformation, when there is nothing
1610 added to the original one, and when there is nothing added to
1611 the expression into which we are doing the propagation. This
1612 may be too conservative. *)
1615 (* k e doesn't change the outer structure of the term,
1616 only the metavars *)
1617 match Ast0.unwrap old_e
with
1618 Ast0.Unary
(exp
,_
) ->
1619 (match Ast0.unwrap exp
with
1620 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1622 | _
-> failwith
"not possible" in
1623 let nomodif = function
1628 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1630 (Ast.NOTHING
,_
,_
) -> true
1632 | _
-> failwith
"plus not possible" in
1633 let same_modif newop oldop
=
1634 (* only propagate ! is they have the same modification
1635 and no + code on the old one (the new one from the iso
1636 surely has no + code) *)
1637 match (newop
,oldop
) with
1638 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1639 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1640 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1645 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1646 (* k accumulates parens, to keep negation outside if no
1647 propagation is possible *)
1648 if nomodif (Ast0.get_mcodekind
e)
1650 match Ast0.unwrap
res with
1651 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1653 (Ast0.get_mcode_mcodekind unop
)
1654 (Ast0.get_mcode_mcodekind op
) ->
1656 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1657 | Ast0.Paren
(lp
,e1,rp
) ->
1660 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1661 | Ast0.Binary
(e1,op
,e2
) when
1663 (Ast0.get_mcode_mcodekind unop
)
1664 (Ast0.get_mcode_mcodekind op
) ->
1666 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1667 let k1 x = k
(Ast0.rewrap
e x) in
1668 (match Ast0.unwrap_mcode op
with
1669 Ast.Logical
(Ast.Inf
) ->
1670 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1671 | Ast.Logical
(Ast.Sup
) ->
1672 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1673 | Ast.Logical
(Ast.InfEq
) ->
1674 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1675 | Ast.Logical
(Ast.SupEq
) ->
1676 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1677 | Ast.Logical
(Ast.Eq
) ->
1678 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1679 | Ast.Logical
(Ast.NotEq
) ->
1680 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1681 | Ast.Logical
(Ast.AndLog
) ->
1682 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1684 negate_reb
e e2
idcont))
1685 | Ast.Logical
(Ast.OrLog
) ->
1686 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1688 negate_reb
e e2
idcont))
1692 Ast0.rewrap_mcode op
Ast.Not
)))
1693 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1694 (* use res because it is the transformed argument *)
1696 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1697 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1699 (*use e, because this might be the toplevel expression*)
1701 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1704 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1705 and negate_reb
e e1 k
=
1706 (* used when ! is propagated to multiple places, to avoid
1707 duplicating mcode cells *)
1709 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1710 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1715 | Ast0.Edots
(d
,_
) ->
1717 (match List.assoc
(dot_term d
) bindings
with
1718 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1719 | _
-> failwith
"unexpected binding")
1720 with Not_found
-> e)
1721 | Ast0.Ecircles
(d
,_
) ->
1723 (match List.assoc
(dot_term d
) bindings
with
1724 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1725 | _
-> failwith
"unexpected binding")
1726 with Not_found
-> e)
1727 | Ast0.Estars
(d
,_
) ->
1729 (match List.assoc
(dot_term d
) bindings
with
1730 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1731 | _
-> failwith
"unexpected binding")
1732 with Not_found
-> e)
1734 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1738 match Ast0.unwrap
e with
1739 Ast0.MetaType
(name
,pure
) ->
1740 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1741 (match lookup name bindings mv_bindings
with
1742 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1743 | Common.Left
(_
) -> failwith
"not possible 1"
1744 | Common.Right
(new_mv
) ->
1746 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1751 match Ast0.unwrap
e with
1752 Ast0.MetaInit
(name
,pure
) ->
1753 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1754 (match lookup name bindings mv_bindings
with
1755 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1756 | Common.Left
(_
) -> failwith
"not possible 1"
1757 | Common.Right
(new_mv
) ->
1759 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1764 match Ast0.unwrap
e with
1767 (match List.assoc
(dot_term d
) bindings
with
1768 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1769 | _
-> failwith
"unexpected binding")
1770 with Not_found
-> e)
1775 match Ast0.unwrap
e with
1776 Ast0.MetaParam
(name
,pure
) ->
1777 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1778 (match lookup name bindings mv_bindings
with
1779 Common.Left
(Ast0.ParamTag
(param)) -> param
1780 | Common.Left
(_
) -> failwith
"not possible 1"
1781 | Common.Right
(new_mv
) ->
1783 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1784 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1785 failwith
"metaparamlist not supported"
1790 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1791 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1792 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1793 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1794 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1795 | _
-> failwith
"unexpected binding" in
1799 match Ast0.unwrap
e with
1800 Ast0.MetaStmt
(name
,pure
) ->
1801 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1802 (match lookup name bindings mv_bindings
with
1803 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1804 | Common.Left
(_
) -> failwith
"not possible 1"
1805 | Common.Right
(new_mv
) ->
1807 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1808 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1814 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1815 | Ast0.Circles
(d
,_
) ->
1820 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1821 | Ast0.Stars
(d
,_
) ->
1826 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1830 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1831 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1832 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1834 (* --------------------------------------------------------------------- *)
1837 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1839 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1841 let disj_fail bindings
e =
1843 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1846 (* isomorphism code is by default CONTEXT *)
1847 let merge_plus model_mcode e_mcode
=
1848 match model_mcode
with
1850 (* add the replacement information at the root *)
1854 (match (!mc
,!emc
) with
1855 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1856 | _
-> failwith
"how can we combine minuses?")
1857 | _
-> failwith
"not possible 6")
1858 | Ast0.CONTEXT
(mc
) ->
1860 Ast0.CONTEXT
(emc
) ->
1861 (* keep the logical line info as in the model *)
1862 let (mba
,tb
,ta
) = !mc
in
1863 let (eba
,_
,_
) = !emc
in
1864 (* merging may be required when a term is replaced by a subterm *)
1866 match (mba
,eba
) with
1867 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1868 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1869 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1870 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1871 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1872 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1873 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1874 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1875 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1876 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1877 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1878 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1879 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1880 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1881 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1882 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1883 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1884 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1885 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1886 emc
:= (merged,tb
,ta
)
1887 | Ast0.MINUS
(emc
) ->
1888 let (anything_bef_aft
,_
,_
) = !mc
in
1889 let (anythings
,t
) = !emc
in
1891 (match anything_bef_aft
with
1892 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1893 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1894 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1895 | Ast.NOTHING
-> (anythings
,t
))
1896 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1897 | _
-> failwith
"not possible 7")
1898 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1899 | Ast0.PLUS _
-> failwith
"not possible 9"
1901 let copy_plus printer minusify model
e =
1902 if !Flag.sgrep_mode2
1903 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1907 match Ast0.get_mcodekind model
with
1908 Ast0.MINUS
(mc
) -> minusify
e
1909 | Ast0.CONTEXT
(mc
) -> e
1910 | _
-> failwith
"not possible: copy_plus\n" in
1911 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1915 let copy_minus printer minusify model
e =
1916 match Ast0.get_mcodekind model
with
1917 Ast0.MINUS
(mc
) -> minusify
e
1918 | Ast0.CONTEXT
(mc
) -> e
1920 if !Flag.sgrep_mode2
1922 else failwith
"not possible 8"
1923 | Ast0.PLUS _
-> failwith
"not possible 9"
1925 let whencode_allowed prev_ecount prev_icount prev_dcount
1926 ecount icount dcount rest
=
1927 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1929 let other_ecount = (* number of edots *)
1930 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1932 let other_icount = (* number of dots *)
1933 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1935 let other_dcount = (* number of dots *)
1936 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1938 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1939 dcount
= 0 or other_dcount = 0)
1941 (* copy the befores and afters to the instantiated code *)
1942 let extra_copy_stmt_plus model
e =
1943 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1945 (match Ast0.unwrap model
with
1946 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1947 | Ast0.Decl
((info,bef
),_
) ->
1948 (match Ast0.unwrap
e with
1949 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1950 | Ast0.Decl
((info,bef1
),_
) ->
1952 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1953 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1954 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1955 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1956 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1957 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1958 (match Ast0.unwrap
e with
1959 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1960 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1961 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1962 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1963 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1965 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1969 let extra_copy_other_plus model
e = e
1971 (* --------------------------------------------------------------------- *)
1973 let mv_count = ref 0
1975 let ct = !mv_count in
1976 mv_count := !mv_count + 1;
1977 "_"^
s^
"_"^
(string_of_int
ct)
1979 let get_name = function
1980 Ast.MetaIdDecl
(ar
,nm) ->
1981 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
1982 | Ast.MetaFreshIdDecl
(nm,seed
) ->
1983 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
1984 | Ast.MetaTypeDecl
(ar
,nm) ->
1985 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
1986 | Ast.MetaInitDecl
(ar
,nm) ->
1987 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
1988 | Ast.MetaListlenDecl
(nm) ->
1989 failwith
"should not be rebuilt"
1990 | Ast.MetaParamDecl
(ar
,nm) ->
1991 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
1992 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
1993 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
1994 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
1995 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
1996 | Ast.MetaErrDecl
(ar
,nm) ->
1997 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
1998 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
1999 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2000 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2001 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2002 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2003 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2004 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2005 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2006 | Ast.MetaStmDecl
(ar
,nm) ->
2007 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2008 | Ast.MetaStmListDecl
(ar
,nm) ->
2009 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2010 | Ast.MetaFuncDecl
(ar
,nm) ->
2011 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2012 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2013 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2014 | Ast.MetaPosDecl
(ar
,nm) ->
2015 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2016 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2017 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2018 | Ast.MetaIteratorDecl
(ar
,nm) ->
2019 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2021 let make_new_metavars metavars bindings
=
2025 let (s,_
) = get_name mv
in
2026 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2031 let (s,rebuild
) = get_name mv
in
2032 let new_s = (!current_rule,new_mv s) in
2033 (rebuild
new_s, (s,new_s)))
2036 (* --------------------------------------------------------------------- *)
2038 let do_nothing x = x
2040 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2041 rebuild_mcodes name printer extra_plus update_others has_context
=
2042 let call_instantiate bindings mv_bindings alts has_context
=
2045 (function (a
,_,_,_) ->
2047 (* no need to create duplicates when the bindings have no effect *)
2049 (function bindings
->
2051 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2053 if has_context
(* ie if pat is not just a metavara *)
2055 copy_plus printer minusify
e (extra_plus
e instantiated)
2056 else instantiated in
2057 Ast0.set_iso
plus_added
2058 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2061 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2062 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2063 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2065 whencode_allowed prev_ecount prev_icount prev_dcount
2066 ecount dcount icount rest
in
2067 (match matcher
true (context_required e) wc pattern
e init_env with
2069 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2072 (match matcher
false false wc pattern
e init_env with
2074 interpret_reason name
(Ast0.get_line
e) reason
2075 (function () -> printer
e)
2077 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2078 (prev_dcount
+ dcount
) rest
2079 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2081 (* apply update_others to all patterns other than the matched
2082 one. This is used to desigate the others as test
2083 expressions in the TestExpression case *)
2085 (function (x,e,i
,d
) as all
->
2088 else (update_others
x,e,i
,d
))
2089 (List.hd
all_alts)) ::
2091 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2092 (List.tl
all_alts)) in
2093 (match List.concat
all_alts with
2094 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2096 let (new_metavars,mv_bindings
) =
2097 make_new_metavars metavars
(nub(List.concat bindings
)) in
2100 call_instantiate bindings mv_bindings
all_alts
2101 (has_context pattern
)))) in
2102 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2103 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2104 | (alts
::rest
) as all_alts ->
2105 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2106 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2107 outer_loop prev_ecount prev_icount prev_dcount rest
2108 | Common.Right
(new_metavars,res) ->
2110 copy_minus printer minusify
e (disj_maker
res)) in
2111 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2112 (count
, metavars
, e)
2114 (* no one should ever look at the information stored in these mcodes *)
2115 let disj_starter lst
=
2116 let old_info = Ast0.get_info
(List.hd lst
) in
2118 { old_info.Ast0.pos_info
with
2119 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2120 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2122 { Ast0.pos_info
= new_pos_info;
2123 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2124 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2125 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2126 Ast0.make_mcode_info
"(" info
2128 let disj_ender lst
=
2129 let old_info = Ast0.get_info
(List.hd lst
) in
2131 { old_info.Ast0.pos_info
with
2132 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2133 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2135 { Ast0.pos_info
= new_pos_info;
2136 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2137 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2138 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2139 Ast0.make_mcode_info
")" info
2141 let disj_mid _ = Ast0.make_mcode
"|"
2143 let make_disj_type tl
=
2146 [] -> failwith
"bad disjunction"
2147 | x::xs
-> List.map
disj_mid xs
in
2148 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2149 let make_disj_stmt_list tl
=
2152 [] -> failwith
"bad disjunction"
2153 | x::xs
-> List.map
disj_mid xs
in
2154 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2155 let make_disj_expr model el
=
2158 [] -> failwith
"bad disjunction"
2159 | x::xs
-> List.map
disj_mid xs
in
2161 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2163 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2164 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2165 let el = List.map
update_arg (List.map
update_test el) in
2166 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2167 let make_disj_decl dl
=
2170 [] -> failwith
"bad disjunction"
2171 | x::xs
-> List.map
disj_mid xs
in
2172 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2173 let make_disj_stmt sl
=
2174 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2177 [] -> failwith
"bad disjunction"
2178 | x::xs
-> List.map
disj_mid xs
in
2180 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2182 let transform_type (metavars
,alts
,name
) e =
2184 (Ast0.TypeCTag
(_)::_)::_ ->
2185 (* start line is given to any leaves in the iso code *)
2187 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2193 (p
,count_edots.VT0.combiner_rec_typeC p
,
2194 count_idots.VT0.combiner_rec_typeC p
,
2195 count_dots.VT0.combiner_rec_typeC p
)
2196 | _ -> failwith
"invalid alt"))
2198 mkdisj match_typeC metavars
alts e
2199 (function b
-> function mv_b
->
2200 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2201 (function t
-> Ast0.TypeCTag t
)
2202 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2203 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2204 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2206 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2210 let transform_expr (metavars
,alts,name
) e =
2211 let process update_others
=
2212 (* start line is given to any leaves in the iso code *)
2214 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2219 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2220 (p
,count_edots.VT0.combiner_rec_expression p
,
2221 count_idots.VT0.combiner_rec_expression p
,
2222 count_dots.VT0.combiner_rec_expression p
)
2223 | _ -> failwith
"invalid alt"))
2225 mkdisj match_expr metavars
alts e
2226 (function b
-> function mv_b
->
2227 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2228 (function e -> Ast0.ExprTag
e)
2230 make_minus.VT0.rebuilder_rec_expression
2231 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2232 name
Unparse_ast0.expression extra_copy_other_plus update_others
2234 match Ast0.unwrap
x with
2235 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2239 (Ast0.ExprTag
(_)::r
)::rs
->
2240 (* hack to accomodate ToTestExpression case, where the first pattern is
2241 a normal expression, but the others are test expressions *)
2242 let others = r
@ (List.concat rs
) in
2243 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2244 if List.for_all
is_test others then process Ast0.set_test_exp
2245 else if List.exists
is_test others then failwith
"inconsistent iso"
2246 else process do_nothing
2247 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2248 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2249 process Ast0.set_test_exp
2252 let transform_decl (metavars
,alts,name
) e =
2254 (Ast0.DeclTag
(_)::_)::_ ->
2255 (* start line is given to any leaves in the iso code *)
2257 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2263 (p
,count_edots.VT0.combiner_rec_declaration p
,
2264 count_idots.VT0.combiner_rec_declaration p
,
2265 count_dots.VT0.combiner_rec_declaration p
)
2266 | _ -> failwith
"invalid alt"))
2268 mkdisj match_decl metavars
alts e
2269 (function b
-> function mv_b
->
2270 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2271 (function d
-> Ast0.DeclTag d
)
2273 make_minus.VT0.rebuilder_rec_declaration
2274 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2275 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2276 (function _ -> true (* no metavars *))
2279 let transform_stmt (metavars
,alts,name
) e =
2281 (Ast0.StmtTag
(_)::_)::_ ->
2282 (* start line is given to any leaves in the iso code *)
2284 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2290 (p
,count_edots.VT0.combiner_rec_statement p
,
2291 count_idots.VT0.combiner_rec_statement p
,
2292 count_dots.VT0.combiner_rec_statement p
)
2293 | _ -> failwith
"invalid alt"))
2295 mkdisj match_statement metavars
alts e
2296 (function b
-> function mv_b
->
2297 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2298 (function s -> Ast0.StmtTag
s)
2299 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2300 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2301 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2303 match Ast0.unwrap
x with
2304 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2308 (* sort of a hack, because there is no disj at top level *)
2309 let transform_top (metavars
,alts,name
) e =
2310 match Ast0.unwrap
e with
2311 Ast0.DECL
(declstm
) ->
2317 Ast0.DotsStmtTag
(d
) ->
2318 (match Ast0.unwrap d
with
2319 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2320 | _ -> raise
(Failure
""))
2321 | _ -> raise
(Failure
"")))
2323 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2324 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2325 with Failure
_ -> (0,[],e))
2326 | Ast0.CODE
(stmts
) ->
2327 let (count
,mv
,res) =
2329 (Ast0.DotsStmtTag
(_)::_)::_ ->
2330 (* start line is given to any leaves in the iso code *)
2332 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2337 Ast0.DotsStmtTag
(p
) ->
2338 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2339 count_idots.VT0.combiner_rec_statement_dots p
,
2340 count_dots.VT0.combiner_rec_statement_dots p
)
2341 | _ -> failwith
"invalid alt"))
2343 mkdisj match_statement_dots metavars
alts stmts
2344 (function b
-> function mv_b
->
2345 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2346 (function s -> Ast0.DotsStmtTag
s)
2348 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2350 make_minus.VT0.rebuilder_rec_statement_dots
x)
2351 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2352 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2353 (function _ -> true)
2354 | _ -> (0,[],stmts
) in
2355 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2358 (* --------------------------------------------------------------------- *)
2360 let transform (alts : isomorphism
) t
=
2361 (* the following ugliness is because rebuilder only returns a new term *)
2362 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2363 let in_limit n
= function
2367 ((if !Flag_parsing_cocci.show_iso_failures
2368 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2370 let bind x y
= x + y
in
2371 let option_default = 0 in
2373 let (e_count
,e) = k
e in
2374 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2376 let (count
,extra_meta
,exp
) = transform_expr alts e in
2377 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2378 (bind count e_count
,exp
)
2382 let (e_count
,e) = k
e in
2383 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2385 let (count
,extra_meta
,dec
) = transform_decl alts e in
2386 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2387 (bind count e_count
,dec
)
2391 let (e_count
,e) = k
e in
2392 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2394 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2395 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2396 (bind count e_count
,stm
)
2400 let (continue
,e_count
,e) =
2401 match Ast0.unwrap
e with
2402 Ast0.Signed
(signb
,tyb
) ->
2403 (* Hack! How else to prevent iso from applying under an
2407 let (e_count
,e) = k
e in
2408 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2409 then (true,e_count
,e)
2410 else (false,e_count
,e) in
2413 let (count
,extra_meta
,ty
) = transform_type alts e in
2414 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2415 (bind count e_count
,ty
)
2419 let (e_count
,e) = k
e in
2420 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2422 let (count
,extra_meta
,ty
) = transform_top alts e in
2423 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2424 (bind count e_count
,ty
)
2428 V0.combiner_rebuilder
bind option_default
2429 {V0.combiner_rebuilder_functions
with
2430 VT0.combiner_rebuilder_exprfn
= exprfn;
2431 VT0.combiner_rebuilder_tyfn
= typefn;
2432 VT0.combiner_rebuilder_declfn
= declfn;
2433 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2434 VT0.combiner_rebuilder_topfn
= topfn} in
2435 let (_,res) = res.VT0.top_level t
in
2436 (!extra_meta_decls,res)
2438 (* --------------------------------------------------------------------- *)
2440 (* should be done by functorizing the parser to use wrap or context_wrap *)
2442 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2443 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2445 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2446 donothing donothing donothing donothing donothing donothing
2447 donothing donothing donothing donothing donothing donothing donothing
2450 let rewrap_anything = function
2451 Ast0.DotsExprTag
(d
) ->
2452 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2453 | Ast0.DotsInitTag
(d
) ->
2454 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2455 | Ast0.DotsParamTag
(d
) ->
2456 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2457 | Ast0.DotsStmtTag
(d
) ->
2458 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2459 | Ast0.DotsDeclTag
(d
) ->
2460 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2461 | Ast0.DotsCaseTag
(d
) ->
2462 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2463 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2464 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2465 | Ast0.ArgExprTag
(d
) ->
2466 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2467 | Ast0.TestExprTag
(d
) ->
2468 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2469 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2470 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2471 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2472 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2473 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2474 | Ast0.CaseLineTag
(d
) ->
2475 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2476 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2477 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2478 failwith
"only for isos within iso phase"
2479 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2481 (* --------------------------------------------------------------------- *)
2483 let apply_isos isos rule rule_name
=
2488 current_rule := rule_name
;
2491 (function (metavars
,iso
,name
) ->
2492 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2494 let (extra_meta
,rule
) =
2499 (function (extra_meta
,t
) -> function iso
->
2500 let (new_extra_meta
,t
) = transform iso t
in
2501 (new_extra_meta
@extra_meta
,t
))
2504 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)