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 | Nest
of Ast0.statement
129 | Position
of Ast.meta_name
130 | TypeMatch
of reason list
132 let rec interpret_reason name line reason printer
=
134 "warning: iso %s does not match the code below on line %d\n" name line
;
135 printer
(); Format.print_newline
();
137 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
139 "pure metavariable %s is matched against the following nonpure code:\n"
141 Unparse_ast0.unparse_anything nonpure
142 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
144 "context metavariable %s is matched against the following\nnoncontext code:\n"
146 Unparse_ast0.unparse_anything nonpure
147 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
149 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
151 Unparse_ast0.unparse_anything nonpure
152 | NotPureLength
((_
,var
)) ->
154 "pure metavariable %s is matched against too much or too little code\n"
156 | ContextRequired
(term) ->
158 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
159 Unparse_ast0.unparse_anything
term
161 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
162 Unparse_ast0.statement
"" s
;
163 Format.print_newline
()
165 Printf.printf
"iso with nest doesn't match whencode (TODO):\n";
166 Unparse_ast0.statement
"" s
;
167 Format.print_newline
()
168 | Position
(rule
,name
) ->
169 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
171 | TypeMatch reason_list
->
172 List.iter
(function r
-> interpret_reason name line r printer
)
174 | _
-> failwith
"not possible"
176 type 'a either
= OK
of 'a
| Fail
of reason
178 let add_binding var exp bindings
=
179 let var = term var in
180 let attempt bindings
=
182 let cur = List.assoc
var bindings
in
183 if anything_equal(exp
,cur) then [bindings
] else []
184 with Not_found
-> [((var,exp
)::bindings
)] in
185 match List.concat
(List.map
attempt bindings
) with
189 let add_dot_binding var exp bindings
=
190 let var = dot_term var in
191 let attempt bindings
=
193 let cur = List.assoc
var bindings
in
194 if anything_equal(exp
,cur) then [bindings
] else []
195 with Not_found
-> [((var,exp
)::bindings
)] in
196 match List.concat
(List.map
attempt bindings
) with
201 let add_multi_dot_binding var exp bindings
=
202 let var = dot_term var in
203 let attempt bindings
= [((var,exp
)::bindings
)] in
204 match List.concat
(List.map
attempt bindings
) with
211 | (x::xs
) when (List.mem
x xs
) -> nub xs
212 | (x::xs
) -> x::(nub xs
)
214 (* --------------------------------------------------------------------- *)
218 let debug str m binding
=
219 let res = m binding
in
221 None
-> Printf.printf
"%s: failed\n" str
225 Printf.printf
"%s: %s\n" str
226 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
230 let conjunct_bindings
231 (m1
: 'binding
-> 'binding either
)
232 (m2
: 'binding
-> 'binding either
)
233 (binding
: 'binding
) : 'binding either
=
234 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
236 let rec conjunct_many_bindings = function
237 [] -> failwith
"not possible"
239 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
241 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
243 let return b binding
= if b
then OK binding
else Fail NonMatch
244 let return_false reason binding
= Fail reason
246 let match_option f t1 t2
=
248 (Some t1
, Some t2
) -> f t1 t2
249 | (None
, None
) -> return true
252 let bool_match_option f t1 t2
=
254 (Some t1
, Some t2
) -> f t1 t2
255 | (None
, None
) -> true
258 (* context_required is for the example
262 where we can't change x == NULL to eg NULL == x. So there can either be
263 nothing attached to the root or the term has to be all removed.
264 if would be nice if we knew more about the relationship between the - and +
265 code, because in the case where the + code is a separate statement in a
266 sequence, this is not a problem. Perhaps something could be done in
269 The example seems strange. Why isn't the cast attached to x?
272 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
273 (match Ast0.get_mcodekind e
with
274 Ast0.CONTEXT
(cell
) -> true
277 (* needs a special case when there is a Disj or an empty DOTS
278 the following stops at the statement level, and gives true if one
279 statement is replaced by another *)
280 let rec is_pure_context s
=
281 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
282 (match Ast0.unwrap s
with
283 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
286 match Ast0.undots
x with
287 [s
] -> is_pure_context s
288 | _
-> false (* could we do better? *))
291 (match Ast0.get_mcodekind s
with
294 (Ast.NOTHING
,_
,_
) -> true
298 (* do better for the common case of replacing a stmt by another one *)
299 ([[Ast.StatementTag
(s
)]],_
) ->
300 (match Ast.unwrap s
with
301 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
307 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
309 let match_list matcher is_list_matcher do_list_match la lb
=
310 let rec loop = function
311 ([],[]) -> return true
312 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
313 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
314 | _
-> return false in
317 let all_caps = Str.regexp
"^[A-Z_][A-Z_0-9]*$"
319 let match_maker checks_needed context_required whencode_allowed
=
321 let check_mcode pmc cmc binding
=
324 match Ast0.get_pos cmc
with
325 (Ast0.MetaPos
(name
,_
,_
)) as x ->
326 (match Ast0.get_pos pmc
with
327 Ast0.MetaPos
(name1
,_
,_
) ->
328 add_binding name1
(Ast0.MetaPosTag
x) binding
330 let (rule
,name
) = Ast0.unwrap_mcode name
in
331 Fail
(Position
(rule
,name
)))
332 | Ast0.NoMetaPos
-> OK binding
335 let match_dots matcher is_list_matcher do_list_match d1 d2
=
336 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
337 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
338 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
339 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
340 match_list matcher is_list_matcher
(do_list_match d2
) la lb
341 | _
-> return false in
343 let is_elist_matcher el
=
344 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
346 let is_plist_matcher pl
=
347 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
349 let is_slist_matcher pl
=
350 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
352 let no_list _
= false in
354 let build_dots pattern data
=
355 match Ast0.unwrap pattern
with
356 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
357 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
358 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
361 let bind = Ast0.lub_pure
in
362 let option_default = Ast0.Context
in
363 let pure_mcodekind mc
=
365 then Ast0.PureContext
370 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
373 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
374 | _
-> Ast0.Impure
in
375 let donothing r k e
=
376 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
378 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
380 (* a case for everything that has a metavariable *)
381 (* pure is supposed to match only unitary metavars, not anything that
382 contains only unitary metavars *)
384 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
385 (match Ast0.unwrap i
with
386 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
387 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
388 | _
-> Ast0.Impure
) in
390 let expression r k e
=
391 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
392 (match Ast0.unwrap e
with
393 Ast0.MetaErr
(name
,_
,pure
)
394 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
396 | _
-> Ast0.Impure
) in
399 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
400 (match Ast0.unwrap t
with
401 Ast0.MetaType
(name
,pure
) -> pure
402 | _
-> Ast0.Impure
) in
405 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
406 (match Ast0.unwrap t
with
407 Ast0.MetaInit
(name
,pure
) -> pure
408 | _
-> Ast0.Impure
) in
411 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
412 (match Ast0.unwrap p
with
413 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
414 | _
-> Ast0.Impure
) in
417 bind (bind (pure_mcodekind (Ast0.get_mcodekind d
)) (k d
))
418 (match Ast0.unwrap d
with
419 Ast0.MetaDecl
(name
,pure
) | Ast0.MetaField
(name
,pure
) -> pure
420 | _
-> Ast0.Impure
) in
423 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
424 (match Ast0.unwrap s
with
425 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
426 | _
-> Ast0.Impure
) in
428 V0.flat_combiner
bind option_default
429 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
430 donothing donothing donothing donothing donothing donothing
431 ident expression typeC init param decl stmt donothing
434 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
435 match (checks_needed
,pure
) with
436 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
439 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
440 then add_binding name
(builder1 lst
)
441 else return_false (NotPure
(pure
,term name
,builder1 lst
))
442 | _
-> return_false (NotPureLength
(term name
)))
443 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
445 let add_pure_binding name pure is_pure builder
x =
446 match (checks_needed
,pure
) with
447 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
448 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
449 then add_binding name
(builder
x)
450 else return_false (NotPure
(pure
,term name
, builder
x))
451 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
453 let do_elist_match builder el lst
=
454 match Ast0.unwrap el
with
455 Ast0.MetaExprList
(name
,lenname
,pure
) ->
456 (*how to handle lenname? should it be an option type and always None?*)
457 failwith
"expr list pattern not supported in iso"
458 (*add_pure_list_binding name pure
459 pure_sp_code.V0.combiner_expression
460 (function lst -> Ast0.ExprTag(List.hd lst))
461 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
463 | _
-> failwith
"not possible" in
465 let do_plist_match builder pl lst
=
466 match Ast0.unwrap pl
with
467 Ast0.MetaParamList
(name
,lename
,pure
) ->
468 failwith
"param list pattern not supported in iso"
469 (*add_pure_list_binding name pure
470 pure_sp_code.V0.combiner_parameter
471 (function lst -> Ast0.ParamTag(List.hd lst))
472 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
474 | _
-> failwith
"not possible" in
476 let do_slist_match builder sl lst
=
477 match Ast0.unwrap sl
with
478 Ast0.MetaStmtList
(name
,pure
) ->
479 add_pure_list_binding name pure
480 pure_sp_code.VT0.combiner_rec_statement
481 (function lst
-> Ast0.StmtTag
(List.hd lst
))
482 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
484 | _
-> failwith
"not possible" in
486 let do_nolist_match _ _
= failwith
"not possible" in
488 let rec match_ident pattern id
=
489 match Ast0.unwrap pattern
with
490 Ast0.MetaId
(name
,_
,pure
) ->
491 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
492 (function id
-> Ast0.IdentTag id
) id
)
493 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
494 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
496 if not
(checks_needed
) or not
(context_required
) or is_context id
498 match (up
,Ast0.unwrap id
) with
499 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
500 if mcode_equal namea nameb
501 then check_mcode namea nameb
503 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
504 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
506 | (_
,Ast0.OptIdent
(idb
))
507 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
509 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
511 (* should we do something about matching metavars against ...? *)
512 let rec match_expr pattern expr
=
513 match Ast0.unwrap pattern
with
514 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
516 match (form
,expr
) with
520 match Ast0.unwrap e
with
521 Ast0.Constant
(c
) -> true
523 (match Ast0.unwrap c
with
525 let nm = Ast0.unwrap_mcode
nm in
526 (* all caps is a const *)
527 Str.string_match
all_caps nm 0
529 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
530 | Ast0.SizeOfExpr
(se
,exp
) -> true
531 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
532 | Ast0.MetaExpr
(nm,_
,_
,Ast.CONST
,p
) ->
533 (Ast0.lub_pure p pure
) = pure
536 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
538 match Ast0.unwrap e
with
539 Ast0.Ident
(c
) -> true
540 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
541 | Ast0.MetaExpr
(nm,_
,_
,Ast.ID
,p
) ->
542 (Ast0.lub_pure p pure
) = pure
550 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
554 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
556 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
557 (* easier than updating type inferencer to manage multiple
559 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
560 | (_
,Some ty
) -> Some
[ty
]
564 let tyname = Ast0.rewrap_mcode name
tyname in
566 (add_pure_binding name pure
567 pure_sp_code.VT0.combiner_rec_expression
568 (function expr
-> Ast0.ExprTag expr
)
570 (function bindings
->
575 add_pure_binding tyname Ast0.Impure
576 (function _
-> Ast0.Impure
)
577 (function ty
-> Ast0.TypeCTag ty
)
579 (Ast0.reverse_type
expty))
583 "warning: unconvertible type";
584 return false bindings
))
587 (function Fail _
-> false | OK
x -> true)
590 (* not sure why this is ok. can there be more
594 (function Fail _
-> [] | OK
x -> x)
602 | OK
x -> failwith
"not possible")
606 "warning: type metavar can only match one type";*)
610 "mixture of metatype and other types not supported")
612 let expty = Ast0.get_type expr
in
613 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
615 add_pure_binding name pure
616 pure_sp_code.VT0.combiner_rec_expression
617 (function expr
-> Ast0.ExprTag expr
)
621 add_pure_binding name pure
622 pure_sp_code.VT0.combiner_rec_expression
623 (function expr
-> Ast0.ExprTag expr
)
626 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
627 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
629 if not
(checks_needed
) or not
(context_required
) or is_context expr
631 match (up
,Ast0.unwrap expr
) with
632 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
634 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
635 if mcode_equal consta constb
636 then check_mcode consta constb
638 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
639 conjunct_many_bindings
640 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
641 match_dots match_expr is_elist_matcher do_elist_match
643 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
644 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
645 if mcode_equal opa opb
647 conjunct_many_bindings
648 [check_mcode opa opb
; match_expr lefta leftb
;
649 match_expr righta rightb
]
651 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
652 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
653 conjunct_many_bindings
654 [check_mcode lp1 lp
; check_mcode rp1 rp
;
655 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
656 match_expr exp3a exp3b
]
657 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
658 if mcode_equal opa opb
660 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
662 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
663 if mcode_equal opa opb
665 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
667 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
668 if mcode_equal opa opb
670 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
672 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
673 if mcode_equal opa opb
675 conjunct_many_bindings
676 [check_mcode opa opb
; match_expr lefta leftb
;
677 match_expr righta rightb
]
679 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
680 conjunct_many_bindings
681 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
682 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
683 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
684 conjunct_many_bindings
685 [check_mcode lb1 lb
; check_mcode rb1 rb
;
686 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
687 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
688 Ast0.RecordAccess
(expb
,op
,fieldb
))
689 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
690 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
691 conjunct_many_bindings
692 [check_mcode opa op
; match_expr expa expb
;
693 match_ident fielda fieldb
]
694 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
695 conjunct_many_bindings
696 [check_mcode lp1 lp
; check_mcode rp1 rp
;
697 match_typeC tya tyb
; match_expr expa expb
]
698 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
699 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
700 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
701 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
702 conjunct_many_bindings
703 [check_mcode lp1 lp
; check_mcode rp1 rp
;
704 check_mcode szf1 szf
; match_typeC tya tyb
]
705 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
707 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
708 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
709 failwith
"not allowed in the pattern of an isomorphism"
710 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
711 failwith
"not allowed in the pattern of an isomorphism"
712 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
713 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
714 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
715 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
716 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
717 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
718 (* hope that mcode of edots is unique somehow *)
719 conjunct_bindings (check_mcode ed ed1
)
720 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
721 if edots_whencode_allowed
722 then add_dot_binding ed
(Ast0.ExprTag wc
)
725 "warning: not applying iso because of whencode";
727 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
728 | (Ast0.Estars
(_
,Some _
),_
) ->
729 failwith
"whencode not allowed in a pattern1"
730 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
731 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
732 | (_
,Ast0.OptExp
(expb
))
733 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
735 else return_false (ContextRequired
(Ast0.ExprTag expr
))
737 (* the special case for function types prevents the eg T X; -> T X = E; iso
738 from applying, which doesn't seem very relevant, but it also avoids a
739 mysterious bug that is obtained with eg int attach(...); *)
740 and match_typeC pattern t
=
741 match Ast0.unwrap pattern
with
742 Ast0.MetaType
(name
,pure
) ->
743 (match Ast0.unwrap t
with
744 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
746 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
747 (function ty
-> Ast0.TypeCTag ty
)
750 if not
(checks_needed
) or not
(context_required
) or is_context t
752 match (up
,Ast0.unwrap t
) with
753 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
754 if mcode_equal cva cvb
756 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
758 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
761 match_list check_mcode
762 (function _
-> false) (function _
-> failwith
"")
765 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
766 if mcode_equal signa signb
768 conjunct_bindings (check_mcode signa signb
)
769 (match_option match_typeC tya tyb
)
771 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
772 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
773 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
774 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
775 conjunct_many_bindings
776 [check_mcode stara starb
; check_mcode lp1a lp1b
;
777 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
778 check_mcode rp2a rp2b
; match_typeC tya tyb
;
779 match_dots match_param
is_plist_matcher
780 do_plist_match paramsa paramsb
]
781 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
782 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
783 conjunct_many_bindings
784 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
785 match_option match_typeC tya tyb
;
786 match_dots match_param
is_plist_matcher do_plist_match
788 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
789 conjunct_many_bindings
790 [check_mcode lb1 lb
; check_mcode rb1 rb
;
791 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
792 | (Ast0.EnumName
(kinda
,Some namea
),
793 Ast0.EnumName
(kindb
,Some nameb
)) ->
794 conjunct_bindings (check_mcode kinda kindb
)
795 (match_ident namea nameb
)
796 | (Ast0.EnumDef
(tya
,lb1
,idsa
,rb1
),
797 Ast0.EnumDef
(tyb
,lb
,idsb
,rb
)) ->
798 conjunct_many_bindings
799 [check_mcode lb1 lb
; check_mcode rb1 rb
;
801 match_dots match_expr no_list do_nolist_match idsa idsb
]
802 | (Ast0.StructUnionName
(kinda
,Some namea
),
803 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
804 if mcode_equal kinda kindb
806 conjunct_bindings (check_mcode kinda kindb
)
807 (match_ident namea nameb
)
809 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
810 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
811 conjunct_many_bindings
812 [check_mcode lb1 lb
; check_mcode rb1 rb
;
814 match_dots match_decl
no_list do_nolist_match declsa declsb
]
815 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
816 if mcode_equal namea nameb
817 then check_mcode namea nameb
819 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
820 failwith
"not allowed in the pattern of an isomorphism"
821 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
822 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
823 | (_
,Ast0.OptType
(tyb
))
824 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
826 else return_false (ContextRequired
(Ast0.TypeCTag t
))
828 and match_decl pattern d
=
829 match Ast0.unwrap pattern
with
830 Ast0.MetaDecl
(name
,pure
) ->
831 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
832 (function d
-> Ast0.DeclTag d
)
834 | Ast0.MetaField
(name
,pure
) ->
835 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_declaration
836 (function d
-> Ast0.DeclTag d
)
839 if not
(checks_needed
) or not
(context_required
) or is_context d
841 match (up
,Ast0.unwrap d
) with
842 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
843 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
844 if bool_match_option mcode_equal stga stgb
846 conjunct_many_bindings
847 [check_mcode eq1 eq
; check_mcode sc1 sc
;
848 match_option check_mcode stga stgb
;
849 match_typeC tya tyb
; match_ident ida idb
;
850 match_init inia inib
]
852 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
853 if bool_match_option mcode_equal stga stgb
855 conjunct_many_bindings
856 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
857 match_typeC tya tyb
; match_ident ida idb
]
859 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
860 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
861 conjunct_many_bindings
862 [match_ident namea nameb
;
863 check_mcode lp1 lp
; check_mcode rp1 rp
;
865 match_dots match_expr is_elist_matcher do_elist_match
867 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
868 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
869 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
870 conjunct_bindings (check_mcode sc1 sc
)
871 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
872 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
873 failwith
"not allowed in the pattern of an isomorphism"
874 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
875 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
876 conjunct_bindings (check_mcode dd d
)
877 (* hope that mcode of ddots is unique somehow *)
878 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
879 if ddots_whencode_allowed
880 then add_dot_binding dd
(Ast0.DeclTag wc
)
882 (Printf.printf
"warning: not applying iso because of whencode";
884 | (Ast0.Ddots
(_
,Some _
),_
) ->
885 failwith
"whencode not allowed in a pattern1"
887 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
888 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
889 match_decl decla declb
890 | (_
,Ast0.OptDecl
(declb
))
891 | (_
,Ast0.UniqueDecl
(declb
)) ->
892 match_decl pattern declb
894 else return_false (ContextRequired
(Ast0.DeclTag d
))
896 and match_init pattern i
=
897 match Ast0.unwrap pattern
with
898 Ast0.MetaInit
(name
,pure
) ->
899 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
900 (function ini
-> Ast0.InitTag ini
)
903 if not
(checks_needed
) or not
(context_required
) or is_context i
905 match (up
,Ast0.unwrap i
) with
906 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
908 | (Ast0.InitList
(lb1
,initlista
,rb1
,oa
),
909 Ast0.InitList
(lb
,initlistb
,rb
,ob
))
911 conjunct_many_bindings
912 [check_mcode lb1 lb
; check_mcode rb1 rb
;
913 match_dots match_init
no_list do_nolist_match
915 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
916 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
917 conjunct_many_bindings
918 [match_list match_designator
919 (function _
-> false) (function _
-> failwith
"")
920 designators1 designators2
;
922 match_init inia inib
]
923 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
924 conjunct_many_bindings
925 [check_mcode c1 c
; match_ident namea nameb
;
926 match_init inia inib
]
927 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
928 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
929 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
930 conjunct_bindings (check_mcode id d
)
931 (* hope that mcode of edots is unique somehow *)
932 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
933 if idots_whencode_allowed
934 then add_dot_binding id
(Ast0.InitTag wc
)
937 "warning: not applying iso because of whencode";
939 | (Ast0.Idots
(_
,Some _
),_
) ->
940 failwith
"whencode not allowed in a pattern2"
941 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
942 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
943 | (_
,Ast0.OptIni
(ib
))
944 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
946 else return_false (ContextRequired
(Ast0.InitTag i
))
948 and match_designator pattern d
=
949 match (pattern
,d
) with
950 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
951 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
952 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
953 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
954 conjunct_many_bindings
955 [check_mcode lba lbb
; match_expr expa expb
;
957 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
958 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
959 conjunct_many_bindings
960 [check_mcode lba lbb
; match_expr mina minb
;
961 check_mcode dotsa dotsb
; match_expr maxa maxb
;
965 and match_param pattern p
=
966 match Ast0.unwrap pattern
with
967 Ast0.MetaParam
(name
,pure
) ->
968 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
969 (function p
-> Ast0.ParamTag p
)
971 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
973 if not
(checks_needed
) or not
(context_required
) or is_context p
975 match (up
,Ast0.unwrap p
) with
976 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
977 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
978 conjunct_bindings (match_typeC tya tyb
)
979 (match_option match_ident ida idb
)
980 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
981 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
982 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
983 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
984 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
985 match_param parama paramb
986 | (_
,Ast0.OptParam
(paramb
))
987 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
989 else return_false (ContextRequired
(Ast0.ParamTag p
))
991 and match_statement pattern s
=
992 match Ast0.unwrap pattern
with
993 Ast0.MetaStmt
(name
,pure
) ->
994 (match Ast0.unwrap s
with
995 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
996 return false (* ... is not a single statement *)
998 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
999 (function ty
-> Ast0.StmtTag ty
)
1001 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1003 if not
(checks_needed
) or not
(context_required
) or is_context s
1005 match (up
,Ast0.unwrap s
) with
1006 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
1007 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
1008 conjunct_many_bindings
1009 [check_mcode lp1 lp
; check_mcode rp1 rp
;
1010 check_mcode lb1 lb
; check_mcode rb1 rb
;
1011 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
1012 match_dots match_param
is_plist_matcher do_plist_match
1014 match_dots match_statement
is_slist_matcher do_slist_match
1016 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
1017 match_decl decla declb
1018 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
1019 (* seqs can only match if they are all minus (plus code
1020 allowed) or all context (plus code not allowed in the body).
1021 we could be more permissive if the expansions of the isos are
1022 also all seqs, but this would be hard to check except at top
1023 level, and perhaps not worth checking even in that case.
1024 Overall, the issue is that braces are used where single
1025 statements are required, and something not satisfying these
1026 conditions can cause a single statement to become a
1027 non-single statement after the transformation.
1029 example: if { ... -foo(); ... }
1030 if we let the sequence convert to just -foo();
1031 then we produce invalid code. For some reason,
1032 single_statement can't deal with this case, perhaps because
1033 it starts introducing too many braces? don't remember the
1036 conjunct_bindings (check_mcode lb1 lb
)
1037 (conjunct_bindings (check_mcode rb1 rb
)
1038 (if not
(checks_needed
) or is_minus s
or
1040 List.for_all
is_pure_context (Ast0.undots bodyb
))
1042 match_dots match_statement
is_slist_matcher do_slist_match
1044 else return_false (Braces
(s
))))
1045 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1046 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1047 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1048 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1049 conjunct_many_bindings
1050 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1051 check_mcode rp1 rp2
;
1052 match_expr expa expb
;
1053 match_statement branch1a branch1b
]
1054 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1055 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1056 conjunct_many_bindings
1057 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1058 check_mcode rp1 rp2
; check_mcode e1 e2
;
1059 match_expr expa expb
;
1060 match_statement branch1a branch1b
;
1061 match_statement branch2a branch2b
]
1062 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1063 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1064 conjunct_many_bindings
1065 [check_mcode w1 w
; check_mcode lp1 lp
;
1066 check_mcode rp1 rp
; match_expr expa expb
;
1067 match_statement bodya bodyb
]
1068 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1069 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1070 conjunct_many_bindings
1071 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1072 check_mcode rp1 rp
; match_statement bodya bodyb
;
1073 match_expr expa expb
]
1074 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1075 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1076 conjunct_many_bindings
1077 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1078 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1079 match_option match_expr e1a e1b
;
1080 match_option match_expr e2a e2b
;
1081 match_option match_expr e3a e3b
;
1082 match_statement bodya bodyb
]
1083 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1084 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1085 conjunct_many_bindings
1086 [match_ident nma nmb
;
1087 check_mcode lp1 lp
; check_mcode rp1 rp
;
1088 match_dots match_expr is_elist_matcher do_elist_match
1090 match_statement bodya bodyb
]
1091 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1092 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1093 conjunct_many_bindings
1094 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1095 check_mcode lb1 lb
; check_mcode rb1 rb
;
1096 match_expr expa expb
;
1097 match_dots match_statement
is_slist_matcher do_slist_match
1099 match_dots match_case_line
no_list do_nolist_match
1101 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1102 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1103 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1104 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1105 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1106 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1107 conjunct_many_bindings
1108 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1109 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1110 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1111 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1112 conjunct_many_bindings
1113 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1114 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1115 failwith
"disj not supported in patterns"
1116 | (Ast0.Nest
(_
,stmt_dotsa
,_
,[],multia
),
1117 Ast0.Nest
(_
,stmt_dotsb
,_
,wc
,multib
)) ->
1122 (* not sure this is correct, perhaps too restrictive *)
1123 if not
(checks_needed
) or is_minus s
or
1125 List.for_all
is_pure_context (Ast0.undots stmt_dotsb
))
1127 match_dots match_statement
1128 is_slist_matcher do_slist_match
1129 stmt_dotsa stmt_dotsb
1130 else return_false (Braces
(s
))
1131 | _
-> return_false (Nest
(s
)))
1132 else return false (* diff kind of nest *)
1133 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1134 failwith
"nest with whencode not supported in patterns"
1135 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1136 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1137 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1138 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1139 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1140 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1141 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1142 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1144 [] -> check_mcode d d1
1146 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1147 if dots_whencode_allowed
1149 conjunct_bindings (check_mcode d d1
)
1153 | Ast0.WhenNot wc
->
1154 conjunct_bindings prev
1155 (add_multi_dot_binding d
1156 (Ast0.DotsStmtTag wc
))
1157 | Ast0.WhenAlways wc
->
1158 conjunct_bindings prev
1159 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1160 | Ast0.WhenNotTrue wc
->
1161 conjunct_bindings prev
1162 (add_multi_dot_binding d
1163 (Ast0.IsoWhenTTag wc
))
1164 | Ast0.WhenNotFalse wc
->
1165 conjunct_bindings prev
1166 (add_multi_dot_binding d
1167 (Ast0.IsoWhenFTag wc
))
1168 | Ast0.WhenModifier
(x) ->
1169 conjunct_bindings prev
1170 (add_multi_dot_binding d
1171 (Ast0.IsoWhenTag
x)))
1175 "warning: not applying iso because of whencode";
1177 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1178 | (Ast0.Stars
(_
,_
::_
),_
) ->
1179 failwith
"whencode not allowed in a pattern3"
1180 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1181 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1182 match_statement rea reb
1183 | (_
,Ast0.OptStm
(reb
))
1184 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1186 else return_false (ContextRequired
(Ast0.StmtTag s
))
1188 (* first should provide a subset of the information in the second *)
1189 and match_fninfo patterninfo cinfo
=
1190 let patterninfo = List.sort compare
patterninfo in
1191 let cinfo = List.sort compare
cinfo in
1192 let rec loop = function
1193 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1194 if mcode_equal sta stb
1195 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1197 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1198 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1199 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1200 if mcode_equal ia ib
1201 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1203 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1204 if mcode_equal ia ib
1205 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1207 | (x::resta
,((y
::_
) as restb
)) ->
1208 (match compare
x y
with
1210 | 1 -> loop (resta
,restb
)
1211 | _
-> failwith
"not possible")
1212 | _
-> return false in
1213 loop (patterninfo,cinfo)
1215 and match_case_line pattern c
=
1216 if not
(checks_needed
) or not
(context_required
) or is_context c
1218 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1219 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1220 conjunct_many_bindings
1221 [check_mcode d1 d
; check_mcode c1 c
;
1222 match_dots match_statement
is_slist_matcher do_slist_match
1224 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1225 conjunct_many_bindings
1226 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1227 match_dots match_statement
is_slist_matcher do_slist_match
1229 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1230 failwith
"not allowed in the pattern of an isomorphism"
1231 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1232 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1234 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1236 let match_statement_dots x y
=
1237 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1239 (match_expr, match_decl
, match_statement
, match_typeC
,
1240 match_statement_dots)
1242 let match_expr dochecks context_required whencode_allowed
=
1243 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1246 let match_decl dochecks context_required whencode_allowed
=
1247 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1250 let match_statement dochecks context_required whencode_allowed
=
1251 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1254 let match_typeC dochecks context_required whencode_allowed
=
1255 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1258 let match_statement_dots dochecks context_required whencode_allowed
=
1259 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1262 (* --------------------------------------------------------------------- *)
1263 (* make an entire tree MINUS *)
1266 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1268 match mcodekind
with
1271 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1272 | _
-> failwith
"make_minus: unexpected befaft")
1273 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1274 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1275 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1277 let update_mc mcodekind e
=
1278 match !mcodekind
with
1281 (Ast.NOTHING
,_
,_
) ->
1282 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1283 | _
-> failwith
"make_minus: unexpected befaft")
1284 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1285 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1286 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1288 let donothing r k e
=
1289 let mcodekind = Ast0.get_mcodekind_ref e
in
1290 let e = k
e in update_mc mcodekind e; e in
1292 (* special case for whencode, because it isn't processed by contextneg,
1293 since it doesn't appear in the + code *)
1294 (* cases for dots and nests *)
1295 let expression r k
e =
1296 let mcodekind = Ast0.get_mcodekind_ref
e in
1297 match Ast0.unwrap
e with
1298 Ast0.Edots
(d
,whencode
) ->
1299 (*don't recurse because whencode hasn't been processed by context_neg*)
1300 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1301 | Ast0.Ecircles
(d
,whencode
) ->
1302 (*don't recurse because whencode hasn't been processed by context_neg*)
1303 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1304 | Ast0.Estars
(d
,whencode
) ->
1305 (*don't recurse because whencode hasn't been processed by context_neg*)
1306 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1307 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1308 update_mc mcodekind e;
1310 (Ast0.NestExpr
(mcode starter
,
1311 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1312 mcode ender
,whencode
,multi
))
1313 | _
-> donothing r k
e in
1315 let declaration r k
e =
1316 let mcodekind = Ast0.get_mcodekind_ref
e in
1317 match Ast0.unwrap
e with
1318 Ast0.Ddots
(d
,whencode
) ->
1319 (*don't recurse because whencode hasn't been processed by context_neg*)
1320 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1321 | _
-> donothing r k
e in
1323 let statement r k
e =
1324 let mcodekind = Ast0.get_mcodekind_ref
e in
1325 match Ast0.unwrap
e with
1326 Ast0.Dots
(d
,whencode
) ->
1327 (*don't recurse because whencode hasn't been processed by context_neg*)
1328 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1329 | Ast0.Circles
(d
,whencode
) ->
1330 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1331 | Ast0.Stars
(d
,whencode
) ->
1332 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1333 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1334 update_mc mcodekind e;
1337 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1338 mcode ender
,whencode
,multi
))
1339 | _
-> donothing r k
e in
1341 let initialiser r k
e =
1342 let mcodekind = Ast0.get_mcodekind_ref
e in
1343 match Ast0.unwrap
e with
1344 Ast0.Idots
(d
,whencode
) ->
1345 (*don't recurse because whencode hasn't been processed by context_neg*)
1346 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1347 | _
-> donothing r k
e in
1350 let info = Ast0.get_info
e in
1351 let mcodekind = Ast0.get_mcodekind_ref
e in
1352 match Ast0.unwrap
e with
1354 (* if context is - this should be - as well. There are no tokens
1355 here though, so the bottom-up minusifier in context_neg leaves it
1356 as mixed (or context for sgrep2). It would be better to fix
1357 context_neg, but that would
1358 require a special case for each term with a dots subterm. *)
1359 (match !mcodekind with
1360 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1362 (Ast.NOTHING
,_
,_
) ->
1363 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1365 | _
-> failwith
"make_minus: unexpected befaft")
1366 (* code already processed by an enclosing iso *)
1367 | Ast0.MINUS
(mc
) -> e
1371 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1372 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1373 | _
-> donothing r k
e in
1376 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1377 dots dots dots dots dots dots
1378 donothing expression donothing initialiser donothing declaration
1379 statement donothing donothing
1381 (* --------------------------------------------------------------------- *)
1382 (* rebuild mcode cells in an instantiated alt *)
1384 (* mcodes will be side effected later with plus code, so we have to copy
1385 them on instantiating an isomorphism. One could wonder whether it would
1386 be better not to use side-effects, but they are convenient for insert_plus
1387 where is it useful to manipulate a list of the mcodes but side-effect a
1389 (* hmm... Insert_plus is called before Iso_pattern... *)
1390 let rebuild_mcode start_line
=
1391 let copy_mcodekind = function
1392 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1393 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1394 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1395 | Ast0.PLUS count
->
1396 (* this function is used elsewhere where we need to rebuild the
1397 indices, and so we allow PLUS code as well *)
1400 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1402 match start_line
with
1405 {info.Ast0.pos_info
with
1406 Ast0.line_start
= x;
1407 Ast0.line_end
= x; } in
1408 {info with Ast0.pos_info
= new_pos_info}
1410 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1413 let old_info = Ast0.get_info
x in
1415 match start_line
with
1418 {old_info.Ast0.pos_info
with
1419 Ast0.line_start
= x;
1420 Ast0.line_end
= x; } in
1421 {old_info with Ast0.pos_info
= new_pos_info}
1422 | None
-> old_info in
1423 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1424 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1426 let donothing r k
e = copy_one (k
e) in
1428 (* case for control operators (if, etc) *)
1429 let statement r k
e =
1434 (match Ast0.unwrap
s with
1435 Ast0.Decl
((info,mc
),decl) ->
1436 Ast0.Decl
((info,copy_mcodekind mc
),decl)
1437 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1438 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1439 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1440 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1441 (info,copy_mcodekind mc
))
1442 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1443 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1444 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1445 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1446 (info,copy_mcodekind mc
))
1447 | Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,mc
)) ->
1448 Ast0.Iterator
(nm,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1450 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1452 ((info,copy_mcodekind mc
),
1453 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1455 Ast0.set_dots_bef_aft
res
1456 (match Ast0.get_dots_bef_aft
res with
1457 Ast0.NoDots
-> Ast0.NoDots
1458 | Ast0.AddingBetweenDots
s ->
1459 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1460 | Ast0.DroppingBetweenDots
s ->
1461 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1464 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1465 donothing donothing donothing donothing donothing donothing
1466 donothing donothing donothing donothing donothing
1467 donothing statement donothing donothing
1469 (* --------------------------------------------------------------------- *)
1470 (* The problem of whencode. If an isomorphism contains dots in multiple
1471 rules, then the code that is matched cannot contain whencode, because we
1472 won't know which dots it goes with. Should worry about nests, but they
1473 aren't allowed in isomorphisms for the moment. *)
1476 let option_default = 0 in
1477 let bind x y
= x + y
in
1479 match Ast0.unwrap
e with
1480 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1483 V0.combiner
bind option_default
1484 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1487 let option_default = 0 in
1488 let bind x y
= x + y
in
1490 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1492 V0.combiner
bind option_default
1493 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1496 let option_default = 0 in
1497 let bind x y
= x + y
in
1499 match Ast0.unwrap
e with
1500 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1503 V0.combiner
bind option_default
1504 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1506 (* --------------------------------------------------------------------- *)
1508 let lookup name bindings mv_bindings
=
1509 try Common.Left
(List.assoc
(term name
) bindings
)
1512 (* failure is not possible anymore *)
1513 Common.Right
(List.assoc
(term name
) mv_bindings
)
1515 (* mv_bindings is for the fresh metavariables that are introduced by the
1517 let instantiate bindings mv_bindings
=
1519 match Ast0.get_pos
x with
1520 Ast0.MetaPos
(name
,_
,_
) ->
1522 match lookup name bindings mv_bindings
with
1523 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1524 | _
-> failwith
"not possible"
1525 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1527 let donothing r k
e = k
e in
1529 (* cases where metavariables can occur *)
1532 match Ast0.unwrap
e with
1533 Ast0.MetaId
(name
,constraints
,pure
) ->
1534 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1535 (match lookup name bindings mv_bindings
with
1536 Common.Left
(Ast0.IdentTag
(id
)) -> id
1537 | Common.Left
(_
) -> failwith
"not possible 1"
1538 | Common.Right
(new_mv
) ->
1541 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1542 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1543 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1546 (* case for list metavariables *)
1547 let rec elist r same_dots
= function
1550 (match Ast0.unwrap
x with
1551 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1552 failwith
"meta_expr_list in iso not supported"
1553 (*match lookup name bindings mv_bindings with
1554 Common.Left(Ast0.DotsExprTag(exp)) ->
1555 (match same_dots exp with
1557 | None -> failwith "dots put in incompatible context")
1558 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1559 | Common.Left(_) -> failwith "not possible 1"
1560 | Common.Right(new_mv) ->
1561 failwith "MetaExprList in SP not supported"*)
1562 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1563 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1565 let rec plist r same_dots
= function
1568 (match Ast0.unwrap
x with
1569 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1570 failwith
"meta_param_list in iso not supported"
1571 (*match lookup name bindings mv_bindings with
1572 Common.Left(Ast0.DotsParamTag(param)) ->
1573 (match same_dots param with
1575 | None -> failwith "dots put in incompatible context")
1576 | Common.Left(Ast0.ParamTag(param)) -> [param]
1577 | Common.Left(_) -> failwith "not possible 1"
1578 | Common.Right(new_mv) ->
1579 failwith "MetaExprList in SP not supported"*)
1580 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1581 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1583 let rec slist r same_dots
= function
1586 (match Ast0.unwrap
x with
1587 Ast0.MetaStmtList
(name
,pure
) ->
1588 (match lookup name bindings mv_bindings
with
1589 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1590 (match same_dots stm
with
1592 | None
-> failwith
"dots put in incompatible context")
1593 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1594 | Common.Left
(_
) -> failwith
"not possible 1"
1595 | Common.Right
(new_mv
) ->
1596 failwith
"MetaExprList in SP not supported")
1597 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1598 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1601 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1602 let same_circles d
=
1603 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1605 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1607 let dots list_fn r k d
=
1609 (match Ast0.unwrap d
with
1610 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1611 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1612 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1614 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1617 match Ast0.unwrap
e with
1618 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1619 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1620 (match lookup name bindings mv_bindings
with
1621 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1622 | Common.Left
(_
) -> failwith
"not possible 1"
1623 | Common.Right
(new_mv
) ->
1628 let rec renamer = function
1629 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1631 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1633 Common.Left
(Ast0.TypeCTag
(t
)) ->
1634 Ast0.ast0_type_to_type t
1636 failwith
"iso pattern: unexpected type"
1637 | Common.Right
(new_mv
) ->
1638 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1639 | Type_cocci.ConstVol
(cv
,ty
) ->
1640 Type_cocci.ConstVol
(cv
,renamer ty
)
1641 | Type_cocci.Pointer
(ty
) ->
1642 Type_cocci.Pointer
(renamer ty
)
1643 | Type_cocci.FunctionPointer
(ty
) ->
1644 Type_cocci.FunctionPointer
(renamer ty
)
1645 | Type_cocci.Array
(ty
) ->
1646 Type_cocci.Array
(renamer ty
)
1648 Some
(List.map
renamer types
) in
1651 (Ast0.set_mcode_data new_mv name
,constraints
,
1652 new_types,form
,pure
)))
1653 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1654 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1655 failwith
"metaexprlist not supported"
1656 | Ast0.Unary
(exp
,unop
) ->
1657 (match Ast0.unwrap_mcode unop
with
1658 (* propagate negation only when the propagated and the encountered
1659 negation have the same transformation, when there is nothing
1660 added to the original one, and when there is nothing added to
1661 the expression into which we are doing the propagation. This
1662 may be too conservative. *)
1665 (* k e doesn't change the outer structure of the term,
1666 only the metavars *)
1667 match Ast0.unwrap old_e
with
1668 Ast0.Unary
(exp
,_
) ->
1669 (match Ast0.unwrap exp
with
1670 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1672 | _
-> failwith
"not possible" in
1673 let nomodif = function
1678 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1680 (Ast.NOTHING
,_
,_
) -> true
1682 | _
-> failwith
"plus not possible" in
1683 let same_modif newop oldop
=
1684 (* only propagate ! is they have the same modification
1685 and no + code on the old one (the new one from the iso
1686 surely has no + code) *)
1687 match (newop
,oldop
) with
1688 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1689 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1690 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1695 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1696 (* k accumulates parens, to keep negation outside if no
1697 propagation is possible *)
1698 if nomodif (Ast0.get_mcodekind
e)
1700 match Ast0.unwrap
res with
1701 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1703 (Ast0.get_mcode_mcodekind unop
)
1704 (Ast0.get_mcode_mcodekind op
) ->
1706 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1707 | Ast0.Paren
(lp
,e1,rp
) ->
1710 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1711 | Ast0.Binary
(e1,op
,e2
) when
1713 (Ast0.get_mcode_mcodekind unop
)
1714 (Ast0.get_mcode_mcodekind op
) ->
1716 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1717 let k1 x = k
(Ast0.rewrap
e x) in
1718 (match Ast0.unwrap_mcode op
with
1719 Ast.Logical
(Ast.Inf
) ->
1720 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1721 | Ast.Logical
(Ast.Sup
) ->
1722 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1723 | Ast.Logical
(Ast.InfEq
) ->
1724 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1725 | Ast.Logical
(Ast.SupEq
) ->
1726 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1727 | Ast.Logical
(Ast.Eq
) ->
1728 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1729 | Ast.Logical
(Ast.NotEq
) ->
1730 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1731 | Ast.Logical
(Ast.AndLog
) ->
1732 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1734 negate_reb
e e2
idcont))
1735 | Ast.Logical
(Ast.OrLog
) ->
1736 k1 (Ast0.Binary
(negate_reb
e e1 idcont,
1738 negate_reb
e e2
idcont))
1742 Ast0.rewrap_mcode op
Ast.Not
)))
1743 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1744 (* use res because it is the transformed argument *)
1746 List.map
(function e1 -> negate_reb
e e1 k
) exps in
1747 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1749 (*use e, because this might be the toplevel expression*)
1751 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1754 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1755 and negate_reb
e e1 k
=
1756 (* used when ! is propagated to multiple places, to avoid
1757 duplicating mcode cells *)
1759 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
1760 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
1765 | Ast0.Edots
(d
,_
) ->
1767 (match List.assoc
(dot_term d
) bindings
with
1768 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1769 | _
-> failwith
"unexpected binding")
1770 with Not_found
-> e)
1771 | Ast0.Ecircles
(d
,_
) ->
1773 (match List.assoc
(dot_term d
) bindings
with
1774 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1775 | _
-> failwith
"unexpected binding")
1776 with Not_found
-> e)
1777 | Ast0.Estars
(d
,_
) ->
1779 (match List.assoc
(dot_term d
) bindings
with
1780 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1781 | _
-> failwith
"unexpected binding")
1782 with Not_found
-> e)
1784 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1788 match Ast0.unwrap
e with
1789 Ast0.MetaType
(name
,pure
) ->
1790 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1791 (match lookup name bindings mv_bindings
with
1792 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1793 | Common.Left
(_
) -> failwith
"not possible 1"
1794 | Common.Right
(new_mv
) ->
1796 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1801 match Ast0.unwrap
e with
1802 Ast0.MetaInit
(name
,pure
) ->
1803 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1804 (match lookup name bindings mv_bindings
with
1805 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1806 | Common.Left
(_
) -> failwith
"not possible 1"
1807 | Common.Right
(new_mv
) ->
1809 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1814 match Ast0.unwrap
e with
1815 Ast0.MetaDecl
(name
,pure
) ->
1816 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1817 (match lookup name bindings mv_bindings
with
1818 Common.Left
(Ast0.DeclTag
(d
)) -> d
1819 | Common.Left
(_
) -> failwith
"not possible 1"
1820 | Common.Right
(new_mv
) ->
1822 (Ast0.MetaDecl
(Ast0.set_mcode_data new_mv name
, pure
)))
1823 | Ast0.MetaField
(name
,pure
) ->
1824 (rebuild_mcode None
).VT0.rebuilder_rec_declaration
1825 (match lookup name bindings mv_bindings
with
1826 Common.Left
(Ast0.DeclTag
(d
)) -> d
1827 | Common.Left
(_
) -> failwith
"not possible 1"
1828 | Common.Right
(new_mv
) ->
1830 (Ast0.MetaField
(Ast0.set_mcode_data new_mv name
, pure
)))
1831 | Ast0.Ddots
(d
,_
) ->
1833 (match List.assoc
(dot_term d
) bindings
with
1834 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1835 | _
-> failwith
"unexpected binding")
1836 with Not_found
-> e)
1841 match Ast0.unwrap
e with
1842 Ast0.MetaParam
(name
,pure
) ->
1843 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1844 (match lookup name bindings mv_bindings
with
1845 Common.Left
(Ast0.ParamTag
(param)) -> param
1846 | Common.Left
(_
) -> failwith
"not possible 1"
1847 | Common.Right
(new_mv
) ->
1849 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1850 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1851 failwith
"metaparamlist not supported"
1856 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1857 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1858 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1859 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1860 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1861 | _
-> failwith
"unexpected binding" in
1865 match Ast0.unwrap
e with
1866 Ast0.MetaStmt
(name
,pure
) ->
1867 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1868 (match lookup name bindings mv_bindings
with
1869 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1870 | Common.Left
(_
) -> failwith
"not possible 1"
1871 | Common.Right
(new_mv
) ->
1873 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1874 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1880 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1881 | Ast0.Circles
(d
,_
) ->
1886 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1887 | Ast0.Stars
(d
,_
) ->
1892 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1896 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1897 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1898 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1900 (* --------------------------------------------------------------------- *)
1903 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1905 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1907 let disj_fail bindings
e =
1909 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1912 (* isomorphism code is by default CONTEXT *)
1913 let merge_plus model_mcode e_mcode
=
1914 match model_mcode
with
1916 (* add the replacement information at the root *)
1920 (match (!mc
,!emc
) with
1921 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1922 | _
-> failwith
"how can we combine minuses?")
1923 | _
-> failwith
"not possible 6")
1924 | Ast0.CONTEXT
(mc
) ->
1926 Ast0.CONTEXT
(emc
) ->
1927 (* keep the logical line info as in the model *)
1928 let (mba
,tb
,ta
) = !mc
in
1929 let (eba
,_
,_
) = !emc
in
1930 (* merging may be required when a term is replaced by a subterm *)
1932 match (mba
,eba
) with
1933 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1934 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1935 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1936 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1937 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1938 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1939 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1940 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1941 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1942 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1943 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1944 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1945 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1946 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1947 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1948 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1949 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1950 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1951 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1952 emc
:= (merged,tb
,ta
)
1953 | Ast0.MINUS
(emc
) ->
1954 let (anything_bef_aft
,_
,_
) = !mc
in
1955 let (anythings
,t
) = !emc
in
1957 (match anything_bef_aft
with
1958 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1959 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1960 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1961 | Ast.NOTHING
-> (anythings
,t
))
1962 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1963 | _
-> failwith
"not possible 7")
1964 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1965 | Ast0.PLUS _
-> failwith
"not possible 9"
1967 let copy_plus printer minusify model
e =
1968 if !Flag.sgrep_mode2
1969 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1973 match Ast0.get_mcodekind model
with
1974 Ast0.MINUS
(mc
) -> minusify
e
1975 | Ast0.CONTEXT
(mc
) -> e
1976 | _
-> failwith
"not possible: copy_plus\n" in
1977 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1981 let copy_minus printer minusify model
e =
1982 match Ast0.get_mcodekind model
with
1983 Ast0.MINUS
(mc
) -> minusify
e
1984 | Ast0.CONTEXT
(mc
) -> e
1986 if !Flag.sgrep_mode2
1988 else failwith
"not possible 8"
1989 | Ast0.PLUS _
-> failwith
"not possible 9"
1991 let whencode_allowed prev_ecount prev_icount prev_dcount
1992 ecount icount dcount rest
=
1993 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1995 let other_ecount = (* number of edots *)
1996 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1998 let other_icount = (* number of dots *)
1999 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
2001 let other_dcount = (* number of dots *)
2002 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
2004 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
2005 dcount
= 0 or other_dcount = 0)
2007 (* copy the befores and afters to the instantiated code *)
2008 let extra_copy_stmt_plus model
e =
2009 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
2011 (match Ast0.unwrap model
with
2012 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
2013 | Ast0.Decl
((info,bef
),_
) ->
2014 (match Ast0.unwrap
e with
2015 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
2016 | Ast0.Decl
((info,bef1
),_
) ->
2018 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
2019 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
2020 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2021 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
2022 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
2023 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
2024 (match Ast0.unwrap
e with
2025 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
2026 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2027 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
2028 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
2029 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
2031 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
2035 let extra_copy_other_plus model
e = e
2037 (* --------------------------------------------------------------------- *)
2039 let mv_count = ref 0
2041 let ct = !mv_count in
2042 mv_count := !mv_count + 1;
2043 "_"^
s^
"_"^
(string_of_int
ct)
2045 let get_name = function
2046 Ast.MetaIdDecl
(ar
,nm) ->
2047 (nm,function nm -> Ast.MetaIdDecl
(ar
,nm))
2048 | Ast.MetaFreshIdDecl
(nm,seed
) ->
2049 (nm,function nm -> Ast.MetaFreshIdDecl
(nm,seed
))
2050 | Ast.MetaTypeDecl
(ar
,nm) ->
2051 (nm,function nm -> Ast.MetaTypeDecl
(ar
,nm))
2052 | Ast.MetaInitDecl
(ar
,nm) ->
2053 (nm,function nm -> Ast.MetaInitDecl
(ar
,nm))
2054 | Ast.MetaListlenDecl
(nm) ->
2055 failwith
"should not be rebuilt"
2056 | Ast.MetaParamDecl
(ar
,nm) ->
2057 (nm,function nm -> Ast.MetaParamDecl
(ar
,nm))
2058 | Ast.MetaParamListDecl
(ar
,nm,nm1
) ->
2059 (nm,function nm -> Ast.MetaParamListDecl
(ar
,nm,nm1
))
2060 | Ast.MetaConstDecl
(ar
,nm,ty
) ->
2061 (nm,function nm -> Ast.MetaConstDecl
(ar
,nm,ty
))
2062 | Ast.MetaErrDecl
(ar
,nm) ->
2063 (nm,function nm -> Ast.MetaErrDecl
(ar
,nm))
2064 | Ast.MetaExpDecl
(ar
,nm,ty
) ->
2065 (nm,function nm -> Ast.MetaExpDecl
(ar
,nm,ty
))
2066 | Ast.MetaIdExpDecl
(ar
,nm,ty
) ->
2067 (nm,function nm -> Ast.MetaIdExpDecl
(ar
,nm,ty
))
2068 | Ast.MetaLocalIdExpDecl
(ar
,nm,ty
) ->
2069 (nm,function nm -> Ast.MetaLocalIdExpDecl
(ar
,nm,ty
))
2070 | Ast.MetaExpListDecl
(ar
,nm,nm1
) ->
2071 (nm,function nm -> Ast.MetaExpListDecl
(ar
,nm,nm1
))
2072 | Ast.MetaDeclDecl
(ar
,nm) ->
2073 (nm,function nm -> Ast.MetaDeclDecl
(ar
,nm))
2074 | Ast.MetaFieldDecl
(ar
,nm) ->
2075 (nm,function nm -> Ast.MetaFieldDecl
(ar
,nm))
2076 | Ast.MetaStmDecl
(ar
,nm) ->
2077 (nm,function nm -> Ast.MetaStmDecl
(ar
,nm))
2078 | Ast.MetaStmListDecl
(ar
,nm) ->
2079 (nm,function nm -> Ast.MetaStmListDecl
(ar
,nm))
2080 | Ast.MetaFuncDecl
(ar
,nm) ->
2081 (nm,function nm -> Ast.MetaFuncDecl
(ar
,nm))
2082 | Ast.MetaLocalFuncDecl
(ar
,nm) ->
2083 (nm,function nm -> Ast.MetaLocalFuncDecl
(ar
,nm))
2084 | Ast.MetaPosDecl
(ar
,nm) ->
2085 (nm,function nm -> Ast.MetaPosDecl
(ar
,nm))
2086 | Ast.MetaDeclarerDecl
(ar
,nm) ->
2087 (nm,function nm -> Ast.MetaDeclarerDecl
(ar
,nm))
2088 | Ast.MetaIteratorDecl
(ar
,nm) ->
2089 (nm,function nm -> Ast.MetaIteratorDecl
(ar
,nm))
2091 let make_new_metavars metavars bindings
=
2095 let (s,_
) = get_name mv
in
2096 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2101 let (s,rebuild
) = get_name mv
in
2102 let new_s = (!current_rule,new_mv s) in
2103 (rebuild
new_s, (s,new_s)))
2106 (* --------------------------------------------------------------------- *)
2108 let do_nothing x = x
2110 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2111 rebuild_mcodes name printer extra_plus update_others has_context
=
2112 let call_instantiate bindings mv_bindings alts pattern has_context
=
2115 (function (a
,_,_,_) ->
2117 (* no need to create duplicates when the bindings have no effect *)
2119 (function bindings
->
2121 instantiater bindings mv_bindings
(rebuild_mcodes a
) in
2123 if has_context
(* ie if pat is not just a metavara *)
2125 copy_plus printer minusify
e (extra_plus
e instantiated)
2126 else instantiated in
2129 else (* iso tracking *)
2130 Ast0.set_iso
plus_added
2131 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2134 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2135 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2136 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2138 whencode_allowed prev_ecount prev_icount prev_dcount
2139 ecount dcount icount rest
in
2140 (match matcher
true (context_required e) wc pattern
e init_env with
2142 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2145 (match matcher
false false wc pattern
e init_env with
2147 interpret_reason name
(Ast0.get_line
e) reason
2148 (function () -> printer
e)
2150 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2151 (prev_dcount
+ dcount
) rest
2152 | OK
(bindings
: ((Ast.meta_name
* 'a
) list list
)) ->
2154 (* apply update_others to all patterns other than the matched
2155 one. This is used to desigate the others as test
2156 expressions in the TestExpression case *)
2158 (function (x,e,i
,d
) as all
->
2161 else (update_others
x,e,i
,d
))
2162 (List.hd
all_alts)) ::
2164 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2165 (List.tl
all_alts)) in
2166 (match List.concat
all_alts with
2167 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2169 let (new_metavars,mv_bindings
) =
2170 make_new_metavars metavars
(nub(List.concat bindings
)) in
2173 call_instantiate bindings mv_bindings
all_alts pattern
2174 (has_context pattern
)))) in
2175 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2176 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2177 | (alts
::rest
) as all_alts ->
2178 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2179 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2180 outer_loop prev_ecount prev_icount prev_dcount rest
2181 | Common.Right
(new_metavars,res) ->
2183 copy_minus printer minusify
e (disj_maker
res)) in
2184 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2185 (count
, metavars
, e)
2187 (* no one should ever look at the information stored in these mcodes *)
2188 let disj_starter lst
=
2189 let old_info = Ast0.get_info
(List.hd lst
) in
2191 { old_info.Ast0.pos_info
with
2192 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2193 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2195 { Ast0.pos_info
= new_pos_info;
2196 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2197 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2198 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2199 Ast0.make_mcode_info
"(" info
2201 let disj_ender lst
=
2202 let old_info = Ast0.get_info
(List.hd lst
) in
2204 { old_info.Ast0.pos_info
with
2205 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2206 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2208 { Ast0.pos_info
= new_pos_info;
2209 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2210 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2211 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2212 Ast0.make_mcode_info
")" info
2214 let disj_mid _ = Ast0.make_mcode
"|"
2216 let make_disj_type tl
=
2219 [] -> failwith
"bad disjunction"
2220 | x::xs
-> List.map
disj_mid xs
in
2221 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2222 let make_disj_stmt_list tl
=
2225 [] -> failwith
"bad disjunction"
2226 | x::xs
-> List.map
disj_mid xs
in
2227 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2228 let make_disj_expr model el
=
2231 [] -> failwith
"bad disjunction"
2232 | x::xs
-> List.map
disj_mid xs
in
2234 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2236 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2237 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2238 let el = List.map
update_arg (List.map
update_test el) in
2239 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2240 let make_disj_decl dl
=
2243 [] -> failwith
"bad disjunction"
2244 | x::xs
-> List.map
disj_mid xs
in
2245 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2246 let make_disj_stmt sl
=
2247 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2250 [] -> failwith
"bad disjunction"
2251 | x::xs
-> List.map
disj_mid xs
in
2253 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2255 let transform_type (metavars
,alts
,name
) e =
2257 (Ast0.TypeCTag
(_)::_)::_ ->
2258 (* start line is given to any leaves in the iso code *)
2260 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2266 (p
,count_edots.VT0.combiner_rec_typeC p
,
2267 count_idots.VT0.combiner_rec_typeC p
,
2268 count_dots.VT0.combiner_rec_typeC p
)
2269 | _ -> failwith
"invalid alt"))
2271 mkdisj match_typeC metavars
alts e
2272 (function b
-> function mv_b
->
2273 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2274 (function t
-> Ast0.TypeCTag t
)
2275 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2276 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2277 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2279 match Ast0.unwrap
x with Ast0.MetaType
_ -> false | _ -> true)
2283 let transform_expr (metavars
,alts,name
) e =
2284 let process update_others
=
2285 (* start line is given to any leaves in the iso code *)
2287 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2292 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2293 (p
,count_edots.VT0.combiner_rec_expression p
,
2294 count_idots.VT0.combiner_rec_expression p
,
2295 count_dots.VT0.combiner_rec_expression p
)
2296 | _ -> failwith
"invalid alt"))
2298 mkdisj match_expr metavars
alts e
2299 (function b
-> function mv_b
->
2300 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2301 (function e -> Ast0.ExprTag
e)
2303 make_minus.VT0.rebuilder_rec_expression
2304 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2305 name
Unparse_ast0.expression extra_copy_other_plus update_others
2307 match Ast0.unwrap
x with
2308 Ast0.MetaExpr
_ | Ast0.MetaExprList
_ | Ast0.MetaErr
_ -> false
2312 (Ast0.ExprTag
(_)::r
)::rs
->
2313 (* hack to accomodate ToTestExpression case, where the first pattern is
2314 a normal expression, but the others are test expressions *)
2315 let others = r
@ (List.concat rs
) in
2316 let is_test = function Ast0.TestExprTag
(_) -> true | _ -> false in
2317 if List.for_all
is_test others then process Ast0.set_test_exp
2318 else if List.exists
is_test others then failwith
"inconsistent iso"
2319 else process do_nothing
2320 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2321 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2322 process Ast0.set_test_exp
2325 let transform_decl (metavars
,alts,name
) e =
2327 (Ast0.DeclTag
(_)::_)::_ ->
2328 (* start line is given to any leaves in the iso code *)
2330 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2336 (p
,count_edots.VT0.combiner_rec_declaration p
,
2337 count_idots.VT0.combiner_rec_declaration p
,
2338 count_dots.VT0.combiner_rec_declaration p
)
2339 | _ -> failwith
"invalid alt"))
2341 mkdisj match_decl metavars
alts e
2342 (function b
-> function mv_b
->
2343 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2344 (function d
-> Ast0.DeclTag d
)
2346 make_minus.VT0.rebuilder_rec_declaration
2347 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2348 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2349 (function _ -> true (* no metavars *))
2352 let transform_stmt (metavars
,alts,name
) e =
2354 (Ast0.StmtTag
(_)::_)::_ ->
2355 (* start line is given to any leaves in the iso code *)
2357 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2363 (p
,count_edots.VT0.combiner_rec_statement p
,
2364 count_idots.VT0.combiner_rec_statement p
,
2365 count_dots.VT0.combiner_rec_statement p
)
2366 | _ -> failwith
"invalid alt"))
2368 mkdisj match_statement metavars
alts e
2369 (function b
-> function mv_b
->
2370 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2371 (function s -> Ast0.StmtTag
s)
2372 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2373 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2374 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2376 match Ast0.unwrap
x with
2377 Ast0.MetaStmt
_ | Ast0.MetaStmtList
_ -> false
2381 (* sort of a hack, because there is no disj at top level *)
2382 let transform_top (metavars
,alts,name
) e =
2383 match Ast0.unwrap
e with
2384 Ast0.DECL
(declstm
) ->
2390 Ast0.DotsStmtTag
(d
) ->
2391 (match Ast0.unwrap d
with
2392 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2393 | _ -> raise
(Failure
""))
2394 | _ -> raise
(Failure
"")))
2396 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2397 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2398 with Failure
_ -> (0,[],e))
2399 | Ast0.CODE
(stmts
) ->
2400 let (count
,mv
,res) =
2402 (Ast0.DotsStmtTag
(_)::_)::_ ->
2403 (* start line is given to any leaves in the iso code *)
2405 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2410 Ast0.DotsStmtTag
(p
) ->
2411 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2412 count_idots.VT0.combiner_rec_statement_dots p
,
2413 count_dots.VT0.combiner_rec_statement_dots p
)
2414 | _ -> failwith
"invalid alt"))
2416 mkdisj match_statement_dots metavars
alts stmts
2417 (function b
-> function mv_b
->
2418 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2419 (function s -> Ast0.DotsStmtTag
s)
2421 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2423 make_minus.VT0.rebuilder_rec_statement_dots
x)
2424 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2425 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2426 (function _ -> true)
2427 | _ -> (0,[],stmts
) in
2428 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2431 (* --------------------------------------------------------------------- *)
2433 let transform (alts : isomorphism
) t
=
2434 (* the following ugliness is because rebuilder only returns a new term *)
2435 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2436 let in_limit n
= function
2440 ((if !Flag_parsing_cocci.show_iso_failures
2441 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2443 let bind x y
= x + y
in
2444 let option_default = 0 in
2446 let (e_count
,e) = k
e in
2447 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2449 let (count
,extra_meta
,exp
) = transform_expr alts e in
2450 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2451 (bind count e_count
,exp
)
2455 let (e_count
,e) = k
e in
2456 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2458 let (count
,extra_meta
,dec
) = transform_decl alts e in
2459 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2460 (bind count e_count
,dec
)
2464 let (e_count
,e) = k
e in
2465 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2467 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2468 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2469 (bind count e_count
,stm
)
2473 let (continue
,e_count
,e) =
2474 match Ast0.unwrap
e with
2475 Ast0.Signed
(signb
,tyb
) ->
2476 (* Hack! How else to prevent iso from applying under an
2480 let (e_count
,e) = k
e in
2481 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2482 then (true,e_count
,e)
2483 else (false,e_count
,e) in
2486 let (count
,extra_meta
,ty
) = transform_type alts e in
2487 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2488 (bind count e_count
,ty
)
2492 let (e_count
,e) = k
e in
2493 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2495 let (count
,extra_meta
,ty
) = transform_top alts e in
2496 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2497 (bind count e_count
,ty
)
2501 V0.combiner_rebuilder
bind option_default
2502 {V0.combiner_rebuilder_functions
with
2503 VT0.combiner_rebuilder_exprfn
= exprfn;
2504 VT0.combiner_rebuilder_tyfn
= typefn;
2505 VT0.combiner_rebuilder_declfn
= declfn;
2506 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2507 VT0.combiner_rebuilder_topfn
= topfn} in
2508 let (_,res) = res.VT0.top_level t
in
2509 (!extra_meta_decls,res)
2511 (* --------------------------------------------------------------------- *)
2513 (* should be done by functorizing the parser to use wrap or context_wrap *)
2515 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2516 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2518 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2519 donothing donothing donothing donothing donothing donothing
2520 donothing donothing donothing donothing donothing donothing donothing
2523 let rewrap_anything = function
2524 Ast0.DotsExprTag
(d
) ->
2525 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2526 | Ast0.DotsInitTag
(d
) ->
2527 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2528 | Ast0.DotsParamTag
(d
) ->
2529 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2530 | Ast0.DotsStmtTag
(d
) ->
2531 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2532 | Ast0.DotsDeclTag
(d
) ->
2533 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2534 | Ast0.DotsCaseTag
(d
) ->
2535 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2536 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2537 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2538 | Ast0.ArgExprTag
(d
) ->
2539 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2540 | Ast0.TestExprTag
(d
) ->
2541 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2542 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2543 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2544 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2545 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2546 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2547 | Ast0.CaseLineTag
(d
) ->
2548 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2549 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2550 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2551 failwith
"only for isos within iso phase"
2552 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2554 (* --------------------------------------------------------------------- *)
2556 let apply_isos isos rule rule_name
=
2561 current_rule := rule_name
;
2564 (function (metavars
,iso
,name
) ->
2565 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2567 let (extra_meta
,rule
) =
2572 (function (extra_meta
,t
) -> function iso
->
2573 let (new_extra_meta
,t
) = transform iso t
in
2574 (new_extra_meta
@extra_meta
,t
))
2577 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)