2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
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
,ref Ast0.NoMetaPos
) in
50 {(Ast0.wrap
(Ast0.unwrap
x)) with
51 Ast0.mcodekind
= ref Ast0.PLUS
;
52 Ast0.true_if_test
= x.Ast0.true_if_test
} in
54 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
55 donothing donothing donothing donothing donothing donothing
56 donothing donothing donothing donothing donothing donothing donothing
59 let anything_equal = function
60 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
61 failwith
"not a possible variable binding" (*not sure why these are pbs*)
62 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
63 failwith
"not a possible variable binding"
64 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
65 failwith
"not a possible variable binding"
66 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
67 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
68 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
69 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
70 failwith
"not a possible variable binding"
71 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
72 failwith
"not a possible variable binding"
73 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
74 (strip_info.VT0.rebuilder_rec_ident d1
) = (strip_info.VT0.rebuilder_rec_ident d2
)
75 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
76 (strip_info.VT0.rebuilder_rec_expression d1
) =
77 (strip_info.VT0.rebuilder_rec_expression d2
)
78 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
79 failwith
"not possible - only in isos1"
80 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
81 failwith
"not possible - only in isos1"
82 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
83 (strip_info.VT0.rebuilder_rec_typeC d1
) =
84 (strip_info.VT0.rebuilder_rec_typeC d2
)
85 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
86 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
87 (strip_info.VT0.rebuilder_rec_initialiser d2
)
88 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
89 (strip_info.VT0.rebuilder_rec_parameter d1
) =
90 (strip_info.VT0.rebuilder_rec_parameter d2
)
91 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
92 (strip_info.VT0.rebuilder_rec_declaration d1
) =
93 (strip_info.VT0.rebuilder_rec_declaration d2
)
94 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
95 (strip_info.VT0.rebuilder_rec_statement d1
) =
96 (strip_info.VT0.rebuilder_rec_statement d2
)
97 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
98 (strip_info.VT0.rebuilder_rec_case_line d1
) =
99 (strip_info.VT0.rebuilder_rec_case_line d2
)
100 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
101 (strip_info.VT0.rebuilder_rec_top_level d1
) =
102 (strip_info.VT0.rebuilder_rec_top_level d2
)
103 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
104 failwith
"only for isos within iso phase"
105 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
106 failwith
"only for isos within iso phase"
107 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
108 failwith
"only for isos within iso phase"
111 let term (var1
,_
,_
,_
,_
) = var1
112 let dot_term (var1
,_
,info
,_
,_
) =
113 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
117 NotPure
of Ast0.pure
* (string * string) * Ast0.anything
118 | NotPureLength
of (string * string)
119 | ContextRequired
of Ast0.anything
121 | Braces
of Ast0.statement
122 | Position
of string * string
123 | TypeMatch
of reason list
125 let rec interpret_reason name line reason printer
=
127 "warning: iso %s does not match the code below on line %d\n" name line
;
128 printer
(); Format.print_newline
();
130 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
132 "pure metavariable %s is matched against the following nonpure code:\n"
134 Unparse_ast0.unparse_anything nonpure
135 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
137 "context metavariable %s is matched against the following\nnoncontext code:\n"
139 Unparse_ast0.unparse_anything nonpure
140 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
142 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
144 Unparse_ast0.unparse_anything nonpure
145 | NotPureLength
((_
,var
)) ->
147 "pure metavariable %s is matched against too much or too little code\n"
149 | ContextRequired
(term) ->
151 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
152 Unparse_ast0.unparse_anything
term
154 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
155 Unparse_ast0.statement
"" s
;
156 Format.print_newline
()
157 | Position
(rule
,name
) ->
158 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
160 | TypeMatch reason_list
->
161 List.iter
(function r
-> interpret_reason name line r printer
)
163 | _
-> failwith
"not possible"
165 type 'a either
= OK
of 'a
| Fail
of reason
167 let add_binding var exp bindings
=
168 let var = term var in
169 let attempt bindings
=
171 let cur = List.assoc
var bindings
in
172 if anything_equal(exp
,cur) then [bindings
] else []
173 with Not_found
-> [((var,exp
)::bindings
)] in
174 match List.concat
(List.map
attempt bindings
) with
178 let add_dot_binding var exp bindings
=
179 let var = dot_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
190 let add_multi_dot_binding var exp bindings
=
191 let var = dot_term var in
192 let attempt bindings
= [((var,exp
)::bindings
)] in
193 match List.concat
(List.map
attempt bindings
) with
200 | (x::xs
) when (List.mem
x xs
) -> nub xs
201 | (x::xs
) -> x::(nub xs
)
203 (* --------------------------------------------------------------------- *)
207 let debug str m binding
=
208 let res = m binding
in
210 None
-> Printf.printf
"%s: failed\n" str
214 Printf.printf
"%s: %s\n" str
215 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
219 let conjunct_bindings
220 (m1
: 'binding
-> 'binding either
)
221 (m2
: 'binding
-> 'binding either
)
222 (binding
: 'binding
) : 'binding either
=
223 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
225 let rec conjunct_many_bindings = function
226 [] -> failwith
"not possible"
228 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
230 let mcode_equal (x,_
,_
,_
,_
) (y
,_
,_
,_
,_
) = x = y
232 let return b binding
= if b
then OK binding
else Fail NonMatch
233 let return_false reason binding
= Fail reason
235 let match_option f t1 t2
=
237 (Some t1
, Some t2
) -> f t1 t2
238 | (None
, None
) -> return true
241 let bool_match_option f t1 t2
=
243 (Some t1
, Some t2
) -> f t1 t2
244 | (None
, None
) -> true
247 (* context_required is for the example
251 where we can't change x == NULL to eg NULL == x. So there can either be
252 nothing attached to the root or the term has to be all removed.
253 if would be nice if we knew more about the relationship between the - and +
254 code, because in the case where the + code is a separate statement in a
255 sequence, this is not a problem. Perhaps something could be done in
258 The example seems strange. Why isn't the cast attached to x?
261 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
262 (match Ast0.get_mcodekind e
with
263 Ast0.CONTEXT
(cell
) -> true
266 (* needs a special case when there is a Disj or an empty DOTS
267 the following stops at the statement level, and gives true if one
268 statement is replaced by another *)
269 let rec is_pure_context s
=
270 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
271 (match Ast0.unwrap s
with
272 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
275 match Ast0.undots
x with
276 [s
] -> is_pure_context s
277 | _
-> false (* could we do better? *))
280 (match Ast0.get_mcodekind s
with
283 (Ast.NOTHING
,_
,_
) -> true
287 (* do better for the common case of replacing a stmt by another one *)
288 ([[Ast.StatementTag
(s
)]],_
) ->
289 (match Ast.unwrap s
with
290 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
296 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
298 let match_list matcher is_list_matcher do_list_match la lb
=
299 let rec loop = function
300 ([],[]) -> return true
301 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
302 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
303 | _
-> return false in
306 let match_maker checks_needed context_required whencode_allowed
=
308 let check_mcode pmc cmc binding
=
311 match Ast0.get_pos cmc
with
312 (Ast0.MetaPos
(name
,_
,_
)) as x ->
313 (match Ast0.get_pos pmc
with
314 Ast0.MetaPos
(name1
,_
,_
) ->
315 add_binding name1
(Ast0.MetaPosTag
x) binding
317 let (rule
,name
) = Ast0.unwrap_mcode name
in
318 Fail
(Position
(rule
,name
)))
319 | Ast0.NoMetaPos
-> OK binding
322 let match_dots matcher is_list_matcher do_list_match d1 d2
=
323 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
324 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
325 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
326 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
327 match_list matcher is_list_matcher
(do_list_match d2
) la lb
328 | _
-> return false in
330 let is_elist_matcher el
=
331 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
333 let is_plist_matcher pl
=
334 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
336 let is_slist_matcher pl
=
337 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
339 let no_list _
= false in
341 let build_dots pattern data
=
342 match Ast0.unwrap pattern
with
343 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
344 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
345 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
348 let bind = Ast0.lub_pure
in
349 let option_default = Ast0.Context
in
350 let pure_mcodekind mc
=
352 then Ast0.PureContext
357 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
360 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
361 | _
-> Ast0.Impure
in
362 let donothing r k e
=
363 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
365 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
367 (* a case for everything that has a metavariable *)
368 (* pure is supposed to match only unitary metavars, not anything that
369 contains only unitary metavars *)
371 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
372 (match Ast0.unwrap i
with
373 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
374 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
375 | _
-> Ast0.Impure
) in
377 let expression r k e
=
378 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
379 (match Ast0.unwrap e
with
380 Ast0.MetaErr
(name
,_
,pure
)
381 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
383 | _
-> Ast0.Impure
) in
386 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
387 (match Ast0.unwrap t
with
388 Ast0.MetaType
(name
,pure
) -> pure
389 | _
-> Ast0.Impure
) in
392 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
393 (match Ast0.unwrap t
with
394 Ast0.MetaInit
(name
,pure
) -> pure
395 | _
-> Ast0.Impure
) in
398 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
399 (match Ast0.unwrap p
with
400 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
401 | _
-> Ast0.Impure
) in
404 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
405 (match Ast0.unwrap s
with
406 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
407 | _
-> Ast0.Impure
) in
409 V0.flat_combiner
bind option_default
410 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
411 donothing donothing donothing donothing donothing donothing
412 ident expression typeC init param donothing stmt donothing
415 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
416 match (checks_needed
,pure
) with
417 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
420 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
421 then add_binding name
(builder1 lst
)
422 else return_false (NotPure
(pure
,term name
,builder1 lst
))
423 | _
-> return_false (NotPureLength
(term name
)))
424 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
426 let add_pure_binding name pure is_pure builder
x =
427 match (checks_needed
,pure
) with
428 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
429 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
430 then add_binding name
(builder
x)
431 else return_false (NotPure
(pure
,term name
, builder
x))
432 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
434 let do_elist_match builder el lst
=
435 match Ast0.unwrap el
with
436 Ast0.MetaExprList
(name
,lenname
,pure
) ->
437 (*how to handle lenname? should it be an option type and always None?*)
438 failwith
"expr list pattern not supported in iso"
439 (*add_pure_list_binding name pure
440 pure_sp_code.V0.combiner_expression
441 (function lst -> Ast0.ExprTag(List.hd lst))
442 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
444 | _
-> failwith
"not possible" in
446 let do_plist_match builder pl lst
=
447 match Ast0.unwrap pl
with
448 Ast0.MetaParamList
(name
,lename
,pure
) ->
449 failwith
"param list pattern not supported in iso"
450 (*add_pure_list_binding name pure
451 pure_sp_code.V0.combiner_parameter
452 (function lst -> Ast0.ParamTag(List.hd lst))
453 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
455 | _
-> failwith
"not possible" in
457 let do_slist_match builder sl lst
=
458 match Ast0.unwrap sl
with
459 Ast0.MetaStmtList
(name
,pure
) ->
460 add_pure_list_binding name pure
461 pure_sp_code.VT0.combiner_rec_statement
462 (function lst
-> Ast0.StmtTag
(List.hd lst
))
463 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
465 | _
-> failwith
"not possible" in
467 let do_nolist_match _ _
= failwith
"not possible" in
469 let rec match_ident pattern id
=
470 match Ast0.unwrap pattern
with
471 Ast0.MetaId
(name
,_
,pure
) ->
472 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
473 (function id
-> Ast0.IdentTag id
) id
)
474 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
475 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
477 if not
(checks_needed
) or not
(context_required
) or is_context id
479 match (up
,Ast0.unwrap id
) with
480 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
481 if mcode_equal namea nameb
482 then check_mcode namea nameb
484 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
485 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
487 | (_
,Ast0.OptIdent
(idb
))
488 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
490 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
492 (* should we do something about matching metavars against ...? *)
493 let rec match_expr pattern expr
=
494 match Ast0.unwrap pattern
with
495 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
497 match (form
,expr
) with
501 match Ast0.unwrap e
with
502 Ast0.Constant
(c
) -> true
503 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
504 | Ast0.SizeOfExpr
(se
,exp
) -> true
505 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
506 | Ast0.MetaExpr
(nm
,_
,_
,Ast.CONST
,p
) ->
507 (Ast0.lub_pure p pure
) = pure
510 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
512 match Ast0.unwrap e
with
513 Ast0.Ident
(c
) -> true
514 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
515 | Ast0.MetaExpr
(nm
,_
,_
,Ast.ID
,p
) ->
516 (Ast0.lub_pure p pure
) = pure
524 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
528 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
530 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
531 (* easier than updating type inferencer to manage multiple
533 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
534 | (_
,Some ty
) -> Some
[ty
]
538 let tyname = Ast0.rewrap_mcode name
tyname in
540 (add_pure_binding name pure
541 pure_sp_code.VT0.combiner_rec_expression
542 (function expr
-> Ast0.ExprTag expr
)
544 (function bindings
->
549 add_pure_binding tyname Ast0.Impure
550 (function _
-> Ast0.Impure
)
551 (function ty
-> Ast0.TypeCTag ty
)
553 (Ast0.reverse_type
expty))
557 "warning: unconvertible type";
558 return false bindings
))
561 (function Fail _
-> false | OK
x -> true)
564 (* not sure why this is ok. can there be more
568 (function Fail _
-> [] | OK
x -> x)
576 | OK
x -> failwith
"not possible")
580 "warning: type metavar can only match one type";*)
584 "mixture of metatype and other types not supported")
586 let expty = Ast0.get_type expr
in
587 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
589 add_pure_binding name pure
590 pure_sp_code.VT0.combiner_rec_expression
591 (function expr
-> Ast0.ExprTag expr
)
595 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_expression
596 (function expr
-> Ast0.ExprTag expr
)
599 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
600 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
602 if not
(checks_needed
) or not
(context_required
) or is_context expr
604 match (up
,Ast0.unwrap expr
) with
605 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
607 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
608 if mcode_equal consta constb
609 then check_mcode consta constb
611 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
612 conjunct_many_bindings
613 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
614 match_dots match_expr is_elist_matcher do_elist_match
616 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
617 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
618 if mcode_equal opa opb
620 conjunct_many_bindings
621 [check_mcode opa opb
; match_expr lefta leftb
;
622 match_expr righta rightb
]
624 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
625 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
626 conjunct_many_bindings
627 [check_mcode lp1 lp
; check_mcode rp1 rp
;
628 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
629 match_expr exp3a exp3b
]
630 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
631 if mcode_equal opa opb
633 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
635 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
636 if mcode_equal opa opb
638 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
640 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
641 if mcode_equal opa opb
643 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
645 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
646 if mcode_equal opa opb
648 conjunct_many_bindings
649 [check_mcode opa opb
; match_expr lefta leftb
;
650 match_expr righta rightb
]
652 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
653 conjunct_many_bindings
654 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
655 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
656 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
657 conjunct_many_bindings
658 [check_mcode lb1 lb
; check_mcode rb1 rb
;
659 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
660 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
661 Ast0.RecordAccess
(expb
,op
,fieldb
))
662 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
663 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
664 conjunct_many_bindings
665 [check_mcode opa op
; match_expr expa expb
;
666 match_ident fielda fieldb
]
667 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
668 conjunct_many_bindings
669 [check_mcode lp1 lp
; check_mcode rp1 rp
;
670 match_typeC tya tyb
; match_expr expa expb
]
671 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
672 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
673 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
674 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
675 conjunct_many_bindings
676 [check_mcode lp1 lp
; check_mcode rp1 rp
;
677 check_mcode szf1 szf
; match_typeC tya tyb
]
678 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
680 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
681 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
682 failwith
"not allowed in the pattern of an isomorphism"
683 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
684 failwith
"not allowed in the pattern of an isomorphism"
685 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
686 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
687 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
688 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
689 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
690 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
691 (* hope that mcode of edots is unique somehow *)
692 conjunct_bindings (check_mcode ed ed1
)
693 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
694 if edots_whencode_allowed
695 then add_dot_binding ed
(Ast0.ExprTag wc
)
698 "warning: not applying iso because of whencode";
700 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
701 | (Ast0.Estars
(_
,Some _
),_
) ->
702 failwith
"whencode not allowed in a pattern1"
703 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
704 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
705 | (_
,Ast0.OptExp
(expb
))
706 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
708 else return_false (ContextRequired
(Ast0.ExprTag expr
))
710 (* the special case for function types prevents the eg T X; -> T X = E; iso
711 from applying, which doesn't seem very relevant, but it also avoids a
712 mysterious bug that is obtained with eg int attach(...); *)
713 and match_typeC pattern t
=
714 match Ast0.unwrap pattern
with
715 Ast0.MetaType
(name
,pure
) ->
716 (match Ast0.unwrap t
with
717 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
719 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
720 (function ty
-> Ast0.TypeCTag ty
)
723 if not
(checks_needed
) or not
(context_required
) or is_context t
725 match (up
,Ast0.unwrap t
) with
726 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
727 if mcode_equal cva cvb
729 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
731 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
734 match_list check_mcode
735 (function _
-> false) (function _
-> failwith
"")
738 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
739 if mcode_equal signa signb
741 conjunct_bindings (check_mcode signa signb
)
742 (match_option match_typeC tya tyb
)
744 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
745 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
746 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
747 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
748 conjunct_many_bindings
749 [check_mcode stara starb
; check_mcode lp1a lp1b
;
750 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
751 check_mcode rp2a rp2b
; match_typeC tya tyb
;
752 match_dots match_param
is_plist_matcher
753 do_plist_match paramsa paramsb
]
754 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
755 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
756 conjunct_many_bindings
757 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
758 match_option match_typeC tya tyb
;
759 match_dots match_param
is_plist_matcher do_plist_match
761 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
762 conjunct_many_bindings
763 [check_mcode lb1 lb
; check_mcode rb1 rb
;
764 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
765 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
766 conjunct_bindings (check_mcode kinda kindb
)
767 (match_ident namea nameb
)
768 | (Ast0.StructUnionName
(kinda
,Some namea
),
769 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
770 if mcode_equal kinda kindb
772 conjunct_bindings (check_mcode kinda kindb
)
773 (match_ident namea nameb
)
775 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
776 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
777 conjunct_many_bindings
778 [check_mcode lb1 lb
; check_mcode rb1 rb
;
780 match_dots match_decl
no_list do_nolist_match declsa declsb
]
781 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
782 if mcode_equal namea nameb
783 then check_mcode namea nameb
785 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
786 failwith
"not allowed in the pattern of an isomorphism"
787 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
788 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
789 | (_
,Ast0.OptType
(tyb
))
790 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
792 else return_false (ContextRequired
(Ast0.TypeCTag t
))
794 and match_decl pattern d
=
795 if not
(checks_needed
) or not
(context_required
) or is_context d
797 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
798 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
799 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
800 if bool_match_option mcode_equal stga stgb
802 conjunct_many_bindings
803 [check_mcode eq1 eq
; check_mcode sc1 sc
;
804 match_option check_mcode stga stgb
;
805 match_typeC tya tyb
; match_ident ida idb
;
806 match_init inia inib
]
808 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
809 if bool_match_option mcode_equal stga stgb
811 conjunct_many_bindings
812 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
813 match_typeC tya tyb
; match_ident ida idb
]
815 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
816 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
817 conjunct_many_bindings
818 [match_ident namea nameb
;
819 check_mcode lp1 lp
; check_mcode rp1 rp
;
821 match_dots match_expr is_elist_matcher do_elist_match
823 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
824 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
825 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
826 conjunct_bindings (check_mcode sc1 sc
)
827 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
828 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
829 failwith
"not allowed in the pattern of an isomorphism"
830 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
831 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
832 conjunct_bindings (check_mcode dd d
)
833 (* hope that mcode of ddots is unique somehow *)
834 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
835 if ddots_whencode_allowed
836 then add_dot_binding dd
(Ast0.DeclTag wc
)
838 (Printf.printf
"warning: not applying iso because of whencode";
840 | (Ast0.Ddots
(_
,Some _
),_
) ->
841 failwith
"whencode not allowed in a pattern1"
843 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
844 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
845 match_decl decla declb
846 | (_
,Ast0.OptDecl
(declb
))
847 | (_
,Ast0.UniqueDecl
(declb
)) ->
848 match_decl pattern declb
850 else return_false (ContextRequired
(Ast0.DeclTag d
))
852 and match_init pattern i
=
853 match Ast0.unwrap pattern
with
854 Ast0.MetaInit
(name
,pure
) ->
855 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
856 (function ini
-> Ast0.InitTag ini
)
859 if not
(checks_needed
) or not
(context_required
) or is_context i
861 match (up
,Ast0.unwrap i
) with
862 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
864 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
866 conjunct_many_bindings
867 [check_mcode lb1 lb
; check_mcode rb1 rb
;
868 match_dots match_init
no_list do_nolist_match
870 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
871 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
872 conjunct_many_bindings
873 [match_list match_designator
874 (function _
-> false) (function _
-> failwith
"")
875 designators1 designators2
;
877 match_init inia inib
]
878 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
879 conjunct_many_bindings
880 [check_mcode c1 c
; match_ident namea nameb
;
881 match_init inia inib
]
882 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
883 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
884 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
885 conjunct_bindings (check_mcode id d
)
886 (* hope that mcode of edots is unique somehow *)
887 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
888 if idots_whencode_allowed
889 then add_dot_binding id
(Ast0.InitTag wc
)
892 "warning: not applying iso because of whencode";
894 | (Ast0.Idots
(_
,Some _
),_
) ->
895 failwith
"whencode not allowed in a pattern2"
896 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
897 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
898 | (_
,Ast0.OptIni
(ib
))
899 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
901 else return_false (ContextRequired
(Ast0.InitTag i
))
903 and match_designator pattern d
=
904 match (pattern
,d
) with
905 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
906 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
907 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
908 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
909 conjunct_many_bindings
910 [check_mcode lba lbb
; match_expr expa expb
;
912 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
913 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
914 conjunct_many_bindings
915 [check_mcode lba lbb
; match_expr mina minb
;
916 check_mcode dotsa dotsb
; match_expr maxa maxb
;
920 and match_param pattern p
=
921 match Ast0.unwrap pattern
with
922 Ast0.MetaParam
(name
,pure
) ->
923 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
924 (function p
-> Ast0.ParamTag p
)
926 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
928 if not
(checks_needed
) or not
(context_required
) or is_context p
930 match (up
,Ast0.unwrap p
) with
931 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
932 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
933 conjunct_bindings (match_typeC tya tyb
)
934 (match_option match_ident ida idb
)
935 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
936 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
937 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
938 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
939 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
940 match_param parama paramb
941 | (_
,Ast0.OptParam
(paramb
))
942 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
944 else return_false (ContextRequired
(Ast0.ParamTag p
))
946 and match_statement pattern s
=
947 match Ast0.unwrap pattern
with
948 Ast0.MetaStmt
(name
,pure
) ->
949 (match Ast0.unwrap s
with
950 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
951 return false (* ... is not a single statement *)
953 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
954 (function ty
-> Ast0.StmtTag ty
)
956 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
958 if not
(checks_needed
) or not
(context_required
) or is_context s
960 match (up
,Ast0.unwrap s
) with
961 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
962 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
963 conjunct_many_bindings
964 [check_mcode lp1 lp
; check_mcode rp1 rp
;
965 check_mcode lb1 lb
; check_mcode rb1 rb
;
966 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
967 match_dots match_param
is_plist_matcher do_plist_match
969 match_dots match_statement
is_slist_matcher do_slist_match
971 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
972 match_decl decla declb
973 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
974 (* seqs can only match if they are all minus (plus code
975 allowed) or all context (plus code not allowed in the body).
976 we could be more permissive if the expansions of the isos are
977 also all seqs, but this would be hard to check except at top
978 level, and perhaps not worth checking even in that case.
979 Overall, the issue is that braces are used where single
980 statements are required, and something not satisfying these
981 conditions can cause a single statement to become a
982 non-single statement after the transformation.
984 example: if { ... -foo(); ... }
985 if we let the sequence convert to just -foo();
986 then we produce invalid code. For some reason,
987 single_statement can't deal with this case, perhaps because
988 it starts introducing too many braces? don't remember the
991 conjunct_bindings (check_mcode lb1 lb
)
992 (conjunct_bindings (check_mcode rb1 rb
)
993 (if not
(checks_needed
) or is_minus s
or
995 List.for_all
is_pure_context (Ast0.undots bodyb
))
997 match_dots match_statement
is_slist_matcher do_slist_match
999 else return_false (Braces
(s
))))
1000 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1001 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1002 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1003 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1004 conjunct_many_bindings
1005 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1006 check_mcode rp1 rp2
;
1007 match_expr expa expb
;
1008 match_statement branch1a branch1b
]
1009 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1010 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1011 conjunct_many_bindings
1012 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1013 check_mcode rp1 rp2
; check_mcode e1 e2
;
1014 match_expr expa expb
;
1015 match_statement branch1a branch1b
;
1016 match_statement branch2a branch2b
]
1017 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1018 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1019 conjunct_many_bindings
1020 [check_mcode w1 w
; check_mcode lp1 lp
;
1021 check_mcode rp1 rp
; match_expr expa expb
;
1022 match_statement bodya bodyb
]
1023 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1024 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1025 conjunct_many_bindings
1026 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1027 check_mcode rp1 rp
; match_statement bodya bodyb
;
1028 match_expr expa expb
]
1029 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1030 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1031 conjunct_many_bindings
1032 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1033 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1034 match_option match_expr e1a e1b
;
1035 match_option match_expr e2a e2b
;
1036 match_option match_expr e3a e3b
;
1037 match_statement bodya bodyb
]
1038 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1039 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1040 conjunct_many_bindings
1041 [match_ident nma nmb
;
1042 check_mcode lp1 lp
; check_mcode rp1 rp
;
1043 match_dots match_expr is_elist_matcher do_elist_match
1045 match_statement bodya bodyb
]
1046 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,casesa
,rb1
),
1047 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,casesb
,rb
)) ->
1048 conjunct_many_bindings
1049 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1050 check_mcode lb1 lb
; check_mcode rb1 rb
;
1051 match_expr expa expb
;
1052 match_dots match_case_line
no_list do_nolist_match
1054 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1055 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1056 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1057 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1058 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1059 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1060 conjunct_many_bindings
1061 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1062 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1063 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1064 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1065 conjunct_many_bindings
1066 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1067 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1068 failwith
"disj not supported in patterns"
1069 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1070 failwith
"nest not supported in patterns"
1071 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1072 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1073 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1074 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1075 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1076 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1077 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1078 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1080 [] -> check_mcode d d1
1082 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1083 if dots_whencode_allowed
1085 conjunct_bindings (check_mcode d d1
)
1089 | Ast0.WhenNot wc
->
1090 conjunct_bindings prev
1091 (add_multi_dot_binding d
1092 (Ast0.DotsStmtTag wc
))
1093 | Ast0.WhenAlways wc
->
1094 conjunct_bindings prev
1095 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1096 | Ast0.WhenNotTrue wc
->
1097 conjunct_bindings prev
1098 (add_multi_dot_binding d
1099 (Ast0.IsoWhenTTag wc
))
1100 | Ast0.WhenNotFalse wc
->
1101 conjunct_bindings prev
1102 (add_multi_dot_binding d
1103 (Ast0.IsoWhenFTag wc
))
1104 | Ast0.WhenModifier
(x) ->
1105 conjunct_bindings prev
1106 (add_multi_dot_binding d
1107 (Ast0.IsoWhenTag
x)))
1111 "warning: not applying iso because of whencode";
1113 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1114 | (Ast0.Stars
(_
,_
::_
),_
) ->
1115 failwith
"whencode not allowed in a pattern3"
1116 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1117 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1118 match_statement rea reb
1119 | (_
,Ast0.OptStm
(reb
))
1120 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1122 else return_false (ContextRequired
(Ast0.StmtTag s
))
1124 (* first should provide a subset of the information in the second *)
1125 and match_fninfo patterninfo cinfo
=
1126 let patterninfo = List.sort compare
patterninfo in
1127 let cinfo = List.sort compare
cinfo in
1128 let rec loop = function
1129 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1130 if mcode_equal sta stb
1131 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1133 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1134 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1135 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1136 if mcode_equal ia ib
1137 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1139 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1140 if mcode_equal ia ib
1141 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1143 | (x::resta
,((y
::_
) as restb
)) ->
1144 (match compare
x y
with
1146 | 1 -> loop (resta
,restb
)
1147 | _
-> failwith
"not possible")
1148 | _
-> return false in
1149 loop (patterninfo,cinfo)
1151 and match_case_line pattern c
=
1152 if not
(checks_needed
) or not
(context_required
) or is_context c
1154 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1155 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1156 conjunct_many_bindings
1157 [check_mcode d1 d
; check_mcode c1 c
;
1158 match_dots match_statement
is_slist_matcher do_slist_match
1160 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1161 conjunct_many_bindings
1162 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1163 match_dots match_statement
is_slist_matcher do_slist_match
1165 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1166 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1168 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1170 let match_statement_dots x y
=
1171 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1173 (match_expr, match_decl
, match_statement
, match_typeC
,
1174 match_statement_dots)
1176 let match_expr dochecks context_required whencode_allowed
=
1177 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1180 let match_decl dochecks context_required whencode_allowed
=
1181 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1184 let match_statement dochecks context_required whencode_allowed
=
1185 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1188 let match_typeC dochecks context_required whencode_allowed
=
1189 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1192 let match_statement_dots dochecks context_required whencode_allowed
=
1193 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1196 (* --------------------------------------------------------------------- *)
1197 (* make an entire tree MINUS *)
1200 let mcode (term,arity
,info
,mcodekind
,pos
) =
1202 match mcodekind
with
1205 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1206 | _
-> failwith
"make_minus: unexpected befaft")
1207 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1208 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1209 (term,arity
,info
,new_mcodekind,pos
) in
1211 let update_mc mcodekind e
=
1212 match !mcodekind
with
1215 (Ast.NOTHING
,_
,_
) ->
1216 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1217 | _
-> failwith
"make_minus: unexpected befaft")
1218 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1219 | Ast0.PLUS
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1220 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1222 let donothing r k e
=
1223 let mcodekind = Ast0.get_mcodekind_ref e
in
1224 let e = k
e in update_mc mcodekind e; e in
1226 (* special case for whencode, because it isn't processed by contextneg,
1227 since it doesn't appear in the + code *)
1228 (* cases for dots and nests *)
1229 let expression r k
e =
1230 let mcodekind = Ast0.get_mcodekind_ref
e in
1231 match Ast0.unwrap
e with
1232 Ast0.Edots
(d
,whencode
) ->
1233 (*don't recurse because whencode hasn't been processed by context_neg*)
1234 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1235 | Ast0.Ecircles
(d
,whencode
) ->
1236 (*don't recurse because whencode hasn't been processed by context_neg*)
1237 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1238 | Ast0.Estars
(d
,whencode
) ->
1239 (*don't recurse because whencode hasn't been processed by context_neg*)
1240 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1241 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1242 update_mc mcodekind e;
1244 (Ast0.NestExpr
(mcode starter
,
1245 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1246 mcode ender
,whencode
,multi
))
1247 | _
-> donothing r k
e in
1249 let declaration r k
e =
1250 let mcodekind = Ast0.get_mcodekind_ref
e in
1251 match Ast0.unwrap
e with
1252 Ast0.Ddots
(d
,whencode
) ->
1253 (*don't recurse because whencode hasn't been processed by context_neg*)
1254 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1255 | _
-> donothing r k
e in
1257 let statement r k
e =
1258 let mcodekind = Ast0.get_mcodekind_ref
e in
1259 match Ast0.unwrap
e with
1260 Ast0.Dots
(d
,whencode
) ->
1261 (*don't recurse because whencode hasn't been processed by context_neg*)
1262 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1263 | Ast0.Circles
(d
,whencode
) ->
1264 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1265 | Ast0.Stars
(d
,whencode
) ->
1266 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1267 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1268 update_mc mcodekind e;
1271 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1272 mcode ender
,whencode
,multi
))
1273 | _
-> donothing r k
e in
1275 let initialiser r k
e =
1276 let mcodekind = Ast0.get_mcodekind_ref
e in
1277 match Ast0.unwrap
e with
1278 Ast0.Idots
(d
,whencode
) ->
1279 (*don't recurse because whencode hasn't been processed by context_neg*)
1280 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1281 | _
-> donothing r k
e in
1284 let info = Ast0.get_info
e in
1285 let mcodekind = Ast0.get_mcodekind_ref
e in
1286 match Ast0.unwrap
e with
1288 (* if context is - this should be - as well. There are no tokens
1289 here though, so the bottom-up minusifier in context_neg leaves it
1290 as mixed (or context for sgrep2). It would be better to fix
1291 context_neg, but that would
1292 require a special case for each term with a dots subterm. *)
1293 (match !mcodekind with
1294 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1296 (Ast.NOTHING
,_
,_
) ->
1297 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1299 | _
-> failwith
"make_minus: unexpected befaft")
1300 (* code already processed by an enclosing iso *)
1301 | Ast0.MINUS
(mc
) -> e
1305 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1306 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1307 | _
-> donothing r k
e in
1310 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1311 dots dots dots dots dots dots
1312 donothing expression donothing initialiser donothing declaration
1313 statement donothing donothing
1315 (* --------------------------------------------------------------------- *)
1316 (* rebuild mcode cells in an instantiated alt *)
1318 (* mcodes will be side effected later with plus code, so we have to copy
1319 them on instantiating an isomorphism. One could wonder whether it would
1320 be better not to use side-effects, but they are convenient for insert_plus
1321 where is it useful to manipulate a list of the mcodes but side-effect a
1323 (* hmm... Insert_plus is called before Iso_pattern... *)
1324 let rebuild_mcode start_line
=
1325 let copy_mcodekind = function
1326 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1327 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1328 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1330 (* this function is used elsewhere where we need to rebuild the
1331 indices, and so we allow PLUS code as well *)
1334 let mcode (term,arity
,info,mcodekind,pos
) =
1336 match start_line
with
1339 {info.Ast0.pos_info
with
1340 Ast0.line_start
= x;
1341 Ast0.line_end
= x; } in
1342 {info with Ast0.pos_info
= new_pos_info}
1344 (term,arity
,info,copy_mcodekind mcodekind,pos
) in
1347 let old_info = Ast0.get_info
x in
1349 match start_line
with
1352 {old_info.Ast0.pos_info
with
1353 Ast0.line_start
= x;
1354 Ast0.line_end
= x; } in
1355 {old_info with Ast0.pos_info
= new_pos_info}
1356 | None
-> old_info in
1357 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1358 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1360 let donothing r k
e = copy_one (k
e) in
1362 (* case for control operators (if, etc) *)
1363 let statement r k
e =
1368 (match Ast0.unwrap
s with
1369 Ast0.Decl
((info,mc
),decl
) ->
1370 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1371 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1372 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1373 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1374 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1375 (info,copy_mcodekind mc
))
1376 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1377 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1378 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1379 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1380 (info,copy_mcodekind mc
))
1381 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,mc
)) ->
1382 Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1384 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1386 ((info,copy_mcodekind mc
),
1387 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1389 Ast0.set_dots_bef_aft
res
1390 (match Ast0.get_dots_bef_aft
res with
1391 Ast0.NoDots
-> Ast0.NoDots
1392 | Ast0.AddingBetweenDots
s ->
1393 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1394 | Ast0.DroppingBetweenDots
s ->
1395 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1398 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1399 donothing donothing donothing donothing donothing donothing
1400 donothing donothing donothing donothing donothing
1401 donothing statement donothing donothing
1403 (* --------------------------------------------------------------------- *)
1404 (* The problem of whencode. If an isomorphism contains dots in multiple
1405 rules, then the code that is matched cannot contain whencode, because we
1406 won't know which dots it goes with. Should worry about nests, but they
1407 aren't allowed in isomorphisms for the moment. *)
1410 let option_default = 0 in
1411 let bind x y
= x + y
in
1413 match Ast0.unwrap
e with
1414 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1417 V0.combiner
bind option_default
1418 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1421 let option_default = 0 in
1422 let bind x y
= x + y
in
1424 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1426 V0.combiner
bind option_default
1427 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1430 let option_default = 0 in
1431 let bind x y
= x + y
in
1433 match Ast0.unwrap
e with
1434 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1437 V0.combiner
bind option_default
1438 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1440 (* --------------------------------------------------------------------- *)
1442 let lookup name bindings mv_bindings
=
1443 try Common.Left
(List.assoc
(term name
) bindings
)
1446 (* failure is not possible anymore *)
1447 Common.Right
(List.assoc
(term name
) mv_bindings
)
1449 (* mv_bindings is for the fresh metavariables that are introduced by the
1451 let instantiate bindings mv_bindings
=
1453 match Ast0.get_pos
x with
1454 Ast0.MetaPos
(name
,_
,_
) ->
1456 match lookup name bindings mv_bindings
with
1457 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1458 | _
-> failwith
"not possible"
1459 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1461 let donothing r k
e = k
e in
1463 (* cases where metavariables can occur *)
1466 match Ast0.unwrap
e with
1467 Ast0.MetaId
(name
,constraints
,pure
) ->
1468 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1469 (match lookup name bindings mv_bindings
with
1470 Common.Left
(Ast0.IdentTag
(id
)) -> id
1471 | Common.Left
(_
) -> failwith
"not possible 1"
1472 | Common.Right
(new_mv
) ->
1475 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1476 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1477 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1480 (* case for list metavariables *)
1481 let rec elist r same_dots
= function
1484 (match Ast0.unwrap
x with
1485 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1486 failwith
"meta_expr_list in iso not supported"
1487 (*match lookup name bindings mv_bindings with
1488 Common.Left(Ast0.DotsExprTag(exp)) ->
1489 (match same_dots exp with
1491 | None -> failwith "dots put in incompatible context")
1492 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1493 | Common.Left(_) -> failwith "not possible 1"
1494 | Common.Right(new_mv) ->
1495 failwith "MetaExprList in SP not supported"*)
1496 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1497 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1499 let rec plist r same_dots
= function
1502 (match Ast0.unwrap
x with
1503 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1504 failwith
"meta_param_list in iso not supported"
1505 (*match lookup name bindings mv_bindings with
1506 Common.Left(Ast0.DotsParamTag(param)) ->
1507 (match same_dots param with
1509 | None -> failwith "dots put in incompatible context")
1510 | Common.Left(Ast0.ParamTag(param)) -> [param]
1511 | Common.Left(_) -> failwith "not possible 1"
1512 | Common.Right(new_mv) ->
1513 failwith "MetaExprList in SP not supported"*)
1514 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1515 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1517 let rec slist r same_dots
= function
1520 (match Ast0.unwrap
x with
1521 Ast0.MetaStmtList
(name
,pure
) ->
1522 (match lookup name bindings mv_bindings
with
1523 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1524 (match same_dots stm
with
1526 | None
-> failwith
"dots put in incompatible context")
1527 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1528 | Common.Left
(_
) -> failwith
"not possible 1"
1529 | Common.Right
(new_mv
) ->
1530 failwith
"MetaExprList in SP not supported")
1531 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1532 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1535 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1536 let same_circles d
=
1537 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1539 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1541 let dots list_fn r k d
=
1543 (match Ast0.unwrap d
with
1544 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1545 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1546 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1548 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1551 match Ast0.unwrap
e with
1552 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1553 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1554 (match lookup name bindings mv_bindings
with
1555 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1556 | Common.Left
(_
) -> failwith
"not possible 1"
1557 | Common.Right
(new_mv
) ->
1562 let rec renamer = function
1563 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1565 lookup (name
,(),(),(),None
) bindings mv_bindings
1567 Common.Left
(Ast0.TypeCTag
(t
)) ->
1568 Ast0.ast0_type_to_type t
1570 failwith
"iso pattern: unexpected type"
1571 | Common.Right
(new_mv
) ->
1572 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1573 | Type_cocci.ConstVol
(cv
,ty
) ->
1574 Type_cocci.ConstVol
(cv
,renamer ty
)
1575 | Type_cocci.Pointer
(ty
) ->
1576 Type_cocci.Pointer
(renamer ty
)
1577 | Type_cocci.FunctionPointer
(ty
) ->
1578 Type_cocci.FunctionPointer
(renamer ty
)
1579 | Type_cocci.Array
(ty
) ->
1580 Type_cocci.Array
(renamer ty
)
1582 Some
(List.map
renamer types
) in
1585 (Ast0.set_mcode_data new_mv name
,constraints
,
1586 new_types,form
,pure
)))
1587 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1588 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1589 failwith
"metaexprlist not supported"
1590 | Ast0.Unary
(exp
,unop
) ->
1591 (match Ast0.unwrap_mcode unop
with
1594 (* k e doesn't change the outer structure of the term,
1595 only the metavars *)
1596 match Ast0.unwrap old_e
with
1597 Ast0.Unary
(exp
,_
) ->
1598 (match Ast0.unwrap exp
with
1599 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1601 | _
-> failwith
"not possible" in
1603 let mc = Ast0.get_mcodekind exp
in
1609 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1611 (Ast.NOTHING
,_
,_
) -> true
1613 | _
-> failwith
"plus not possible" in
1614 if was_meta && nomodif exp
&& nomodif e
1617 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1618 (* k accumulates parens, to keep negation outside if no
1619 propagation is possible *)
1620 match Ast0.unwrap
res with
1621 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
->
1622 k
(Ast0.rewrap
e (Ast0.unwrap
e1))
1623 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1624 | Ast0.Paren
(lp
,e,rp
) ->
1627 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1628 | Ast0.Binary
(e1,op
,e2
) ->
1629 let reb nop
= Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1630 let k1 x = k
(Ast0.rewrap
e x) in
1631 (match Ast0.unwrap_mcode op
with
1632 Ast.Logical
(Ast.Inf
) ->
1633 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1634 | Ast.Logical
(Ast.Sup
) ->
1635 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1636 | Ast.Logical
(Ast.InfEq
) ->
1637 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1638 | Ast.Logical
(Ast.SupEq
) ->
1639 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1640 | Ast.Logical
(Ast.Eq
) ->
1641 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1642 | Ast.Logical
(Ast.NotEq
) ->
1643 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1644 | Ast.Logical
(Ast.AndLog
) ->
1645 k1 (Ast0.Binary
(negate e1 e1 idcont,reb Ast.OrLog
,
1646 negate e2 e2
idcont))
1647 | Ast.Logical
(Ast.OrLog
) ->
1648 k1 (Ast0.Binary
(negate e1 e1 idcont,reb Ast.AndLog
,
1649 negate e2 e2
idcont))
1652 (Ast0.Unary
(k
res,Ast0.rewrap_mcode op
Ast.Not
)))
1653 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1654 (* use res because it is the transformed argument *)
1655 let exps = List.map
(function e -> negate e e k
) exps in
1656 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1658 (*use e, because this might be the toplevel expression*)
1660 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
)) in
1664 | Ast0.Edots
(d
,_
) ->
1666 (match List.assoc
(dot_term d
) bindings
with
1667 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1668 | _
-> failwith
"unexpected binding")
1669 with Not_found
-> e)
1670 | Ast0.Ecircles
(d
,_
) ->
1672 (match List.assoc
(dot_term d
) bindings
with
1673 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1674 | _
-> failwith
"unexpected binding")
1675 with Not_found
-> e)
1676 | Ast0.Estars
(d
,_
) ->
1678 (match List.assoc
(dot_term d
) bindings
with
1679 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1680 | _
-> failwith
"unexpected binding")
1681 with Not_found
-> e)
1683 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1687 match Ast0.unwrap
e with
1688 Ast0.MetaType
(name
,pure
) ->
1689 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1690 (match lookup name bindings mv_bindings
with
1691 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1692 | Common.Left
(_
) -> failwith
"not possible 1"
1693 | Common.Right
(new_mv
) ->
1695 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1700 match Ast0.unwrap
e with
1701 Ast0.MetaInit
(name
,pure
) ->
1702 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1703 (match lookup name bindings mv_bindings
with
1704 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1705 | Common.Left
(_
) -> failwith
"not possible 1"
1706 | Common.Right
(new_mv
) ->
1708 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1713 match Ast0.unwrap
e with
1716 (match List.assoc
(dot_term d
) bindings
with
1717 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1718 | _
-> failwith
"unexpected binding")
1719 with Not_found
-> e)
1724 match Ast0.unwrap
e with
1725 Ast0.MetaParam
(name
,pure
) ->
1726 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1727 (match lookup name bindings mv_bindings
with
1728 Common.Left
(Ast0.ParamTag
(param)) -> param
1729 | Common.Left
(_
) -> failwith
"not possible 1"
1730 | Common.Right
(new_mv
) ->
1732 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1733 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1734 failwith
"metaparamlist not supported"
1739 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1740 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1741 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1742 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1743 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1744 | _
-> failwith
"unexpected binding" in
1748 match Ast0.unwrap
e with
1749 Ast0.MetaStmt
(name
,pure
) ->
1750 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1751 (match lookup name bindings mv_bindings
with
1752 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1753 | Common.Left
(_
) -> failwith
"not possible 1"
1754 | Common.Right
(new_mv
) ->
1756 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1757 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1763 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1764 | Ast0.Circles
(d
,_
) ->
1769 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1770 | Ast0.Stars
(d
,_
) ->
1775 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1779 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1780 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1781 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1783 (* --------------------------------------------------------------------- *)
1786 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1788 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1790 let disj_fail bindings
e =
1792 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1795 (* isomorphism code is by default CONTEXT *)
1796 let merge_plus model_mcode e_mcode
=
1797 match model_mcode
with
1799 (* add the replacement information at the root *)
1803 (match (!mc,!emc
) with
1804 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1805 | _
-> failwith
"how can we combine minuses?")
1806 | _
-> failwith
"not possible 6")
1807 | Ast0.CONTEXT
(mc) ->
1809 Ast0.CONTEXT
(emc
) ->
1810 (* keep the logical line info as in the model *)
1811 let (mba
,tb
,ta
) = !mc in
1812 let (eba
,_
,_
) = !emc
in
1813 (* merging may be required when a term is replaced by a subterm *)
1815 match (mba
,eba
) with
1816 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1817 | (Ast.BEFORE
(b1
),Ast.BEFORE
(b2
)) -> Ast.BEFORE
(b1
@b2
)
1818 | (Ast.BEFORE
(b
),Ast.AFTER
(a
)) -> Ast.BEFOREAFTER
(b
,a
)
1819 | (Ast.BEFORE
(b1
),Ast.BEFOREAFTER
(b2
,a
)) ->
1820 Ast.BEFOREAFTER
(b1
@b2
,a
)
1821 | (Ast.AFTER
(a
),Ast.BEFORE
(b
)) -> Ast.BEFOREAFTER
(b
,a
)
1822 | (Ast.AFTER
(a1
),Ast.AFTER
(a2
)) ->Ast.AFTER
(a2
@a1
)
1823 | (Ast.AFTER
(a1
),Ast.BEFOREAFTER
(b
,a2
)) -> Ast.BEFOREAFTER
(b
,a2
@a1
)
1824 | (Ast.BEFOREAFTER
(b1
,a
),Ast.BEFORE
(b2
)) ->
1825 Ast.BEFOREAFTER
(b1
@b2
,a
)
1826 | (Ast.BEFOREAFTER
(b
,a1
),Ast.AFTER
(a2
)) ->
1827 Ast.BEFOREAFTER
(b
,a2
@a1
)
1828 | (Ast.BEFOREAFTER
(b1
,a1
),Ast.BEFOREAFTER
(b2
,a2
)) ->
1829 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
) in
1830 emc
:= (merged,tb
,ta
)
1831 | Ast0.MINUS
(emc
) ->
1832 let (anything_bef_aft
,_
,_
) = !mc in
1833 let (anythings
,t
) = !emc
in
1835 (match anything_bef_aft
with
1836 Ast.BEFORE
(b
) -> (b
@anythings
,t
)
1837 | Ast.AFTER
(a
) -> (anythings
@a
,t
)
1838 | Ast.BEFOREAFTER
(b
,a
) -> (b
@anythings
@a
,t
)
1839 | Ast.NOTHING
-> (anythings
,t
))
1840 | _
-> failwith
"not possible 7")
1841 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1842 | Ast0.PLUS
-> failwith
"not possible 9"
1844 let copy_plus printer minusify model
e =
1845 if !Flag.sgrep_mode2
1846 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1849 match Ast0.get_mcodekind model
with
1850 Ast0.MINUS
(mc) -> minusify
e
1851 | Ast0.CONTEXT
(mc) -> e
1852 | _
-> failwith
"not possible: copy_plus\n" in
1853 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1856 let copy_minus printer minusify model
e =
1857 match Ast0.get_mcodekind model
with
1858 Ast0.MINUS
(mc) -> minusify
e
1859 | Ast0.CONTEXT
(mc) -> e
1861 if !Flag.sgrep_mode2
1863 else failwith
"not possible 8"
1864 | Ast0.PLUS
-> failwith
"not possible 9"
1866 let whencode_allowed prev_ecount prev_icount prev_dcount
1867 ecount icount dcount rest
=
1868 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1870 let other_ecount = (* number of edots *)
1871 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1873 let other_icount = (* number of dots *)
1874 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1876 let other_dcount = (* number of dots *)
1877 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1879 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1880 dcount
= 0 or other_dcount = 0)
1882 (* copy the befores and afters to the instantiated code *)
1883 let extra_copy_stmt_plus model
e =
1884 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1886 (match Ast0.unwrap model
with
1887 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1888 | Ast0.Decl
((info,bef
),_
) ->
1889 (match Ast0.unwrap
e with
1890 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1891 | Ast0.Decl
((info,bef1
),_
) ->
1893 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1894 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1895 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1896 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1897 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1898 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1899 (match Ast0.unwrap
e with
1900 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1901 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1902 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1903 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1904 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1906 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1910 let extra_copy_other_plus model
e = e
1912 (* --------------------------------------------------------------------- *)
1914 let mv_count = ref 0
1916 let ct = !mv_count in
1917 mv_count := !mv_count + 1;
1918 "_"^
s^
"_"^
(string_of_int
ct)
1920 let get_name = function
1921 Ast.MetaIdDecl
(ar
,nm
) ->
1922 (nm
,function nm
-> Ast.MetaIdDecl
(ar
,nm
))
1923 | Ast.MetaFreshIdDecl
(nm
,seed
) ->
1924 (nm
,function nm
-> Ast.MetaFreshIdDecl
(nm
,seed
))
1925 | Ast.MetaTypeDecl
(ar
,nm
) ->
1926 (nm
,function nm
-> Ast.MetaTypeDecl
(ar
,nm
))
1927 | Ast.MetaInitDecl
(ar
,nm
) ->
1928 (nm
,function nm
-> Ast.MetaInitDecl
(ar
,nm
))
1929 | Ast.MetaListlenDecl
(nm
) ->
1930 failwith
"should not be rebuilt"
1931 | Ast.MetaParamDecl
(ar
,nm
) ->
1932 (nm
,function nm
-> Ast.MetaParamDecl
(ar
,nm
))
1933 | Ast.MetaParamListDecl
(ar
,nm
,nm1
) ->
1934 (nm
,function nm
-> Ast.MetaParamListDecl
(ar
,nm
,nm1
))
1935 | Ast.MetaConstDecl
(ar
,nm
,ty
) ->
1936 (nm
,function nm
-> Ast.MetaConstDecl
(ar
,nm
,ty
))
1937 | Ast.MetaErrDecl
(ar
,nm
) ->
1938 (nm
,function nm
-> Ast.MetaErrDecl
(ar
,nm
))
1939 | Ast.MetaExpDecl
(ar
,nm
,ty
) ->
1940 (nm
,function nm
-> Ast.MetaExpDecl
(ar
,nm
,ty
))
1941 | Ast.MetaIdExpDecl
(ar
,nm
,ty
) ->
1942 (nm
,function nm
-> Ast.MetaIdExpDecl
(ar
,nm
,ty
))
1943 | Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
) ->
1944 (nm
,function nm
-> Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
))
1945 | Ast.MetaExpListDecl
(ar
,nm
,nm1
) ->
1946 (nm
,function nm
-> Ast.MetaExpListDecl
(ar
,nm
,nm1
))
1947 | Ast.MetaStmDecl
(ar
,nm
) ->
1948 (nm
,function nm
-> Ast.MetaStmDecl
(ar
,nm
))
1949 | Ast.MetaStmListDecl
(ar
,nm
) ->
1950 (nm
,function nm
-> Ast.MetaStmListDecl
(ar
,nm
))
1951 | Ast.MetaFuncDecl
(ar
,nm
) ->
1952 (nm
,function nm
-> Ast.MetaFuncDecl
(ar
,nm
))
1953 | Ast.MetaLocalFuncDecl
(ar
,nm
) ->
1954 (nm
,function nm
-> Ast.MetaLocalFuncDecl
(ar
,nm
))
1955 | Ast.MetaPosDecl
(ar
,nm
) ->
1956 (nm
,function nm
-> Ast.MetaPosDecl
(ar
,nm
))
1957 | Ast.MetaDeclarerDecl
(ar
,nm
) ->
1958 (nm
,function nm
-> Ast.MetaDeclarerDecl
(ar
,nm
))
1959 | Ast.MetaIteratorDecl
(ar
,nm
) ->
1960 (nm
,function nm
-> Ast.MetaIteratorDecl
(ar
,nm
))
1962 let make_new_metavars metavars bindings
=
1966 let (s,_
) = get_name mv
in
1967 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
1972 let (s,rebuild
) = get_name mv
in
1973 let new_s = (!current_rule,new_mv s) in
1974 (rebuild
new_s, (s,new_s)))
1977 (* --------------------------------------------------------------------- *)
1979 let do_nothing x = x
1981 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
1982 rebuild_mcodes name printer extra_plus update_others
=
1983 let call_instantiate bindings mv_bindings alts
=
1986 (function (a
,_,_,_) ->
1988 (* no need to create duplicates when the bindings have no effect *)
1990 (function bindings
->
1992 (copy_plus printer minusify
e
1994 (instantiater bindings mv_bindings
1995 (rebuild_mcodes a
))))
1996 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
1999 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2000 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2001 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2003 whencode_allowed prev_ecount prev_icount prev_dcount
2004 ecount dcount icount rest
in
2005 (match matcher
true (context_required e) wc pattern
e init_env with
2007 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2010 (match matcher
false false wc pattern
e init_env with
2012 interpret_reason name
(Ast0.get_line
e) reason
2013 (function () -> printer
e)
2015 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2016 (prev_dcount
+ dcount
) rest
2017 | OK
(bindings
: (((string * string) * 'a
) list list
)) ->
2019 (* apply update_others to all patterns other than the matched
2020 one. This is used to desigate the others as test
2021 expressions in the TestExpression case *)
2023 (function (x,e,i
,d
) as all
->
2026 else (update_others
x,e,i
,d
))
2027 (List.hd
all_alts)) ::
2029 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2030 (List.tl
all_alts)) in
2031 (match List.concat
all_alts with
2032 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2034 let (new_metavars,mv_bindings
) =
2035 make_new_metavars metavars
(nub(List.concat bindings
)) in
2038 call_instantiate bindings mv_bindings
all_alts))) in
2039 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2040 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2041 | (alts
::rest
) as all_alts ->
2042 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2043 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2044 outer_loop prev_ecount prev_icount prev_dcount rest
2045 | Common.Right
(new_metavars,res) ->
2047 copy_minus printer minusify
e (disj_maker
res)) in
2048 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2049 (count
, metavars
, e)
2051 (* no one should ever look at the information stored in these mcodes *)
2052 let disj_starter lst
=
2053 let old_info = Ast0.get_info
(List.hd lst
) in
2055 { old_info.Ast0.pos_info
with
2056 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2057 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2059 { Ast0.pos_info
= new_pos_info;
2060 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2061 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2062 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2063 Ast0.make_mcode_info
"(" info
2065 let disj_ender lst
=
2066 let old_info = Ast0.get_info
(List.hd lst
) in
2068 { old_info.Ast0.pos_info
with
2069 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2070 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2072 { Ast0.pos_info
= new_pos_info;
2073 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2074 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2075 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2076 Ast0.make_mcode_info
")" info
2078 let disj_mid _ = Ast0.make_mcode
"|"
2080 let make_disj_type tl
=
2083 [] -> failwith
"bad disjunction"
2084 | x::xs
-> List.map
disj_mid xs
in
2085 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2086 let make_disj_stmt_list tl
=
2089 [] -> failwith
"bad disjunction"
2090 | x::xs
-> List.map
disj_mid xs
in
2091 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2092 let make_disj_expr model el
=
2095 [] -> failwith
"bad disjunction"
2096 | x::xs
-> List.map
disj_mid xs
in
2098 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2100 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2101 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2102 let el = List.map
update_arg (List.map
update_test el) in
2103 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2104 let make_disj_decl dl
=
2107 [] -> failwith
"bad disjunction"
2108 | x::xs
-> List.map
disj_mid xs
in
2109 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2110 let make_disj_stmt sl
=
2111 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2114 [] -> failwith
"bad disjunction"
2115 | x::xs
-> List.map
disj_mid xs
in
2117 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2119 let transform_type (metavars
,alts
,name
) e =
2121 (Ast0.TypeCTag
(_)::_)::_ ->
2122 (* start line is given to any leaves in the iso code *)
2124 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2130 (p
,count_edots.VT0.combiner_rec_typeC p
,
2131 count_idots.VT0.combiner_rec_typeC p
,
2132 count_dots.VT0.combiner_rec_typeC p
)
2133 | _ -> failwith
"invalid alt"))
2135 mkdisj match_typeC metavars
alts e
2136 (function b
-> function mv_b
->
2137 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2138 (function t
-> Ast0.TypeCTag t
)
2139 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2140 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2141 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2145 let transform_expr (metavars
,alts,name
) e =
2146 let process update_others
=
2147 (* start line is given to any leaves in the iso code *)
2149 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2154 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2155 (p
,count_edots.VT0.combiner_rec_expression p
,
2156 count_idots.VT0.combiner_rec_expression p
,
2157 count_dots.VT0.combiner_rec_expression p
)
2158 | _ -> failwith
"invalid alt"))
2160 mkdisj match_expr metavars
alts e
2161 (function b
-> function mv_b
->
2162 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2163 (function e -> Ast0.ExprTag
e)
2165 make_minus.VT0.rebuilder_rec_expression
2166 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2167 name
Unparse_ast0.expression extra_copy_other_plus update_others
in
2169 (Ast0.ExprTag
(_)::_)::_ -> process do_nothing
2170 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2171 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2172 process Ast0.set_test_exp
2175 let transform_decl (metavars
,alts,name
) e =
2177 (Ast0.DeclTag
(_)::_)::_ ->
2178 (* start line is given to any leaves in the iso code *)
2180 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2186 (p
,count_edots.VT0.combiner_rec_declaration p
,
2187 count_idots.VT0.combiner_rec_declaration p
,
2188 count_dots.VT0.combiner_rec_declaration p
)
2189 | _ -> failwith
"invalid alt"))
2191 mkdisj match_decl metavars
alts e
2192 (function b
-> function mv_b
->
2193 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2194 (function d
-> Ast0.DeclTag d
)
2196 make_minus.VT0.rebuilder_rec_declaration
2197 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2198 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2201 let transform_stmt (metavars
,alts,name
) e =
2203 (Ast0.StmtTag
(_)::_)::_ ->
2204 (* start line is given to any leaves in the iso code *)
2206 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2212 (p
,count_edots.VT0.combiner_rec_statement p
,
2213 count_idots.VT0.combiner_rec_statement p
,
2214 count_dots.VT0.combiner_rec_statement p
)
2215 | _ -> failwith
"invalid alt"))
2217 mkdisj match_statement metavars
alts e
2218 (function b
-> function mv_b
->
2219 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2220 (function s -> Ast0.StmtTag
s)
2221 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2222 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2223 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2226 (* sort of a hack, because there is no disj at top level *)
2227 let transform_top (metavars
,alts,name
) e =
2228 match Ast0.unwrap
e with
2229 Ast0.DECL
(declstm
) ->
2235 Ast0.DotsStmtTag
(d
) ->
2236 (match Ast0.unwrap d
with
2237 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2238 | _ -> raise
(Failure
""))
2239 | _ -> raise
(Failure
"")))
2241 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2242 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2243 with Failure
_ -> (0,[],e))
2244 | Ast0.CODE
(stmts
) ->
2245 let (count
,mv
,res) =
2247 (Ast0.DotsStmtTag
(_)::_)::_ ->
2248 (* start line is given to any leaves in the iso code *)
2250 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2255 Ast0.DotsStmtTag
(p
) ->
2256 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2257 count_idots.VT0.combiner_rec_statement_dots p
,
2258 count_dots.VT0.combiner_rec_statement_dots p
)
2259 | _ -> failwith
"invalid alt"))
2261 mkdisj match_statement_dots metavars
alts stmts
2262 (function b
-> function mv_b
->
2263 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2264 (function s -> Ast0.DotsStmtTag
s)
2266 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2268 make_minus.VT0.rebuilder_rec_statement_dots
x)
2269 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2270 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2271 | _ -> (0,[],stmts
) in
2272 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2275 (* --------------------------------------------------------------------- *)
2277 let transform (alts : isomorphism
) t
=
2278 (* the following ugliness is because rebuilder only returns a new term *)
2279 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2280 let in_limit n
= function
2284 ((if !Flag_parsing_cocci.show_iso_failures
2285 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2287 let bind x y
= x + y
in
2288 let option_default = 0 in
2290 let (e_count
,e) = k
e in
2291 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2293 let (count
,extra_meta
,exp
) = transform_expr alts e in
2294 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2295 (bind count e_count
,exp
)
2299 let (e_count
,e) = k
e in
2300 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2302 let (count
,extra_meta
,dec
) = transform_decl alts e in
2303 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2304 (bind count e_count
,dec
)
2308 let (e_count
,e) = k
e in
2309 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2311 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2312 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2313 (bind count e_count
,stm
)
2317 let (continue
,e_count
,e) =
2318 match Ast0.unwrap
e with
2319 Ast0.Signed
(signb
,tyb
) ->
2320 (* Hack! How else to prevent iso from applying under an
2324 let (e_count
,e) = k
e in
2325 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2326 then (true,e_count
,e)
2327 else (false,e_count
,e) in
2330 let (count
,extra_meta
,ty
) = transform_type alts e in
2331 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2332 (bind count e_count
,ty
)
2336 let (e_count
,e) = k
e in
2337 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2339 let (count
,extra_meta
,ty
) = transform_top alts e in
2340 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2341 (bind count e_count
,ty
)
2345 V0.combiner_rebuilder
bind option_default
2346 {V0.combiner_rebuilder_functions
with
2347 VT0.combiner_rebuilder_exprfn
= exprfn;
2348 VT0.combiner_rebuilder_tyfn
= typefn;
2349 VT0.combiner_rebuilder_declfn
= declfn;
2350 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2351 VT0.combiner_rebuilder_topfn
= topfn} in
2352 let (_,res) = res.VT0.top_level t
in
2353 (!extra_meta_decls,res)
2355 (* --------------------------------------------------------------------- *)
2357 (* should be done by functorizing the parser to use wrap or context_wrap *)
2359 let mcode (x,a
,i
,mc,pos
) = (x,a
,i
,Ast0.context_befaft
(),pos
) in
2360 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2362 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2363 donothing donothing donothing donothing donothing donothing
2364 donothing donothing donothing donothing donothing donothing donothing
2367 let rewrap_anything = function
2368 Ast0.DotsExprTag
(d
) ->
2369 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2370 | Ast0.DotsInitTag
(d
) ->
2371 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2372 | Ast0.DotsParamTag
(d
) ->
2373 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2374 | Ast0.DotsStmtTag
(d
) ->
2375 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2376 | Ast0.DotsDeclTag
(d
) ->
2377 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2378 | Ast0.DotsCaseTag
(d
) ->
2379 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2380 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2381 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2382 | Ast0.ArgExprTag
(d
) ->
2383 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2384 | Ast0.TestExprTag
(d
) ->
2385 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2386 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2387 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2388 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2389 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2390 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2391 | Ast0.CaseLineTag
(d
) ->
2392 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2393 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2394 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2395 failwith
"only for isos within iso phase"
2396 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2398 (* --------------------------------------------------------------------- *)
2400 let apply_isos isos rule rule_name
=
2405 current_rule := rule_name
;
2408 (function (metavars
,iso
,name
) ->
2409 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2411 let (extra_meta
,rule
) =
2416 (function (extra_meta
,t
) -> function iso
->
2417 let (new_extra_meta
,t
) = transform iso t
in
2418 (new_extra_meta
@extra_meta
,t
))
2421 (List.concat extra_meta
, Compute_lines.compute_lines rule
)
HCoop / bpt / coccinelle.git / blob