2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* Potential problem: offset of mcode is not updated when an iso is
24 instantiated, implying that a term may end up with many mcodes with the
25 same offset. On the other hand, at the moment offset only seems to be used
26 before this phase. Furthermore add_dot_binding relies on the offset to
27 remain the same between matching an iso and instantiating it with bindings. *)
29 (* --------------------------------------------------------------------- *)
30 (* match a SmPL expression against a SmPL abstract syntax tree,
33 module Ast
= Ast_cocci
34 module Ast0
= Ast0_cocci
35 module V0
= Visitor_ast0
36 module VT0
= Visitor_ast0_types
38 let current_rule = ref ""
40 (* --------------------------------------------------------------------- *)
43 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
46 let mcode (term
,_
,_
,_
,_
,_
) =
47 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
48 ref Ast0.NoMetaPos
,-1) in
51 {(Ast0.wrap
(Ast0.unwrap
x)) with
52 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
53 Ast0.true_if_test
= x.Ast0.true_if_test
} in
55 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
56 donothing donothing donothing donothing donothing donothing
57 donothing donothing donothing donothing donothing donothing donothing
60 let anything_equal = function
61 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
62 failwith
"not a possible variable binding" (*not sure why these are pbs*)
63 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
64 failwith
"not a possible variable binding"
65 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
66 failwith
"not a possible variable binding"
67 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
68 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
69 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
70 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
71 failwith
"not a possible variable binding"
72 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
73 failwith
"not a possible variable binding"
74 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
75 (strip_info.VT0.rebuilder_rec_ident d1
) =
76 (strip_info.VT0.rebuilder_rec_ident d2
)
77 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
78 (strip_info.VT0.rebuilder_rec_expression d1
) =
79 (strip_info.VT0.rebuilder_rec_expression d2
)
80 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
81 failwith
"not possible - only in isos1"
82 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
83 failwith
"not possible - only in isos1"
84 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
85 (strip_info.VT0.rebuilder_rec_typeC d1
) =
86 (strip_info.VT0.rebuilder_rec_typeC d2
)
87 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
88 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
89 (strip_info.VT0.rebuilder_rec_initialiser d2
)
90 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
91 (strip_info.VT0.rebuilder_rec_parameter d1
) =
92 (strip_info.VT0.rebuilder_rec_parameter d2
)
93 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
94 (strip_info.VT0.rebuilder_rec_declaration d1
) =
95 (strip_info.VT0.rebuilder_rec_declaration d2
)
96 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
97 (strip_info.VT0.rebuilder_rec_statement d1
) =
98 (strip_info.VT0.rebuilder_rec_statement d2
)
99 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
100 (strip_info.VT0.rebuilder_rec_case_line d1
) =
101 (strip_info.VT0.rebuilder_rec_case_line d2
)
102 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
103 (strip_info.VT0.rebuilder_rec_top_level d1
) =
104 (strip_info.VT0.rebuilder_rec_top_level d2
)
105 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
106 failwith
"only for isos within iso phase"
107 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
108 failwith
"only for isos within iso phase"
109 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
110 failwith
"only for isos within iso phase"
113 let term (var1
,_
,_
,_
,_
,_
) = var1
114 let dot_term (var1
,_
,info
,_
,_
,_
) =
115 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
119 NotPure
of Ast0.pure
* (string * string) * Ast0.anything
120 | NotPureLength
of (string * string)
121 | ContextRequired
of Ast0.anything
123 | Braces
of Ast0.statement
124 | Position
of string * string
125 | TypeMatch
of reason list
127 let rec interpret_reason name line reason printer
=
129 "warning: iso %s does not match the code below on line %d\n" name line
;
130 printer
(); Format.print_newline
();
132 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
134 "pure metavariable %s is matched against the following nonpure code:\n"
136 Unparse_ast0.unparse_anything nonpure
137 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
139 "context metavariable %s is matched against the following\nnoncontext code:\n"
141 Unparse_ast0.unparse_anything nonpure
142 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
144 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
146 Unparse_ast0.unparse_anything nonpure
147 | NotPureLength
((_
,var
)) ->
149 "pure metavariable %s is matched against too much or too little code\n"
151 | ContextRequired
(term) ->
153 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
154 Unparse_ast0.unparse_anything
term
156 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
157 Unparse_ast0.statement
"" s
;
158 Format.print_newline
()
159 | Position
(rule
,name
) ->
160 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
162 | TypeMatch reason_list
->
163 List.iter
(function r
-> interpret_reason name line r printer
)
165 | _
-> failwith
"not possible"
167 type 'a either
= OK
of 'a
| Fail
of reason
169 let add_binding var exp bindings
=
170 let var = term var in
171 let attempt bindings
=
173 let cur = List.assoc
var bindings
in
174 if anything_equal(exp
,cur) then [bindings
] else []
175 with Not_found
-> [((var,exp
)::bindings
)] in
176 match List.concat
(List.map
attempt bindings
) with
180 let add_dot_binding var exp bindings
=
181 let var = dot_term var in
182 let attempt bindings
=
184 let cur = List.assoc
var bindings
in
185 if anything_equal(exp
,cur) then [bindings
] else []
186 with Not_found
-> [((var,exp
)::bindings
)] in
187 match List.concat
(List.map
attempt bindings
) with
192 let add_multi_dot_binding var exp bindings
=
193 let var = dot_term var in
194 let attempt bindings
= [((var,exp
)::bindings
)] in
195 match List.concat
(List.map
attempt bindings
) with
202 | (x::xs
) when (List.mem
x xs
) -> nub xs
203 | (x::xs
) -> x::(nub xs
)
205 (* --------------------------------------------------------------------- *)
209 let debug str m binding
=
210 let res = m binding
in
212 None
-> Printf.printf
"%s: failed\n" str
216 Printf.printf
"%s: %s\n" str
217 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
221 let conjunct_bindings
222 (m1
: 'binding
-> 'binding either
)
223 (m2
: 'binding
-> 'binding either
)
224 (binding
: 'binding
) : 'binding either
=
225 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
227 let rec conjunct_many_bindings = function
228 [] -> failwith
"not possible"
230 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
232 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
234 let return b binding
= if b
then OK binding
else Fail NonMatch
235 let return_false reason binding
= Fail reason
237 let match_option f t1 t2
=
239 (Some t1
, Some t2
) -> f t1 t2
240 | (None
, None
) -> return true
243 let bool_match_option f t1 t2
=
245 (Some t1
, Some t2
) -> f t1 t2
246 | (None
, None
) -> true
249 (* context_required is for the example
253 where we can't change x == NULL to eg NULL == x. So there can either be
254 nothing attached to the root or the term has to be all removed.
255 if would be nice if we knew more about the relationship between the - and +
256 code, because in the case where the + code is a separate statement in a
257 sequence, this is not a problem. Perhaps something could be done in
260 The example seems strange. Why isn't the cast attached to x?
263 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
264 (match Ast0.get_mcodekind e
with
265 Ast0.CONTEXT
(cell
) -> true
268 (* needs a special case when there is a Disj or an empty DOTS
269 the following stops at the statement level, and gives true if one
270 statement is replaced by another *)
271 let rec is_pure_context s
=
272 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
273 (match Ast0.unwrap s
with
274 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
277 match Ast0.undots
x with
278 [s
] -> is_pure_context s
279 | _
-> false (* could we do better? *))
282 (match Ast0.get_mcodekind s
with
285 (Ast.NOTHING
,_
,_
) -> true
289 (* do better for the common case of replacing a stmt by another one *)
290 ([[Ast.StatementTag
(s
)]],_
) ->
291 (match Ast.unwrap s
with
292 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
298 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
300 let match_list matcher is_list_matcher do_list_match la lb
=
301 let rec loop = function
302 ([],[]) -> return true
303 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
304 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
305 | _
-> return false in
308 let match_maker checks_needed context_required whencode_allowed
=
310 let check_mcode pmc cmc binding
=
313 match Ast0.get_pos cmc
with
314 (Ast0.MetaPos
(name
,_
,_
)) as x ->
315 (match Ast0.get_pos pmc
with
316 Ast0.MetaPos
(name1
,_
,_
) ->
317 add_binding name1
(Ast0.MetaPosTag
x) binding
319 let (rule
,name
) = Ast0.unwrap_mcode name
in
320 Fail
(Position
(rule
,name
)))
321 | Ast0.NoMetaPos
-> OK binding
324 let match_dots matcher is_list_matcher do_list_match d1 d2
=
325 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
326 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
327 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
328 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
329 match_list matcher is_list_matcher
(do_list_match d2
) la lb
330 | _
-> return false in
332 let is_elist_matcher el
=
333 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
335 let is_plist_matcher pl
=
336 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
338 let is_slist_matcher pl
=
339 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
341 let no_list _
= false in
343 let build_dots pattern data
=
344 match Ast0.unwrap pattern
with
345 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
346 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
347 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
350 let bind = Ast0.lub_pure
in
351 let option_default = Ast0.Context
in
352 let pure_mcodekind mc
=
354 then Ast0.PureContext
359 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
362 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
363 | _
-> Ast0.Impure
in
364 let donothing r k e
=
365 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
367 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
369 (* a case for everything that has a metavariable *)
370 (* pure is supposed to match only unitary metavars, not anything that
371 contains only unitary metavars *)
373 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
374 (match Ast0.unwrap i
with
375 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
376 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
377 | _
-> Ast0.Impure
) in
379 let expression r k e
=
380 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
381 (match Ast0.unwrap e
with
382 Ast0.MetaErr
(name
,_
,pure
)
383 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
385 | _
-> Ast0.Impure
) in
388 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
389 (match Ast0.unwrap t
with
390 Ast0.MetaType
(name
,pure
) -> pure
391 | _
-> Ast0.Impure
) in
394 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
395 (match Ast0.unwrap t
with
396 Ast0.MetaInit
(name
,pure
) -> pure
397 | _
-> Ast0.Impure
) in
400 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
401 (match Ast0.unwrap p
with
402 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
403 | _
-> Ast0.Impure
) in
406 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
407 (match Ast0.unwrap s
with
408 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
409 | _
-> Ast0.Impure
) in
411 V0.flat_combiner
bind option_default
412 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
413 donothing donothing donothing donothing donothing donothing
414 ident expression typeC init param donothing stmt donothing
417 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
418 match (checks_needed
,pure
) with
419 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
422 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
423 then add_binding name
(builder1 lst
)
424 else return_false (NotPure
(pure
,term name
,builder1 lst
))
425 | _
-> return_false (NotPureLength
(term name
)))
426 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
428 let add_pure_binding name pure is_pure builder
x =
429 match (checks_needed
,pure
) with
430 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
431 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
432 then add_binding name
(builder
x)
433 else return_false (NotPure
(pure
,term name
, builder
x))
434 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
436 let do_elist_match builder el lst
=
437 match Ast0.unwrap el
with
438 Ast0.MetaExprList
(name
,lenname
,pure
) ->
439 (*how to handle lenname? should it be an option type and always None?*)
440 failwith
"expr list pattern not supported in iso"
441 (*add_pure_list_binding name pure
442 pure_sp_code.V0.combiner_expression
443 (function lst -> Ast0.ExprTag(List.hd lst))
444 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
446 | _
-> failwith
"not possible" in
448 let do_plist_match builder pl lst
=
449 match Ast0.unwrap pl
with
450 Ast0.MetaParamList
(name
,lename
,pure
) ->
451 failwith
"param list pattern not supported in iso"
452 (*add_pure_list_binding name pure
453 pure_sp_code.V0.combiner_parameter
454 (function lst -> Ast0.ParamTag(List.hd lst))
455 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
457 | _
-> failwith
"not possible" in
459 let do_slist_match builder sl lst
=
460 match Ast0.unwrap sl
with
461 Ast0.MetaStmtList
(name
,pure
) ->
462 add_pure_list_binding name pure
463 pure_sp_code.VT0.combiner_rec_statement
464 (function lst
-> Ast0.StmtTag
(List.hd lst
))
465 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
467 | _
-> failwith
"not possible" in
469 let do_nolist_match _ _
= failwith
"not possible" in
471 let rec match_ident pattern id
=
472 match Ast0.unwrap pattern
with
473 Ast0.MetaId
(name
,_
,pure
) ->
474 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
475 (function id
-> Ast0.IdentTag id
) id
)
476 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
477 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
479 if not
(checks_needed
) or not
(context_required
) or is_context id
481 match (up
,Ast0.unwrap id
) with
482 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
483 if mcode_equal namea nameb
484 then check_mcode namea nameb
486 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
487 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
489 | (_
,Ast0.OptIdent
(idb
))
490 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
492 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
494 (* should we do something about matching metavars against ...? *)
495 let rec match_expr pattern expr
=
496 match Ast0.unwrap pattern
with
497 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
499 match (form
,expr
) with
503 match Ast0.unwrap e
with
504 Ast0.Constant
(c
) -> true
505 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
506 | Ast0.SizeOfExpr
(se
,exp
) -> true
507 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
508 | Ast0.MetaExpr
(nm
,_
,_
,Ast.CONST
,p
) ->
509 (Ast0.lub_pure p pure
) = pure
512 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
514 match Ast0.unwrap e
with
515 Ast0.Ident
(c
) -> true
516 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
517 | Ast0.MetaExpr
(nm
,_
,_
,Ast.ID
,p
) ->
518 (Ast0.lub_pure p pure
) = pure
526 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
530 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
532 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
533 (* easier than updating type inferencer to manage multiple
535 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
536 | (_
,Some ty
) -> Some
[ty
]
540 let tyname = Ast0.rewrap_mcode name
tyname in
542 (add_pure_binding name pure
543 pure_sp_code.VT0.combiner_rec_expression
544 (function expr
-> Ast0.ExprTag expr
)
546 (function bindings
->
551 add_pure_binding tyname Ast0.Impure
552 (function _
-> Ast0.Impure
)
553 (function ty
-> Ast0.TypeCTag ty
)
555 (Ast0.reverse_type
expty))
559 "warning: unconvertible type";
560 return false bindings
))
563 (function Fail _
-> false | OK
x -> true)
566 (* not sure why this is ok. can there be more
570 (function Fail _
-> [] | OK
x -> x)
578 | OK
x -> failwith
"not possible")
582 "warning: type metavar can only match one type";*)
586 "mixture of metatype and other types not supported")
588 let expty = Ast0.get_type expr
in
589 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
591 add_pure_binding name pure
592 pure_sp_code.VT0.combiner_rec_expression
593 (function expr
-> Ast0.ExprTag expr
)
597 add_pure_binding name pure
598 pure_sp_code.VT0.combiner_rec_expression
599 (function expr
-> Ast0.ExprTag expr
)
602 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
603 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
605 if not
(checks_needed
) or not
(context_required
) or is_context expr
607 match (up
,Ast0.unwrap expr
) with
608 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
610 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
611 if mcode_equal consta constb
612 then check_mcode consta constb
614 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
615 conjunct_many_bindings
616 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
617 match_dots match_expr is_elist_matcher do_elist_match
619 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
620 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
621 if mcode_equal opa opb
623 conjunct_many_bindings
624 [check_mcode opa opb
; match_expr lefta leftb
;
625 match_expr righta rightb
]
627 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
628 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
629 conjunct_many_bindings
630 [check_mcode lp1 lp
; check_mcode rp1 rp
;
631 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
632 match_expr exp3a exp3b
]
633 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
634 if mcode_equal opa opb
636 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
638 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
639 if mcode_equal opa opb
641 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
643 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
644 if mcode_equal opa opb
646 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
648 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
649 if mcode_equal opa opb
651 conjunct_many_bindings
652 [check_mcode opa opb
; match_expr lefta leftb
;
653 match_expr righta rightb
]
655 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
656 conjunct_many_bindings
657 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
658 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
659 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
660 conjunct_many_bindings
661 [check_mcode lb1 lb
; check_mcode rb1 rb
;
662 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
663 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
664 Ast0.RecordAccess
(expb
,op
,fieldb
))
665 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
666 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
667 conjunct_many_bindings
668 [check_mcode opa op
; match_expr expa expb
;
669 match_ident fielda fieldb
]
670 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
671 conjunct_many_bindings
672 [check_mcode lp1 lp
; check_mcode rp1 rp
;
673 match_typeC tya tyb
; match_expr expa expb
]
674 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
675 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
676 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
677 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
678 conjunct_many_bindings
679 [check_mcode lp1 lp
; check_mcode rp1 rp
;
680 check_mcode szf1 szf
; match_typeC tya tyb
]
681 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
683 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
684 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
685 failwith
"not allowed in the pattern of an isomorphism"
686 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
687 failwith
"not allowed in the pattern of an isomorphism"
688 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
689 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
690 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
691 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
692 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
693 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
694 (* hope that mcode of edots is unique somehow *)
695 conjunct_bindings (check_mcode ed ed1
)
696 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
697 if edots_whencode_allowed
698 then add_dot_binding ed
(Ast0.ExprTag wc
)
701 "warning: not applying iso because of whencode";
703 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
704 | (Ast0.Estars
(_
,Some _
),_
) ->
705 failwith
"whencode not allowed in a pattern1"
706 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
707 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
708 | (_
,Ast0.OptExp
(expb
))
709 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
711 else return_false (ContextRequired
(Ast0.ExprTag expr
))
713 (* the special case for function types prevents the eg T X; -> T X = E; iso
714 from applying, which doesn't seem very relevant, but it also avoids a
715 mysterious bug that is obtained with eg int attach(...); *)
716 and match_typeC pattern t
=
717 match Ast0.unwrap pattern
with
718 Ast0.MetaType
(name
,pure
) ->
719 (match Ast0.unwrap t
with
720 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
722 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
723 (function ty
-> Ast0.TypeCTag ty
)
726 if not
(checks_needed
) or not
(context_required
) or is_context t
728 match (up
,Ast0.unwrap t
) with
729 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
730 if mcode_equal cva cvb
732 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
734 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
737 match_list check_mcode
738 (function _
-> false) (function _
-> failwith
"")
741 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
742 if mcode_equal signa signb
744 conjunct_bindings (check_mcode signa signb
)
745 (match_option match_typeC tya tyb
)
747 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
748 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
749 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
750 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
751 conjunct_many_bindings
752 [check_mcode stara starb
; check_mcode lp1a lp1b
;
753 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
754 check_mcode rp2a rp2b
; match_typeC tya tyb
;
755 match_dots match_param
is_plist_matcher
756 do_plist_match paramsa paramsb
]
757 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
758 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
759 conjunct_many_bindings
760 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
761 match_option match_typeC tya tyb
;
762 match_dots match_param
is_plist_matcher do_plist_match
764 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
765 conjunct_many_bindings
766 [check_mcode lb1 lb
; check_mcode rb1 rb
;
767 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
768 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
769 conjunct_bindings (check_mcode kinda kindb
)
770 (match_ident namea nameb
)
771 | (Ast0.StructUnionName
(kinda
,Some namea
),
772 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
773 if mcode_equal kinda kindb
775 conjunct_bindings (check_mcode kinda kindb
)
776 (match_ident namea nameb
)
778 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
779 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
780 conjunct_many_bindings
781 [check_mcode lb1 lb
; check_mcode rb1 rb
;
783 match_dots match_decl
no_list do_nolist_match declsa declsb
]
784 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
785 if mcode_equal namea nameb
786 then check_mcode namea nameb
788 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
789 failwith
"not allowed in the pattern of an isomorphism"
790 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
791 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
792 | (_
,Ast0.OptType
(tyb
))
793 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
795 else return_false (ContextRequired
(Ast0.TypeCTag t
))
797 and match_decl pattern d
=
798 if not
(checks_needed
) or not
(context_required
) or is_context d
800 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
801 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
802 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
803 if bool_match_option mcode_equal stga stgb
805 conjunct_many_bindings
806 [check_mcode eq1 eq
; check_mcode sc1 sc
;
807 match_option check_mcode stga stgb
;
808 match_typeC tya tyb
; match_ident ida idb
;
809 match_init inia inib
]
811 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
812 if bool_match_option mcode_equal stga stgb
814 conjunct_many_bindings
815 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
816 match_typeC tya tyb
; match_ident ida idb
]
818 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
819 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
820 conjunct_many_bindings
821 [match_ident namea nameb
;
822 check_mcode lp1 lp
; check_mcode rp1 rp
;
824 match_dots match_expr is_elist_matcher do_elist_match
826 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
827 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
828 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
829 conjunct_bindings (check_mcode sc1 sc
)
830 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
831 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
832 failwith
"not allowed in the pattern of an isomorphism"
833 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
834 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
835 conjunct_bindings (check_mcode dd d
)
836 (* hope that mcode of ddots is unique somehow *)
837 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
838 if ddots_whencode_allowed
839 then add_dot_binding dd
(Ast0.DeclTag wc
)
841 (Printf.printf
"warning: not applying iso because of whencode";
843 | (Ast0.Ddots
(_
,Some _
),_
) ->
844 failwith
"whencode not allowed in a pattern1"
846 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
847 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
848 match_decl decla declb
849 | (_
,Ast0.OptDecl
(declb
))
850 | (_
,Ast0.UniqueDecl
(declb
)) ->
851 match_decl pattern declb
853 else return_false (ContextRequired
(Ast0.DeclTag d
))
855 and match_init pattern i
=
856 match Ast0.unwrap pattern
with
857 Ast0.MetaInit
(name
,pure
) ->
858 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
859 (function ini
-> Ast0.InitTag ini
)
862 if not
(checks_needed
) or not
(context_required
) or is_context i
864 match (up
,Ast0.unwrap i
) with
865 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
867 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
869 conjunct_many_bindings
870 [check_mcode lb1 lb
; check_mcode rb1 rb
;
871 match_dots match_init
no_list do_nolist_match
873 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
874 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
875 conjunct_many_bindings
876 [match_list match_designator
877 (function _
-> false) (function _
-> failwith
"")
878 designators1 designators2
;
880 match_init inia inib
]
881 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
882 conjunct_many_bindings
883 [check_mcode c1 c
; match_ident namea nameb
;
884 match_init inia inib
]
885 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
886 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
887 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
888 conjunct_bindings (check_mcode id d
)
889 (* hope that mcode of edots is unique somehow *)
890 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
891 if idots_whencode_allowed
892 then add_dot_binding id
(Ast0.InitTag wc
)
895 "warning: not applying iso because of whencode";
897 | (Ast0.Idots
(_
,Some _
),_
) ->
898 failwith
"whencode not allowed in a pattern2"
899 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
900 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
901 | (_
,Ast0.OptIni
(ib
))
902 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
904 else return_false (ContextRequired
(Ast0.InitTag i
))
906 and match_designator pattern d
=
907 match (pattern
,d
) with
908 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
909 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
910 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
911 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
912 conjunct_many_bindings
913 [check_mcode lba lbb
; match_expr expa expb
;
915 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
916 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
917 conjunct_many_bindings
918 [check_mcode lba lbb
; match_expr mina minb
;
919 check_mcode dotsa dotsb
; match_expr maxa maxb
;
923 and match_param pattern p
=
924 match Ast0.unwrap pattern
with
925 Ast0.MetaParam
(name
,pure
) ->
926 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
927 (function p
-> Ast0.ParamTag p
)
929 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
931 if not
(checks_needed
) or not
(context_required
) or is_context p
933 match (up
,Ast0.unwrap p
) with
934 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
935 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
936 conjunct_bindings (match_typeC tya tyb
)
937 (match_option match_ident ida idb
)
938 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
939 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
940 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
941 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
942 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
943 match_param parama paramb
944 | (_
,Ast0.OptParam
(paramb
))
945 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
947 else return_false (ContextRequired
(Ast0.ParamTag p
))
949 and match_statement pattern s
=
950 match Ast0.unwrap pattern
with
951 Ast0.MetaStmt
(name
,pure
) ->
952 (match Ast0.unwrap s
with
953 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
954 return false (* ... is not a single statement *)
956 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
957 (function ty
-> Ast0.StmtTag ty
)
959 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
961 if not
(checks_needed
) or not
(context_required
) or is_context s
963 match (up
,Ast0.unwrap s
) with
964 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
965 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
966 conjunct_many_bindings
967 [check_mcode lp1 lp
; check_mcode rp1 rp
;
968 check_mcode lb1 lb
; check_mcode rb1 rb
;
969 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
970 match_dots match_param
is_plist_matcher do_plist_match
972 match_dots match_statement
is_slist_matcher do_slist_match
974 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
975 match_decl decla declb
976 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
977 (* seqs can only match if they are all minus (plus code
978 allowed) or all context (plus code not allowed in the body).
979 we could be more permissive if the expansions of the isos are
980 also all seqs, but this would be hard to check except at top
981 level, and perhaps not worth checking even in that case.
982 Overall, the issue is that braces are used where single
983 statements are required, and something not satisfying these
984 conditions can cause a single statement to become a
985 non-single statement after the transformation.
987 example: if { ... -foo(); ... }
988 if we let the sequence convert to just -foo();
989 then we produce invalid code. For some reason,
990 single_statement can't deal with this case, perhaps because
991 it starts introducing too many braces? don't remember the
994 conjunct_bindings (check_mcode lb1 lb
)
995 (conjunct_bindings (check_mcode rb1 rb
)
996 (if not
(checks_needed
) or is_minus s
or
998 List.for_all
is_pure_context (Ast0.undots bodyb
))
1000 match_dots match_statement
is_slist_matcher do_slist_match
1002 else return_false (Braces
(s
))))
1003 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
1004 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
1005 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
1006 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
1007 conjunct_many_bindings
1008 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1009 check_mcode rp1 rp2
;
1010 match_expr expa expb
;
1011 match_statement branch1a branch1b
]
1012 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
1013 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
1014 conjunct_many_bindings
1015 [check_mcode if1 if2
; check_mcode lp1 lp2
;
1016 check_mcode rp1 rp2
; check_mcode e1 e2
;
1017 match_expr expa expb
;
1018 match_statement branch1a branch1b
;
1019 match_statement branch2a branch2b
]
1020 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
1021 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1022 conjunct_many_bindings
1023 [check_mcode w1 w
; check_mcode lp1 lp
;
1024 check_mcode rp1 rp
; match_expr expa expb
;
1025 match_statement bodya bodyb
]
1026 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1027 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1028 conjunct_many_bindings
1029 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1030 check_mcode rp1 rp
; match_statement bodya bodyb
;
1031 match_expr expa expb
]
1032 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1033 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1034 conjunct_many_bindings
1035 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1036 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1037 match_option match_expr e1a e1b
;
1038 match_option match_expr e2a e2b
;
1039 match_option match_expr e3a e3b
;
1040 match_statement bodya bodyb
]
1041 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1042 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1043 conjunct_many_bindings
1044 [match_ident nma nmb
;
1045 check_mcode lp1 lp
; check_mcode rp1 rp
;
1046 match_dots match_expr is_elist_matcher do_elist_match
1048 match_statement bodya bodyb
]
1049 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1050 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1051 conjunct_many_bindings
1052 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1053 check_mcode lb1 lb
; check_mcode rb1 rb
;
1054 match_expr expa expb
;
1055 match_dots match_statement
is_slist_matcher do_slist_match
1057 match_dots match_case_line
no_list do_nolist_match
1059 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1060 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1061 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1062 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1063 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1064 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1065 conjunct_many_bindings
1066 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1067 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1068 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1069 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1070 conjunct_many_bindings
1071 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1072 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1073 failwith
"disj not supported in patterns"
1074 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1075 failwith
"nest not supported in patterns"
1076 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1077 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1078 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1079 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1080 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1081 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1082 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1083 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1085 [] -> check_mcode d d1
1087 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1088 if dots_whencode_allowed
1090 conjunct_bindings (check_mcode d d1
)
1094 | Ast0.WhenNot wc
->
1095 conjunct_bindings prev
1096 (add_multi_dot_binding d
1097 (Ast0.DotsStmtTag wc
))
1098 | Ast0.WhenAlways wc
->
1099 conjunct_bindings prev
1100 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1101 | Ast0.WhenNotTrue wc
->
1102 conjunct_bindings prev
1103 (add_multi_dot_binding d
1104 (Ast0.IsoWhenTTag wc
))
1105 | Ast0.WhenNotFalse wc
->
1106 conjunct_bindings prev
1107 (add_multi_dot_binding d
1108 (Ast0.IsoWhenFTag wc
))
1109 | Ast0.WhenModifier
(x) ->
1110 conjunct_bindings prev
1111 (add_multi_dot_binding d
1112 (Ast0.IsoWhenTag
x)))
1116 "warning: not applying iso because of whencode";
1118 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1119 | (Ast0.Stars
(_
,_
::_
),_
) ->
1120 failwith
"whencode not allowed in a pattern3"
1121 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1122 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1123 match_statement rea reb
1124 | (_
,Ast0.OptStm
(reb
))
1125 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1127 else return_false (ContextRequired
(Ast0.StmtTag s
))
1129 (* first should provide a subset of the information in the second *)
1130 and match_fninfo patterninfo cinfo
=
1131 let patterninfo = List.sort compare
patterninfo in
1132 let cinfo = List.sort compare
cinfo in
1133 let rec loop = function
1134 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1135 if mcode_equal sta stb
1136 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1138 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1139 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1140 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1141 if mcode_equal ia ib
1142 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1144 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1145 if mcode_equal ia ib
1146 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1148 | (x::resta
,((y
::_
) as restb
)) ->
1149 (match compare
x y
with
1151 | 1 -> loop (resta
,restb
)
1152 | _
-> failwith
"not possible")
1153 | _
-> return false in
1154 loop (patterninfo,cinfo)
1156 and match_case_line pattern c
=
1157 if not
(checks_needed
) or not
(context_required
) or is_context c
1159 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1160 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1161 conjunct_many_bindings
1162 [check_mcode d1 d
; check_mcode c1 c
;
1163 match_dots match_statement
is_slist_matcher do_slist_match
1165 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1166 conjunct_many_bindings
1167 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1168 match_dots match_statement
is_slist_matcher do_slist_match
1170 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1171 failwith
"not allowed in the pattern of an isomorphism"
1172 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1173 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1175 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1177 let match_statement_dots x y
=
1178 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1180 (match_expr, match_decl
, match_statement
, match_typeC
,
1181 match_statement_dots)
1183 let match_expr dochecks context_required whencode_allowed
=
1184 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1187 let match_decl dochecks context_required whencode_allowed
=
1188 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1191 let match_statement dochecks context_required whencode_allowed
=
1192 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1195 let match_typeC dochecks context_required whencode_allowed
=
1196 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1199 let match_statement_dots dochecks context_required whencode_allowed
=
1200 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1203 (* --------------------------------------------------------------------- *)
1204 (* make an entire tree MINUS *)
1207 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1209 match mcodekind
with
1212 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1213 | _
-> failwith
"make_minus: unexpected befaft")
1214 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1215 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1216 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1218 let update_mc mcodekind e
=
1219 match !mcodekind
with
1222 (Ast.NOTHING
,_
,_
) ->
1223 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1224 | _
-> failwith
"make_minus: unexpected befaft")
1225 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1226 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1227 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1229 let donothing r k e
=
1230 let mcodekind = Ast0.get_mcodekind_ref e
in
1231 let e = k
e in update_mc mcodekind e; e in
1233 (* special case for whencode, because it isn't processed by contextneg,
1234 since it doesn't appear in the + code *)
1235 (* cases for dots and nests *)
1236 let expression r k
e =
1237 let mcodekind = Ast0.get_mcodekind_ref
e in
1238 match Ast0.unwrap
e with
1239 Ast0.Edots
(d
,whencode
) ->
1240 (*don't recurse because whencode hasn't been processed by context_neg*)
1241 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1242 | Ast0.Ecircles
(d
,whencode
) ->
1243 (*don't recurse because whencode hasn't been processed by context_neg*)
1244 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1245 | Ast0.Estars
(d
,whencode
) ->
1246 (*don't recurse because whencode hasn't been processed by context_neg*)
1247 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1248 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1249 update_mc mcodekind e;
1251 (Ast0.NestExpr
(mcode starter
,
1252 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1253 mcode ender
,whencode
,multi
))
1254 | _
-> donothing r k
e in
1256 let declaration r k
e =
1257 let mcodekind = Ast0.get_mcodekind_ref
e in
1258 match Ast0.unwrap
e with
1259 Ast0.Ddots
(d
,whencode
) ->
1260 (*don't recurse because whencode hasn't been processed by context_neg*)
1261 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1262 | _
-> donothing r k
e in
1264 let statement r k
e =
1265 let mcodekind = Ast0.get_mcodekind_ref
e in
1266 match Ast0.unwrap
e with
1267 Ast0.Dots
(d
,whencode
) ->
1268 (*don't recurse because whencode hasn't been processed by context_neg*)
1269 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1270 | Ast0.Circles
(d
,whencode
) ->
1271 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1272 | Ast0.Stars
(d
,whencode
) ->
1273 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1274 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1275 update_mc mcodekind e;
1278 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1279 mcode ender
,whencode
,multi
))
1280 | _
-> donothing r k
e in
1282 let initialiser r k
e =
1283 let mcodekind = Ast0.get_mcodekind_ref
e in
1284 match Ast0.unwrap
e with
1285 Ast0.Idots
(d
,whencode
) ->
1286 (*don't recurse because whencode hasn't been processed by context_neg*)
1287 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1288 | _
-> donothing r k
e in
1291 let info = Ast0.get_info
e in
1292 let mcodekind = Ast0.get_mcodekind_ref
e in
1293 match Ast0.unwrap
e with
1295 (* if context is - this should be - as well. There are no tokens
1296 here though, so the bottom-up minusifier in context_neg leaves it
1297 as mixed (or context for sgrep2). It would be better to fix
1298 context_neg, but that would
1299 require a special case for each term with a dots subterm. *)
1300 (match !mcodekind with
1301 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1303 (Ast.NOTHING
,_
,_
) ->
1304 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1306 | _
-> failwith
"make_minus: unexpected befaft")
1307 (* code already processed by an enclosing iso *)
1308 | Ast0.MINUS
(mc
) -> e
1312 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1313 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1314 | _
-> donothing r k
e in
1317 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1318 dots dots dots dots dots dots
1319 donothing expression donothing initialiser donothing declaration
1320 statement donothing donothing
1322 (* --------------------------------------------------------------------- *)
1323 (* rebuild mcode cells in an instantiated alt *)
1325 (* mcodes will be side effected later with plus code, so we have to copy
1326 them on instantiating an isomorphism. One could wonder whether it would
1327 be better not to use side-effects, but they are convenient for insert_plus
1328 where is it useful to manipulate a list of the mcodes but side-effect a
1330 (* hmm... Insert_plus is called before Iso_pattern... *)
1331 let rebuild_mcode start_line
=
1332 let copy_mcodekind = function
1333 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1334 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1335 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1336 | Ast0.PLUS count
->
1337 (* this function is used elsewhere where we need to rebuild the
1338 indices, and so we allow PLUS code as well *)
1341 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1343 match start_line
with
1346 {info.Ast0.pos_info
with
1347 Ast0.line_start
= x;
1348 Ast0.line_end
= x; } in
1349 {info with Ast0.pos_info
= new_pos_info}
1351 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1354 let old_info = Ast0.get_info
x in
1356 match start_line
with
1359 {old_info.Ast0.pos_info
with
1360 Ast0.line_start
= x;
1361 Ast0.line_end
= x; } in
1362 {old_info with Ast0.pos_info
= new_pos_info}
1363 | None
-> old_info in
1364 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1365 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1367 let donothing r k
e = copy_one (k
e) in
1369 (* case for control operators (if, etc) *)
1370 let statement r k
e =
1375 (match Ast0.unwrap
s with
1376 Ast0.Decl
((info,mc
),decl
) ->
1377 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1378 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1379 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1380 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1381 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1382 (info,copy_mcodekind mc
))
1383 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1384 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1385 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1386 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1387 (info,copy_mcodekind mc
))
1388 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,mc
)) ->
1389 Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1391 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1393 ((info,copy_mcodekind mc
),
1394 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1396 Ast0.set_dots_bef_aft
res
1397 (match Ast0.get_dots_bef_aft
res with
1398 Ast0.NoDots
-> Ast0.NoDots
1399 | Ast0.AddingBetweenDots
s ->
1400 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1401 | Ast0.DroppingBetweenDots
s ->
1402 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1405 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1406 donothing donothing donothing donothing donothing donothing
1407 donothing donothing donothing donothing donothing
1408 donothing statement donothing donothing
1410 (* --------------------------------------------------------------------- *)
1411 (* The problem of whencode. If an isomorphism contains dots in multiple
1412 rules, then the code that is matched cannot contain whencode, because we
1413 won't know which dots it goes with. Should worry about nests, but they
1414 aren't allowed in isomorphisms for the moment. *)
1417 let option_default = 0 in
1418 let bind x y
= x + y
in
1420 match Ast0.unwrap
e with
1421 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1424 V0.combiner
bind option_default
1425 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1428 let option_default = 0 in
1429 let bind x y
= x + y
in
1431 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1433 V0.combiner
bind option_default
1434 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1437 let option_default = 0 in
1438 let bind x y
= x + y
in
1440 match Ast0.unwrap
e with
1441 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1444 V0.combiner
bind option_default
1445 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1447 (* --------------------------------------------------------------------- *)
1449 let lookup name bindings mv_bindings
=
1450 try Common.Left
(List.assoc
(term name
) bindings
)
1453 (* failure is not possible anymore *)
1454 Common.Right
(List.assoc
(term name
) mv_bindings
)
1456 (* mv_bindings is for the fresh metavariables that are introduced by the
1458 let instantiate bindings mv_bindings
=
1460 match Ast0.get_pos
x with
1461 Ast0.MetaPos
(name
,_
,_
) ->
1463 match lookup name bindings mv_bindings
with
1464 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1465 | _
-> failwith
"not possible"
1466 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1468 let donothing r k
e = k
e in
1470 (* cases where metavariables can occur *)
1473 match Ast0.unwrap
e with
1474 Ast0.MetaId
(name
,constraints
,pure
) ->
1475 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1476 (match lookup name bindings mv_bindings
with
1477 Common.Left
(Ast0.IdentTag
(id
)) -> id
1478 | Common.Left
(_
) -> failwith
"not possible 1"
1479 | Common.Right
(new_mv
) ->
1482 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1483 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1484 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1487 (* case for list metavariables *)
1488 let rec elist r same_dots
= function
1491 (match Ast0.unwrap
x with
1492 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1493 failwith
"meta_expr_list in iso not supported"
1494 (*match lookup name bindings mv_bindings with
1495 Common.Left(Ast0.DotsExprTag(exp)) ->
1496 (match same_dots exp with
1498 | None -> failwith "dots put in incompatible context")
1499 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1500 | Common.Left(_) -> failwith "not possible 1"
1501 | Common.Right(new_mv) ->
1502 failwith "MetaExprList in SP not supported"*)
1503 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1504 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1506 let rec plist r same_dots
= function
1509 (match Ast0.unwrap
x with
1510 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1511 failwith
"meta_param_list in iso not supported"
1512 (*match lookup name bindings mv_bindings with
1513 Common.Left(Ast0.DotsParamTag(param)) ->
1514 (match same_dots param with
1516 | None -> failwith "dots put in incompatible context")
1517 | Common.Left(Ast0.ParamTag(param)) -> [param]
1518 | Common.Left(_) -> failwith "not possible 1"
1519 | Common.Right(new_mv) ->
1520 failwith "MetaExprList in SP not supported"*)
1521 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1522 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1524 let rec slist r same_dots
= function
1527 (match Ast0.unwrap
x with
1528 Ast0.MetaStmtList
(name
,pure
) ->
1529 (match lookup name bindings mv_bindings
with
1530 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1531 (match same_dots stm
with
1533 | None
-> failwith
"dots put in incompatible context")
1534 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1535 | Common.Left
(_
) -> failwith
"not possible 1"
1536 | Common.Right
(new_mv
) ->
1537 failwith
"MetaExprList in SP not supported")
1538 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1539 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1542 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1543 let same_circles d
=
1544 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1546 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1548 let dots list_fn r k d
=
1550 (match Ast0.unwrap d
with
1551 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1552 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1553 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1555 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1558 match Ast0.unwrap
e with
1559 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1560 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1561 (match lookup name bindings mv_bindings
with
1562 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1563 | Common.Left
(_
) -> failwith
"not possible 1"
1564 | Common.Right
(new_mv
) ->
1569 let rec renamer = function
1570 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1572 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1574 Common.Left
(Ast0.TypeCTag
(t
)) ->
1575 Ast0.ast0_type_to_type t
1577 failwith
"iso pattern: unexpected type"
1578 | Common.Right
(new_mv
) ->
1579 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1580 | Type_cocci.ConstVol
(cv
,ty
) ->
1581 Type_cocci.ConstVol
(cv
,renamer ty
)
1582 | Type_cocci.Pointer
(ty
) ->
1583 Type_cocci.Pointer
(renamer ty
)
1584 | Type_cocci.FunctionPointer
(ty
) ->
1585 Type_cocci.FunctionPointer
(renamer ty
)
1586 | Type_cocci.Array
(ty
) ->
1587 Type_cocci.Array
(renamer ty
)
1589 Some
(List.map
renamer types
) in
1592 (Ast0.set_mcode_data new_mv name
,constraints
,
1593 new_types,form
,pure
)))
1594 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1595 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1596 failwith
"metaexprlist not supported"
1597 | Ast0.Unary
(exp
,unop
) ->
1598 (match Ast0.unwrap_mcode unop
with
1599 (* propagate negation only when the propagated and the encountered
1600 negation have the same transformation, when there is nothing
1601 added to the original one, and when there is nothing added to
1602 the expression into which we are doing the propagation. This
1603 may be too conservative. *)
1606 (* k e doesn't change the outer structure of the term,
1607 only the metavars *)
1608 match Ast0.unwrap old_e
with
1609 Ast0.Unary
(exp
,_
) ->
1610 (match Ast0.unwrap exp
with
1611 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1613 | _
-> failwith
"not possible" in
1614 let nomodif = function
1619 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1621 (Ast.NOTHING
,_
,_
) -> true
1623 | _
-> failwith
"plus not possible" in
1624 let same_modif newop oldop
=
1625 (* only propagate ! is they have the same modification
1626 and no + code on the old one (the new one from the iso
1627 surely has no + code) *)
1628 match (newop
,oldop
) with
1629 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1630 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1631 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1636 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1637 (* k accumulates parens, to keep negation outside if no
1638 propagation is possible *)
1639 if nomodif (Ast0.get_mcodekind
e)
1641 match Ast0.unwrap
res with
1642 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1644 (Ast0.get_mcode_mcodekind unop
)
1645 (Ast0.get_mcode_mcodekind op
) ->
1647 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1648 | Ast0.Paren
(lp
,e1,rp
) ->
1651 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1652 | Ast0.Binary
(e1,op
,e2
) when
1654 (Ast0.get_mcode_mcodekind unop
)
1655 (Ast0.get_mcode_mcodekind op
)->
1657 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1658 let k1 x = k
(Ast0.rewrap
e x) in
1659 (match Ast0.unwrap_mcode op
with
1660 Ast.Logical
(Ast.Inf
) ->
1661 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1662 | Ast.Logical
(Ast.Sup
) ->
1663 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1664 | Ast.Logical
(Ast.InfEq
) ->
1665 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1666 | Ast.Logical
(Ast.SupEq
) ->
1667 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1668 | Ast.Logical
(Ast.Eq
) ->
1669 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1670 | Ast.Logical
(Ast.NotEq
) ->
1671 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1672 | Ast.Logical
(Ast.AndLog
) ->
1673 k1 (Ast0.Binary
(negate e1 e1 idcont,
1675 negate e2 e2
idcont))
1676 | Ast.Logical
(Ast.OrLog
) ->
1677 k1 (Ast0.Binary
(negate e1 e1 idcont,
1679 negate e2 e2
idcont))
1683 Ast0.rewrap_mcode op
Ast.Not
)))
1684 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1685 (* use res because it is the transformed argument *)
1686 let exps = List.map
(function e -> negate e e k
) exps in
1687 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1689 (*use e, because this might be the toplevel expression*)
1691 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1694 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
)) in
1698 | Ast0.Edots
(d
,_
) ->
1700 (match List.assoc
(dot_term d
) bindings
with
1701 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1702 | _
-> failwith
"unexpected binding")
1703 with Not_found
-> e)
1704 | Ast0.Ecircles
(d
,_
) ->
1706 (match List.assoc
(dot_term d
) bindings
with
1707 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1708 | _
-> failwith
"unexpected binding")
1709 with Not_found
-> e)
1710 | Ast0.Estars
(d
,_
) ->
1712 (match List.assoc
(dot_term d
) bindings
with
1713 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1714 | _
-> failwith
"unexpected binding")
1715 with Not_found
-> e)
1717 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1721 match Ast0.unwrap
e with
1722 Ast0.MetaType
(name
,pure
) ->
1723 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1724 (match lookup name bindings mv_bindings
with
1725 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1726 | Common.Left
(_
) -> failwith
"not possible 1"
1727 | Common.Right
(new_mv
) ->
1729 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1734 match Ast0.unwrap
e with
1735 Ast0.MetaInit
(name
,pure
) ->
1736 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1737 (match lookup name bindings mv_bindings
with
1738 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1739 | Common.Left
(_
) -> failwith
"not possible 1"
1740 | Common.Right
(new_mv
) ->
1742 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1747 match Ast0.unwrap
e with
1750 (match List.assoc
(dot_term d
) bindings
with
1751 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1752 | _
-> failwith
"unexpected binding")
1753 with Not_found
-> e)
1758 match Ast0.unwrap
e with
1759 Ast0.MetaParam
(name
,pure
) ->
1760 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1761 (match lookup name bindings mv_bindings
with
1762 Common.Left
(Ast0.ParamTag
(param)) -> param
1763 | Common.Left
(_
) -> failwith
"not possible 1"
1764 | Common.Right
(new_mv
) ->
1766 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1767 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1768 failwith
"metaparamlist not supported"
1773 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1774 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1775 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1776 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1777 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1778 | _
-> failwith
"unexpected binding" in
1782 match Ast0.unwrap
e with
1783 Ast0.MetaStmt
(name
,pure
) ->
1784 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1785 (match lookup name bindings mv_bindings
with
1786 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1787 | Common.Left
(_
) -> failwith
"not possible 1"
1788 | Common.Right
(new_mv
) ->
1790 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1791 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1797 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1798 | Ast0.Circles
(d
,_
) ->
1803 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1804 | Ast0.Stars
(d
,_
) ->
1809 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1813 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1814 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1815 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1817 (* --------------------------------------------------------------------- *)
1820 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1822 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1824 let disj_fail bindings
e =
1826 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1829 (* isomorphism code is by default CONTEXT *)
1830 let merge_plus model_mcode e_mcode
=
1831 match model_mcode
with
1833 (* add the replacement information at the root *)
1837 (match (!mc
,!emc
) with
1838 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1839 | _
-> failwith
"how can we combine minuses?")
1840 | _
-> failwith
"not possible 6")
1841 | Ast0.CONTEXT
(mc
) ->
1843 Ast0.CONTEXT
(emc
) ->
1844 (* keep the logical line info as in the model *)
1845 let (mba
,tb
,ta
) = !mc
in
1846 let (eba
,_
,_
) = !emc
in
1847 (* merging may be required when a term is replaced by a subterm *)
1849 match (mba
,eba
) with
1850 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1851 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1852 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1853 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1854 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1855 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1856 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1857 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1858 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1859 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1860 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1861 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1862 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1863 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1864 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1865 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1866 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1867 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1868 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1869 emc
:= (merged,tb
,ta
)
1870 | Ast0.MINUS
(emc
) ->
1871 let (anything_bef_aft
,_
,_
) = !mc
in
1872 let (anythings
,t
) = !emc
in
1874 (match anything_bef_aft
with
1875 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1876 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1877 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1878 | Ast.NOTHING
-> (anythings
,t
))
1879 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1880 | _
-> failwith
"not possible 7")
1881 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1882 | Ast0.PLUS _
-> failwith
"not possible 9"
1884 let copy_plus printer minusify model
e =
1885 if !Flag.sgrep_mode2
1886 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1889 match Ast0.get_mcodekind model
with
1890 Ast0.MINUS
(mc
) -> minusify
e
1891 | Ast0.CONTEXT
(mc
) -> e
1892 | _
-> failwith
"not possible: copy_plus\n" in
1893 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1896 let copy_minus printer minusify model
e =
1897 match Ast0.get_mcodekind model
with
1898 Ast0.MINUS
(mc
) -> minusify
e
1899 | Ast0.CONTEXT
(mc
) -> e
1901 if !Flag.sgrep_mode2
1903 else failwith
"not possible 8"
1904 | Ast0.PLUS _
-> failwith
"not possible 9"
1906 let whencode_allowed prev_ecount prev_icount prev_dcount
1907 ecount icount dcount rest
=
1908 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1910 let other_ecount = (* number of edots *)
1911 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1913 let other_icount = (* number of dots *)
1914 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1916 let other_dcount = (* number of dots *)
1917 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1919 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1920 dcount
= 0 or other_dcount = 0)
1922 (* copy the befores and afters to the instantiated code *)
1923 let extra_copy_stmt_plus model
e =
1924 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1926 (match Ast0.unwrap model
with
1927 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1928 | Ast0.Decl
((info,bef
),_
) ->
1929 (match Ast0.unwrap
e with
1930 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1931 | Ast0.Decl
((info,bef1
),_
) ->
1933 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1934 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1935 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1936 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1937 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1938 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1939 (match Ast0.unwrap
e with
1940 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1941 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1942 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1943 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1944 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1946 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1950 let extra_copy_other_plus model
e = e
1952 (* --------------------------------------------------------------------- *)
1954 let mv_count = ref 0
1956 let ct = !mv_count in
1957 mv_count := !mv_count + 1;
1958 "_"^
s^
"_"^
(string_of_int
ct)
1960 let get_name = function
1961 Ast.MetaIdDecl
(ar
,nm
) ->
1962 (nm
,function nm
-> Ast.MetaIdDecl
(ar
,nm
))
1963 | Ast.MetaFreshIdDecl
(nm
,seed
) ->
1964 (nm
,function nm
-> Ast.MetaFreshIdDecl
(nm
,seed
))
1965 | Ast.MetaTypeDecl
(ar
,nm
) ->
1966 (nm
,function nm
-> Ast.MetaTypeDecl
(ar
,nm
))
1967 | Ast.MetaInitDecl
(ar
,nm
) ->
1968 (nm
,function nm
-> Ast.MetaInitDecl
(ar
,nm
))
1969 | Ast.MetaListlenDecl
(nm
) ->
1970 failwith
"should not be rebuilt"
1971 | Ast.MetaParamDecl
(ar
,nm
) ->
1972 (nm
,function nm
-> Ast.MetaParamDecl
(ar
,nm
))
1973 | Ast.MetaParamListDecl
(ar
,nm
,nm1
) ->
1974 (nm
,function nm
-> Ast.MetaParamListDecl
(ar
,nm
,nm1
))
1975 | Ast.MetaConstDecl
(ar
,nm
,ty
) ->
1976 (nm
,function nm
-> Ast.MetaConstDecl
(ar
,nm
,ty
))
1977 | Ast.MetaErrDecl
(ar
,nm
) ->
1978 (nm
,function nm
-> Ast.MetaErrDecl
(ar
,nm
))
1979 | Ast.MetaExpDecl
(ar
,nm
,ty
) ->
1980 (nm
,function nm
-> Ast.MetaExpDecl
(ar
,nm
,ty
))
1981 | Ast.MetaIdExpDecl
(ar
,nm
,ty
) ->
1982 (nm
,function nm
-> Ast.MetaIdExpDecl
(ar
,nm
,ty
))
1983 | Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
) ->
1984 (nm
,function nm
-> Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
))
1985 | Ast.MetaExpListDecl
(ar
,nm
,nm1
) ->
1986 (nm
,function nm
-> Ast.MetaExpListDecl
(ar
,nm
,nm1
))
1987 | Ast.MetaStmDecl
(ar
,nm
) ->
1988 (nm
,function nm
-> Ast.MetaStmDecl
(ar
,nm
))
1989 | Ast.MetaStmListDecl
(ar
,nm
) ->
1990 (nm
,function nm
-> Ast.MetaStmListDecl
(ar
,nm
))
1991 | Ast.MetaFuncDecl
(ar
,nm
) ->
1992 (nm
,function nm
-> Ast.MetaFuncDecl
(ar
,nm
))
1993 | Ast.MetaLocalFuncDecl
(ar
,nm
) ->
1994 (nm
,function nm
-> Ast.MetaLocalFuncDecl
(ar
,nm
))
1995 | Ast.MetaPosDecl
(ar
,nm
) ->
1996 (nm
,function nm
-> Ast.MetaPosDecl
(ar
,nm
))
1997 | Ast.MetaDeclarerDecl
(ar
,nm
) ->
1998 (nm
,function nm
-> Ast.MetaDeclarerDecl
(ar
,nm
))
1999 | Ast.MetaIteratorDecl
(ar
,nm
) ->
2000 (nm
,function nm
-> Ast.MetaIteratorDecl
(ar
,nm
))
2002 let make_new_metavars metavars bindings
=
2006 let (s,_
) = get_name mv
in
2007 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
2012 let (s,rebuild
) = get_name mv
in
2013 let new_s = (!current_rule,new_mv s) in
2014 (rebuild
new_s, (s,new_s)))
2017 (* --------------------------------------------------------------------- *)
2019 let do_nothing x = x
2021 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2022 rebuild_mcodes name printer extra_plus update_others
=
2023 let call_instantiate bindings mv_bindings alts
=
2026 (function (a
,_,_,_) ->
2028 (* no need to create duplicates when the bindings have no effect *)
2030 (function bindings
->
2032 (copy_plus printer minusify
e
2034 (instantiater bindings mv_bindings
2035 (rebuild_mcodes a
))))
2036 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2039 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2040 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2041 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2043 whencode_allowed prev_ecount prev_icount prev_dcount
2044 ecount dcount icount rest
in
2045 (match matcher
true (context_required e) wc pattern
e init_env with
2047 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2050 (match matcher
false false wc pattern
e init_env with
2052 interpret_reason name
(Ast0.get_line
e) reason
2053 (function () -> printer
e)
2055 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2056 (prev_dcount
+ dcount
) rest
2057 | OK
(bindings
: (((string * string) * 'a
) list list
)) ->
2059 (* apply update_others to all patterns other than the matched
2060 one. This is used to desigate the others as test
2061 expressions in the TestExpression case *)
2063 (function (x,e,i
,d
) as all
->
2066 else (update_others
x,e,i
,d
))
2067 (List.hd
all_alts)) ::
2069 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2070 (List.tl
all_alts)) in
2071 (match List.concat
all_alts with
2072 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2074 let (new_metavars,mv_bindings
) =
2075 make_new_metavars metavars
(nub(List.concat bindings
)) in
2078 call_instantiate bindings mv_bindings
all_alts))) in
2079 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2080 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2081 | (alts
::rest
) as all_alts ->
2082 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2083 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2084 outer_loop prev_ecount prev_icount prev_dcount rest
2085 | Common.Right
(new_metavars,res) ->
2087 copy_minus printer minusify
e (disj_maker
res)) in
2088 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2089 (count
, metavars
, e)
2091 (* no one should ever look at the information stored in these mcodes *)
2092 let disj_starter lst
=
2093 let old_info = Ast0.get_info
(List.hd lst
) in
2095 { old_info.Ast0.pos_info
with
2096 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2097 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2099 { Ast0.pos_info
= new_pos_info;
2100 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2101 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2102 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2103 Ast0.make_mcode_info
"(" info
2105 let disj_ender lst
=
2106 let old_info = Ast0.get_info
(List.hd lst
) in
2108 { old_info.Ast0.pos_info
with
2109 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2110 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2112 { Ast0.pos_info
= new_pos_info;
2113 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2114 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2115 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2116 Ast0.make_mcode_info
")" info
2118 let disj_mid _ = Ast0.make_mcode
"|"
2120 let make_disj_type tl
=
2123 [] -> failwith
"bad disjunction"
2124 | x::xs
-> List.map
disj_mid xs
in
2125 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2126 let make_disj_stmt_list tl
=
2129 [] -> failwith
"bad disjunction"
2130 | x::xs
-> List.map
disj_mid xs
in
2131 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2132 let make_disj_expr model el
=
2135 [] -> failwith
"bad disjunction"
2136 | x::xs
-> List.map
disj_mid xs
in
2138 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2140 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2141 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2142 let el = List.map
update_arg (List.map
update_test el) in
2143 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2144 let make_disj_decl dl
=
2147 [] -> failwith
"bad disjunction"
2148 | x::xs
-> List.map
disj_mid xs
in
2149 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2150 let make_disj_stmt sl
=
2151 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2154 [] -> failwith
"bad disjunction"
2155 | x::xs
-> List.map
disj_mid xs
in
2157 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2159 let transform_type (metavars
,alts
,name
) e =
2161 (Ast0.TypeCTag
(_)::_)::_ ->
2162 (* start line is given to any leaves in the iso code *)
2164 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2170 (p
,count_edots.VT0.combiner_rec_typeC p
,
2171 count_idots.VT0.combiner_rec_typeC p
,
2172 count_dots.VT0.combiner_rec_typeC p
)
2173 | _ -> failwith
"invalid alt"))
2175 mkdisj match_typeC metavars
alts e
2176 (function b
-> function mv_b
->
2177 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2178 (function t
-> Ast0.TypeCTag t
)
2179 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2180 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2181 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2185 let transform_expr (metavars
,alts,name
) e =
2186 let process update_others
=
2187 (* start line is given to any leaves in the iso code *)
2189 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2194 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2195 (p
,count_edots.VT0.combiner_rec_expression p
,
2196 count_idots.VT0.combiner_rec_expression p
,
2197 count_dots.VT0.combiner_rec_expression p
)
2198 | _ -> failwith
"invalid alt"))
2200 mkdisj match_expr metavars
alts e
2201 (function b
-> function mv_b
->
2202 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2203 (function e -> Ast0.ExprTag
e)
2205 make_minus.VT0.rebuilder_rec_expression
2206 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2207 name
Unparse_ast0.expression extra_copy_other_plus update_others
in
2208 let set_property model
e =
2209 let e = if Ast0.get_test_pos model
then Ast0.set_test_exp
e else e in
2210 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
e else e in
2212 (Ast0.ExprTag
(_)::_)::_ ->
2213 process (set_property e)
2214 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e ->
2215 process (set_property e)
2216 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2217 process (set_property e)
2220 let transform_decl (metavars
,alts,name
) e =
2222 (Ast0.DeclTag
(_)::_)::_ ->
2223 (* start line is given to any leaves in the iso code *)
2225 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2231 (p
,count_edots.VT0.combiner_rec_declaration p
,
2232 count_idots.VT0.combiner_rec_declaration p
,
2233 count_dots.VT0.combiner_rec_declaration p
)
2234 | _ -> failwith
"invalid alt"))
2236 mkdisj match_decl metavars
alts e
2237 (function b
-> function mv_b
->
2238 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2239 (function d
-> Ast0.DeclTag d
)
2241 make_minus.VT0.rebuilder_rec_declaration
2242 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2243 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2246 let transform_stmt (metavars
,alts,name
) e =
2248 (Ast0.StmtTag
(_)::_)::_ ->
2249 (* start line is given to any leaves in the iso code *)
2251 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2257 (p
,count_edots.VT0.combiner_rec_statement p
,
2258 count_idots.VT0.combiner_rec_statement p
,
2259 count_dots.VT0.combiner_rec_statement p
)
2260 | _ -> failwith
"invalid alt"))
2262 mkdisj match_statement metavars
alts e
2263 (function b
-> function mv_b
->
2264 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2265 (function s -> Ast0.StmtTag
s)
2266 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2267 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2268 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2271 (* sort of a hack, because there is no disj at top level *)
2272 let transform_top (metavars
,alts,name
) e =
2273 match Ast0.unwrap
e with
2274 Ast0.DECL
(declstm
) ->
2280 Ast0.DotsStmtTag
(d
) ->
2281 (match Ast0.unwrap d
with
2282 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2283 | _ -> raise
(Failure
""))
2284 | _ -> raise
(Failure
"")))
2286 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2287 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2288 with Failure
_ -> (0,[],e))
2289 | Ast0.CODE
(stmts
) ->
2290 let (count
,mv
,res) =
2292 (Ast0.DotsStmtTag
(_)::_)::_ ->
2293 (* start line is given to any leaves in the iso code *)
2295 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2300 Ast0.DotsStmtTag
(p
) ->
2301 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2302 count_idots.VT0.combiner_rec_statement_dots p
,
2303 count_dots.VT0.combiner_rec_statement_dots p
)
2304 | _ -> failwith
"invalid alt"))
2306 mkdisj match_statement_dots metavars
alts stmts
2307 (function b
-> function mv_b
->
2308 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2309 (function s -> Ast0.DotsStmtTag
s)
2311 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2313 make_minus.VT0.rebuilder_rec_statement_dots
x)
2314 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2315 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2316 | _ -> (0,[],stmts
) in
2317 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2320 (* --------------------------------------------------------------------- *)
2322 let transform (alts : isomorphism
) t
=
2323 (* the following ugliness is because rebuilder only returns a new term *)
2324 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2325 let in_limit n
= function
2329 ((if !Flag_parsing_cocci.show_iso_failures
2330 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2332 let bind x y
= x + y
in
2333 let option_default = 0 in
2335 let (e_count
,e) = k
e in
2336 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2338 let (count
,extra_meta
,exp
) = transform_expr alts e in
2339 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2340 (bind count e_count
,exp
)
2344 let (e_count
,e) = k
e in
2345 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2347 let (count
,extra_meta
,dec
) = transform_decl alts e in
2348 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2349 (bind count e_count
,dec
)
2353 let (e_count
,e) = k
e in
2354 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2356 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2357 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2358 (bind count e_count
,stm
)
2362 let (continue
,e_count
,e) =
2363 match Ast0.unwrap
e with
2364 Ast0.Signed
(signb
,tyb
) ->
2365 (* Hack! How else to prevent iso from applying under an
2369 let (e_count
,e) = k
e in
2370 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2371 then (true,e_count
,e)
2372 else (false,e_count
,e) in
2375 let (count
,extra_meta
,ty
) = transform_type alts e in
2376 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2377 (bind count e_count
,ty
)
2381 let (e_count
,e) = k
e in
2382 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2384 let (count
,extra_meta
,ty
) = transform_top alts e in
2385 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2386 (bind count e_count
,ty
)
2390 V0.combiner_rebuilder
bind option_default
2391 {V0.combiner_rebuilder_functions
with
2392 VT0.combiner_rebuilder_exprfn
= exprfn;
2393 VT0.combiner_rebuilder_tyfn
= typefn;
2394 VT0.combiner_rebuilder_declfn
= declfn;
2395 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2396 VT0.combiner_rebuilder_topfn
= topfn} in
2397 let (_,res) = res.VT0.top_level t
in
2398 (!extra_meta_decls,res)
2400 (* --------------------------------------------------------------------- *)
2402 (* should be done by functorizing the parser to use wrap or context_wrap *)
2404 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2405 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2407 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2408 donothing donothing donothing donothing donothing donothing
2409 donothing donothing donothing donothing donothing donothing donothing
2412 let rewrap_anything = function
2413 Ast0.DotsExprTag
(d
) ->
2414 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2415 | Ast0.DotsInitTag
(d
) ->
2416 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2417 | Ast0.DotsParamTag
(d
) ->
2418 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2419 | Ast0.DotsStmtTag
(d
) ->
2420 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2421 | Ast0.DotsDeclTag
(d
) ->
2422 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2423 | Ast0.DotsCaseTag
(d
) ->
2424 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2425 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2426 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2427 | Ast0.ArgExprTag
(d
) ->
2428 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2429 | Ast0.TestExprTag
(d
) ->
2430 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2431 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2432 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2433 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2434 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2435 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2436 | Ast0.CaseLineTag
(d
) ->
2437 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2438 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2439 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2440 failwith
"only for isos within iso phase"
2441 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2443 (* --------------------------------------------------------------------- *)
2445 let apply_isos isos rule rule_name
=
2450 current_rule := rule_name
;
2453 (function (metavars
,iso
,name
) ->
2454 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2456 let (extra_meta
,rule
) =
2461 (function (extra_meta
,t
) -> function iso
->
2462 let (new_extra_meta
,t
) = transform iso t
in
2463 (new_extra_meta
@extra_meta
,t
))
2466 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)