2 * Copyright 2005-2008, 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
37 let current_rule = ref ""
39 (* --------------------------------------------------------------------- *)
42 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
45 let mcode (term
,_
,_
,_
,_
) =
46 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
,ref Ast0.NoMetaPos
) in
49 {(Ast0.wrap
(Ast0.unwrap
x)) with
50 Ast0.mcodekind
= ref Ast0.PLUS
;
51 Ast0.true_if_test
= x.Ast0.true_if_test
} in
53 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.V0.rebuilder_statement_dots d1
) =
68 (strip_info.V0.rebuilder_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.V0.rebuilder_ident d1
) = (strip_info.V0.rebuilder_ident d2
)
75 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
76 (strip_info.V0.rebuilder_expression d1
) =
77 (strip_info.V0.rebuilder_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.V0.rebuilder_typeC d1
) =
84 (strip_info.V0.rebuilder_typeC d2
)
85 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
86 (strip_info.V0.rebuilder_initialiser d1
) =
87 (strip_info.V0.rebuilder_initialiser d2
)
88 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
89 (strip_info.V0.rebuilder_parameter d1
) =
90 (strip_info.V0.rebuilder_parameter d2
)
91 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
92 (strip_info.V0.rebuilder_declaration d1
) =
93 (strip_info.V0.rebuilder_declaration d2
)
94 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
95 (strip_info.V0.rebuilder_statement d1
) =
96 (strip_info.V0.rebuilder_statement d2
)
97 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
98 (strip_info.V0.rebuilder_case_line d1
) =
99 (strip_info.V0.rebuilder_case_line d2
)
100 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
101 (strip_info.V0.rebuilder_top_level d1
) =
102 (strip_info.V0.rebuilder_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
,_
,_
) = ("", var1 ^
(string_of_int info
.Ast0.offset
))
116 NotPure
of Ast0.pure
* (string * string) * Ast0.anything
117 | NotPureLength
of (string * string)
118 | ContextRequired
of Ast0.anything
120 | Braces
of Ast0.statement
121 | Position
of string * string
122 | TypeMatch
of reason list
124 let rec interpret_reason name line reason printer
=
126 "warning: iso %s does not match the code below on line %d\n" name line
;
127 printer
(); Format.print_newline
();
129 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
131 "pure metavariable %s is matched against the following nonpure code:\n"
133 Unparse_ast0.unparse_anything nonpure
134 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
136 "context metavariable %s is matched against the following\nnoncontext code:\n"
138 Unparse_ast0.unparse_anything nonpure
139 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
141 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
143 Unparse_ast0.unparse_anything nonpure
144 | NotPureLength
((_
,var
)) ->
146 "pure metavariable %s is matched against too much or too little code\n"
148 | ContextRequired
(term) ->
150 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
151 Unparse_ast0.unparse_anything
term
153 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
154 Unparse_ast0.statement
"" s
;
155 Format.print_newline
()
156 | Position
(rule
,name
) ->
157 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
159 | TypeMatch reason_list
->
160 List.iter
(function r
-> interpret_reason name line r printer
)
162 | _
-> failwith
"not possible"
164 type 'a either
= OK
of 'a
| Fail
of reason
166 let add_binding var exp bindings
=
167 let var = term var in
168 let attempt bindings
=
170 let cur = List.assoc
var bindings
in
171 if anything_equal(exp
,cur) then [bindings
] else []
172 with Not_found
-> [((var,exp
)::bindings
)] in
173 match List.concat
(List.map
attempt bindings
) with
177 let add_dot_binding var exp bindings
=
178 let var = dot_term var in
179 let attempt bindings
=
181 let cur = List.assoc
var bindings
in
182 if anything_equal(exp
,cur) then [bindings
] else []
183 with Not_found
-> [((var,exp
)::bindings
)] in
184 match List.concat
(List.map
attempt bindings
) with
189 let add_multi_dot_binding var exp bindings
=
190 let var = dot_term var in
191 let attempt bindings
= [((var,exp
)::bindings
)] in
192 match List.concat
(List.map
attempt bindings
) with
199 | (x::xs
) when (List.mem
x xs
) -> nub xs
200 | (x::xs
) -> x::(nub xs
)
202 (* --------------------------------------------------------------------- *)
206 let debug str m binding
=
207 let res = m binding
in
209 None
-> Printf.printf
"%s: failed\n" str
213 Printf.printf
"%s: %s\n" str
214 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
218 let conjunct_bindings
219 (m1
: 'binding
-> 'binding either
)
220 (m2
: 'binding
-> 'binding either
)
221 (binding
: 'binding
) : 'binding either
=
222 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
224 let rec conjunct_many_bindings = function
225 [] -> failwith
"not possible"
227 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
229 let mcode_equal (x,_
,_
,_
,_
) (y
,_
,_
,_
,_
) = x = y
231 let return b binding
= if b
then OK binding
else Fail NonMatch
232 let return_false reason binding
= Fail reason
234 let match_option f t1 t2
=
236 (Some t1
, Some t2
) -> f t1 t2
237 | (None
, None
) -> return true
240 let bool_match_option f t1 t2
=
242 (Some t1
, Some t2
) -> f t1 t2
243 | (None
, None
) -> true
246 (* context_required is for the example
250 where we can't change x == NULL to eg NULL == x. So there can either be
251 nothing attached to the root or the term has to be all removed.
252 if would be nice if we knew more about the relationship between the - and +
253 code, because in the case where the + code is a separate statement in a
254 sequence, this is not a problem. Perhaps something could be done in
257 The example seems strange. Why isn't the cast attached to x?
260 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
261 (match Ast0.get_mcodekind e
with
262 Ast0.CONTEXT
(cell
) -> true
265 (* needs a special case when there is a Disj or an empty DOTS
266 the following stops at the statement level, and gives true if one
267 statement is replaced by another *)
268 let rec is_pure_context s
=
269 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
270 (match Ast0.unwrap s
with
271 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
274 match Ast0.undots
x with
275 [s
] -> is_pure_context s
276 | _
-> false (* could we do better? *))
279 (match Ast0.get_mcodekind s
with
282 (Ast.NOTHING
,_
,_
) -> true
286 (* do better for the common case of replacing a stmt by another one *)
287 ([[Ast.StatementTag
(s
)]],_
) ->
288 (match Ast.unwrap s
with
289 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
295 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
297 let match_list matcher is_list_matcher do_list_match la lb
=
298 let rec loop = function
299 ([],[]) -> return true
300 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
301 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
302 | _
-> return false in
305 let match_maker checks_needed context_required whencode_allowed
=
307 let check_mcode pmc cmc binding
=
310 match Ast0.get_pos cmc
with
311 (Ast0.MetaPos
(name
,_
,_
)) as x ->
312 (match Ast0.get_pos pmc
with
313 Ast0.MetaPos
(name1
,_
,_
) ->
314 add_binding name1
(Ast0.MetaPosTag
x) binding
316 let (rule
,name
) = Ast0.unwrap_mcode name
in
317 Fail
(Position
(rule
,name
)))
318 | Ast0.NoMetaPos
-> OK binding
321 let match_dots matcher is_list_matcher do_list_match d1 d2
=
322 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
323 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
324 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
325 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
326 match_list matcher is_list_matcher
(do_list_match d2
) la lb
327 | _
-> return false in
329 let is_elist_matcher el
=
330 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
332 let is_plist_matcher pl
=
333 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
335 let is_slist_matcher pl
=
336 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
338 let no_list _
= false in
340 let build_dots pattern data
=
341 match Ast0.unwrap pattern
with
342 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
343 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
344 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
347 let bind = Ast0.lub_pure
in
348 let option_default = Ast0.Context
in
349 let pure_mcodekind mc
=
351 then Ast0.PureContext
356 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
359 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
360 | _
-> Ast0.Impure
in
361 let donothing r k e
=
362 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
364 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
366 (* a case for everything that has a metavariable *)
367 (* pure is supposed to match only unitary metavars, not anything that
368 contains only unitary metavars *)
370 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
371 (match Ast0.unwrap i
with
372 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
373 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
374 | _
-> Ast0.Impure
) in
376 let expression r k e
=
377 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
378 (match Ast0.unwrap e
with
379 Ast0.MetaErr
(name
,_
,pure
)
380 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
382 | _
-> Ast0.Impure
) in
385 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
386 (match Ast0.unwrap t
with
387 Ast0.MetaType
(name
,pure
) -> pure
388 | _
-> Ast0.Impure
) in
391 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
392 (match Ast0.unwrap p
with
393 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
394 | _
-> Ast0.Impure
) in
397 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
398 (match Ast0.unwrap s
with
399 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
400 | _
-> Ast0.Impure
) in
402 V0.combiner
bind option_default
403 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
405 donothing donothing donothing donothing donothing donothing
406 ident expression typeC donothing param donothing stmt donothing
409 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
410 match (checks_needed
,pure
) with
411 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
414 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
415 then add_binding name
(builder1 lst
)
416 else return_false (NotPure
(pure
,term name
,builder1 lst
))
417 | _
-> return_false (NotPureLength
(term name
)))
418 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
420 let add_pure_binding name pure is_pure builder
x =
421 match (checks_needed
,pure
) with
422 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
423 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
424 then add_binding name
(builder
x)
425 else return_false (NotPure
(pure
,term name
, builder
x))
426 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
428 let do_elist_match builder el lst
=
429 match Ast0.unwrap el
with
430 Ast0.MetaExprList
(name
,lenname
,pure
) ->
431 (*how to handle lenname? should it be an option type and always None?*)
432 failwith
"expr list pattern not supported in iso"
433 (*add_pure_list_binding name pure
434 pure_sp_code.V0.combiner_expression
435 (function lst -> Ast0.ExprTag(List.hd lst))
436 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
438 | _
-> failwith
"not possible" in
440 let do_plist_match builder pl lst
=
441 match Ast0.unwrap pl
with
442 Ast0.MetaParamList
(name
,lename
,pure
) ->
443 failwith
"param list pattern not supported in iso"
444 (*add_pure_list_binding name pure
445 pure_sp_code.V0.combiner_parameter
446 (function lst -> Ast0.ParamTag(List.hd lst))
447 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
449 | _
-> failwith
"not possible" in
451 let do_slist_match builder sl lst
=
452 match Ast0.unwrap sl
with
453 Ast0.MetaStmtList
(name
,pure
) ->
454 add_pure_list_binding name pure
455 pure_sp_code.V0.combiner_statement
456 (function lst
-> Ast0.StmtTag
(List.hd lst
))
457 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
459 | _
-> failwith
"not possible" in
461 let do_nolist_match _ _
= failwith
"not possible" in
463 let rec match_ident pattern id
=
464 match Ast0.unwrap pattern
with
465 Ast0.MetaId
(name
,_
,pure
) ->
466 (add_pure_binding name pure
pure_sp_code.V0.combiner_ident
467 (function id
-> Ast0.IdentTag id
) id
)
468 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
469 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
471 if not
(checks_needed
) or not
(context_required
) or is_context id
473 match (up
,Ast0.unwrap id
) with
474 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
475 if mcode_equal namea nameb
476 then check_mcode namea nameb
478 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
479 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
481 | (_
,Ast0.OptIdent
(idb
))
482 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
484 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
486 (* should we do something about matching metavars against ...? *)
487 let rec match_expr pattern expr
=
488 match Ast0.unwrap pattern
with
489 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
491 match (form
,expr
) with
495 match Ast0.unwrap e
with
496 Ast0.Constant
(c
) -> true
497 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
498 | Ast0.SizeOfExpr
(se
,exp
) -> true
499 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
500 | Ast0.MetaExpr
(nm
,_
,_
,Ast.CONST
,p
) ->
501 (Ast0.lub_pure p pure
) = pure
504 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
506 match Ast0.unwrap e
with
507 Ast0.Ident
(c
) -> true
508 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
509 | Ast0.MetaExpr
(nm
,_
,_
,Ast.ID
,p
) ->
510 (Ast0.lub_pure p pure
) = pure
518 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
522 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
524 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
525 (* easier than updating type inferencer to manage multiple
527 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
528 | (_
,Some ty
) -> Some
[ty
]
532 let tyname = Ast0.rewrap_mcode name
tyname in
534 (add_pure_binding name pure
535 pure_sp_code.V0.combiner_expression
536 (function expr
-> Ast0.ExprTag expr
)
538 (function bindings
->
543 add_pure_binding tyname Ast0.Impure
544 (function _
-> Ast0.Impure
)
545 (function ty
-> Ast0.TypeCTag ty
)
547 (Ast0.reverse_type
expty))
551 "warning: unconvertible type";
552 return false bindings
))
555 (function Fail _
-> false | OK
x -> true)
558 (* not sure why this is ok. can there be more
562 (function Fail _
-> [] | OK
x -> x)
570 | OK
x -> failwith
"not possible")
574 "warning: type metavar can only match one type";*)
578 "mixture of metatype and other types not supported")
580 let expty = Ast0.get_type expr
in
581 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
583 add_pure_binding name pure
584 pure_sp_code.V0.combiner_expression
585 (function expr
-> Ast0.ExprTag expr
)
589 add_pure_binding name pure
pure_sp_code.V0.combiner_expression
590 (function expr
-> Ast0.ExprTag expr
)
593 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
594 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
596 if not
(checks_needed
) or not
(context_required
) or is_context expr
598 match (up
,Ast0.unwrap expr
) with
599 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
601 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
602 if mcode_equal consta constb
603 then check_mcode consta constb
605 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
606 conjunct_many_bindings
607 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
608 match_dots match_expr is_elist_matcher do_elist_match
610 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
611 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
612 if mcode_equal opa opb
614 conjunct_many_bindings
615 [check_mcode opa opb
; match_expr lefta leftb
;
616 match_expr righta rightb
]
618 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
619 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
620 conjunct_many_bindings
621 [check_mcode lp1 lp
; check_mcode rp1 rp
;
622 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
623 match_expr exp3a exp3b
]
624 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
625 if mcode_equal opa opb
627 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
629 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
630 if mcode_equal opa opb
632 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
634 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
635 if mcode_equal opa opb
637 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
639 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
640 if mcode_equal opa opb
642 conjunct_many_bindings
643 [check_mcode opa opb
; match_expr lefta leftb
;
644 match_expr righta rightb
]
646 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
647 conjunct_many_bindings
648 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
649 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
650 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
651 conjunct_many_bindings
652 [check_mcode lb1 lb
; check_mcode rb1 rb
;
653 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
654 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
655 Ast0.RecordAccess
(expb
,op
,fieldb
))
656 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
657 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
658 conjunct_many_bindings
659 [check_mcode opa op
; match_expr expa expb
;
660 match_ident fielda fieldb
]
661 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
662 conjunct_many_bindings
663 [check_mcode lp1 lp
; check_mcode rp1 rp
;
664 match_typeC tya tyb
; match_expr expa expb
]
665 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
666 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
667 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
668 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
669 conjunct_many_bindings
670 [check_mcode lp1 lp
; check_mcode rp1 rp
;
671 check_mcode szf1 szf
; match_typeC tya tyb
]
672 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
674 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
675 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
676 failwith
"not allowed in the pattern of an isomorphism"
677 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
678 failwith
"not allowed in the pattern of an isomorphism"
679 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
680 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
681 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
682 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
683 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
684 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
685 (* hope that mcode of edots is unique somehow *)
686 conjunct_bindings (check_mcode ed ed1
)
687 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
688 if edots_whencode_allowed
689 then add_dot_binding ed
(Ast0.ExprTag wc
)
692 "warning: not applying iso because of whencode";
694 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
695 | (Ast0.Estars
(_
,Some _
),_
) ->
696 failwith
"whencode not allowed in a pattern1"
697 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
698 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
699 | (_
,Ast0.OptExp
(expb
))
700 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
702 else return_false (ContextRequired
(Ast0.ExprTag expr
))
704 (* the special case for function types prevents the eg T X; -> T X = E; iso
705 from applying, which doesn't seem very relevant, but it also avoids a
706 mysterious bug that is obtained with eg int attach(...); *)
707 and match_typeC pattern t
=
708 match Ast0.unwrap pattern
with
709 Ast0.MetaType
(name
,pure
) ->
710 (match Ast0.unwrap t
with
711 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
713 add_pure_binding name pure
pure_sp_code.V0.combiner_typeC
714 (function ty
-> Ast0.TypeCTag ty
)
717 if not
(checks_needed
) or not
(context_required
) or is_context t
719 match (up
,Ast0.unwrap t
) with
720 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
721 if mcode_equal cva cvb
723 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
725 | (Ast0.BaseType
(tya
,signa
),Ast0.BaseType
(tyb
,signb
)) ->
726 if (mcode_equal tya tyb
&&
727 bool_match_option mcode_equal signa signb
)
729 conjunct_bindings (check_mcode tya tyb
)
730 (match_option check_mcode signa signb
)
732 | (Ast0.ImplicitInt
(signa
),Ast0.ImplicitInt
(signb
)) ->
733 if mcode_equal signa signb
734 then check_mcode signa signb
736 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
737 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
738 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
739 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
740 conjunct_many_bindings
741 [check_mcode stara starb
; check_mcode lp1a lp1b
;
742 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
743 check_mcode rp2a rp2b
; match_typeC tya tyb
;
744 match_dots match_param
is_plist_matcher
745 do_plist_match paramsa paramsb
]
746 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
747 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
748 conjunct_many_bindings
749 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
750 match_option match_typeC tya tyb
;
751 match_dots match_param
is_plist_matcher do_plist_match
753 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
754 conjunct_many_bindings
755 [check_mcode lb1 lb
; check_mcode rb1 rb
;
756 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
757 | (Ast0.StructUnionName
(kinda
,Some namea
),
758 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
759 if mcode_equal kinda kindb
761 conjunct_bindings (check_mcode kinda kindb
)
762 (match_ident namea nameb
)
764 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
765 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
766 conjunct_many_bindings
767 [check_mcode lb1 lb
; check_mcode rb1 rb
;
769 match_dots match_decl
no_list do_nolist_match declsa declsb
]
770 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
771 if mcode_equal namea nameb
772 then check_mcode namea nameb
774 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
775 failwith
"not allowed in the pattern of an isomorphism"
776 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
777 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
778 | (_
,Ast0.OptType
(tyb
))
779 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
781 else return_false (ContextRequired
(Ast0.TypeCTag t
))
783 and match_decl pattern d
=
784 if not
(checks_needed
) or not
(context_required
) or is_context d
786 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
787 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
788 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
789 if bool_match_option mcode_equal stga stgb
791 conjunct_many_bindings
792 [check_mcode eq1 eq
; check_mcode sc1 sc
;
793 match_option check_mcode stga stgb
;
794 match_typeC tya tyb
; match_ident ida idb
;
795 match_init inia inib
]
797 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
798 if bool_match_option mcode_equal stga stgb
800 conjunct_many_bindings
801 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
802 match_typeC tya tyb
; match_ident ida idb
]
804 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
805 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
806 conjunct_many_bindings
807 [match_ident namea nameb
;
808 check_mcode lp1 lp
; check_mcode rp1 rp
;
810 match_dots match_expr is_elist_matcher do_elist_match
812 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
813 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
814 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
815 conjunct_bindings (check_mcode sc1 sc
)
816 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
817 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
818 failwith
"not allowed in the pattern of an isomorphism"
819 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
820 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
821 conjunct_bindings (check_mcode dd d
)
822 (* hope that mcode of ddots is unique somehow *)
823 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
824 if ddots_whencode_allowed
825 then add_dot_binding dd
(Ast0.DeclTag wc
)
827 (Printf.printf
"warning: not applying iso because of whencode";
829 | (Ast0.Ddots
(_
,Some _
),_
) ->
830 failwith
"whencode not allowed in a pattern1"
832 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
833 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
834 match_decl decla declb
835 | (_
,Ast0.OptDecl
(declb
))
836 | (_
,Ast0.UniqueDecl
(declb
)) ->
837 match_decl pattern declb
839 else return_false (ContextRequired
(Ast0.DeclTag d
))
841 and match_init pattern i
=
842 if not
(checks_needed
) or not
(context_required
) or is_context i
844 match (Ast0.unwrap pattern
,Ast0.unwrap i
) with
845 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
847 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
)) ->
848 conjunct_many_bindings
849 [check_mcode lb1 lb
; check_mcode rb1 rb
;
850 match_dots match_init
no_list do_nolist_match
852 | (Ast0.InitGccDotName
(d1
,namea
,e1
,inia
),
853 Ast0.InitGccDotName
(d
,nameb
,e
,inib
)) ->
854 conjunct_many_bindings
855 [check_mcode d1 d
; check_mcode e1 e
;
856 match_ident namea nameb
; match_init inia inib
]
857 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
858 conjunct_many_bindings
859 [check_mcode c1 c
; match_ident namea nameb
;
860 match_init inia inib
]
861 | (Ast0.InitGccIndex
(lb1
,expa
,rb1
,e1
,inia
),
862 Ast0.InitGccIndex
(lb2
,expb
,rb2
,e2
,inib
)) ->
863 conjunct_many_bindings
864 [check_mcode lb1 lb2
; check_mcode rb1 rb2
; check_mcode e1 e2
;
865 match_expr expa expb
; match_init inia inib
]
866 | (Ast0.InitGccRange
(lb1
,exp1a
,d1
,exp2a
,rb1
,e1
,inia
),
867 Ast0.InitGccRange
(lb2
,exp1b
,d2
,exp2b
,rb2
,e2
,inib
)) ->
868 conjunct_many_bindings
869 [check_mcode lb1 lb2
; check_mcode d1 d2
;
870 check_mcode rb1 rb2
; check_mcode e1 e2
;
871 match_expr exp1a exp1b
; match_expr exp2a exp2b
;
872 match_init inia inib
]
873 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
874 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
875 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
876 conjunct_bindings (check_mcode id d
)
877 (* hope that mcode of edots is unique somehow *)
878 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
879 if idots_whencode_allowed
880 then add_dot_binding id
(Ast0.InitTag wc
)
882 (Printf.printf
"warning: not applying iso because of whencode";
884 | (Ast0.Idots
(_
,Some _
),_
) ->
885 failwith
"whencode not allowed in a pattern2"
886 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
887 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
888 | (_
,Ast0.OptIni
(ib
))
889 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
891 else return_false (ContextRequired
(Ast0.InitTag i
))
893 and match_param pattern p
=
894 match Ast0.unwrap pattern
with
895 Ast0.MetaParam
(name
,pure
) ->
896 add_pure_binding name pure
pure_sp_code.V0.combiner_parameter
897 (function p
-> Ast0.ParamTag p
)
899 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
901 if not
(checks_needed
) or not
(context_required
) or is_context p
903 match (up
,Ast0.unwrap p
) with
904 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
905 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
906 conjunct_bindings (match_typeC tya tyb
)
907 (match_option match_ident ida idb
)
908 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
909 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
910 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
911 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
912 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
913 match_param parama paramb
914 | (_
,Ast0.OptParam
(paramb
))
915 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
917 else return_false (ContextRequired
(Ast0.ParamTag p
))
919 and match_statement pattern s
=
920 match Ast0.unwrap pattern
with
921 Ast0.MetaStmt
(name
,pure
) ->
922 (match Ast0.unwrap s
with
923 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
924 return false (* ... is not a single statement *)
926 add_pure_binding name pure
pure_sp_code.V0.combiner_statement
927 (function ty
-> Ast0.StmtTag ty
)
929 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
931 if not
(checks_needed
) or not
(context_required
) or is_context s
933 match (up
,Ast0.unwrap s
) with
934 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
935 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
936 conjunct_many_bindings
937 [check_mcode lp1 lp
; check_mcode rp1 rp
;
938 check_mcode lb1 lb
; check_mcode rb1 rb
;
939 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
940 match_dots match_param
is_plist_matcher do_plist_match
942 match_dots match_statement
is_slist_matcher do_slist_match
944 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
945 match_decl decla declb
946 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
947 (* seqs can only match if they are all minus (plus code
948 allowed) or all context (plus code not allowed in the body).
949 we could be more permissive if the expansions of the isos are
950 also all seqs, but this would be hard to check except at top
951 level, and perhaps not worth checking even in that case.
952 Overall, the issue is that braces are used where single
953 statements are required, and something not satisfying these
954 conditions can cause a single statement to become a
955 non-single statement after the transformation.
957 example: if { ... -foo(); ... }
958 if we let the sequence convert to just -foo();
959 then we produce invalid code. For some reason,
960 single_statement can't deal with this case, perhaps because
961 it starts introducing too many braces? don't remember the
964 conjunct_bindings (check_mcode lb1 lb
)
965 (conjunct_bindings (check_mcode rb1 rb
)
966 (if not
(checks_needed
) or is_minus s
or
968 List.for_all
is_pure_context (Ast0.undots bodyb
))
970 match_dots match_statement
is_slist_matcher do_slist_match
972 else return_false (Braces
(s
))))
973 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
974 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
975 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
976 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
977 conjunct_many_bindings
978 [check_mcode if1 if2
; check_mcode lp1 lp2
;
980 match_expr expa expb
;
981 match_statement branch1a branch1b
]
982 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
983 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
984 conjunct_many_bindings
985 [check_mcode if1 if2
; check_mcode lp1 lp2
;
986 check_mcode rp1 rp2
; check_mcode e1 e2
;
987 match_expr expa expb
;
988 match_statement branch1a branch1b
;
989 match_statement branch2a branch2b
]
990 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
991 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
992 conjunct_many_bindings
993 [check_mcode w1 w
; check_mcode lp1 lp
;
994 check_mcode rp1 rp
; match_expr expa expb
;
995 match_statement bodya bodyb
]
996 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
997 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
998 conjunct_many_bindings
999 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1000 check_mcode rp1 rp
; match_statement bodya bodyb
;
1001 match_expr expa expb
]
1002 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1003 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1004 conjunct_many_bindings
1005 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1006 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1007 match_option match_expr e1a e1b
;
1008 match_option match_expr e2a e2b
;
1009 match_option match_expr e3a e3b
;
1010 match_statement bodya bodyb
]
1011 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1012 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1013 conjunct_many_bindings
1014 [match_ident nma nmb
;
1015 check_mcode lp1 lp
; check_mcode rp1 rp
;
1016 match_dots match_expr is_elist_matcher do_elist_match
1018 match_statement bodya bodyb
]
1019 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,casesa
,rb1
),
1020 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,casesb
,rb
)) ->
1021 conjunct_many_bindings
1022 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1023 check_mcode lb1 lb
; check_mcode rb1 rb
;
1024 match_expr expa expb
;
1025 match_dots match_case_line
no_list do_nolist_match
1027 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1028 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1029 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1030 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1031 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1032 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1033 conjunct_many_bindings
1034 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1035 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1036 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1037 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1038 conjunct_many_bindings
1039 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1040 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1041 failwith
"disj not supported in patterns"
1042 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1043 failwith
"nest not supported in patterns"
1044 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1045 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1046 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1047 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1048 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1049 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1050 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1051 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1053 [] -> check_mcode d d1
1055 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1056 if dots_whencode_allowed
1058 conjunct_bindings (check_mcode d d1
)
1062 | Ast0.WhenNot wc
->
1063 conjunct_bindings prev
1064 (add_multi_dot_binding d
1065 (Ast0.DotsStmtTag wc
))
1066 | Ast0.WhenAlways wc
->
1067 conjunct_bindings prev
1068 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1069 | Ast0.WhenNotTrue wc
->
1070 conjunct_bindings prev
1071 (add_multi_dot_binding d
1072 (Ast0.IsoWhenTTag wc
))
1073 | Ast0.WhenNotFalse wc
->
1074 conjunct_bindings prev
1075 (add_multi_dot_binding d
1076 (Ast0.IsoWhenFTag wc
))
1077 | Ast0.WhenModifier
(x) ->
1078 conjunct_bindings prev
1079 (add_multi_dot_binding d
1080 (Ast0.IsoWhenTag
x)))
1084 "warning: not applying iso because of whencode";
1086 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1087 | (Ast0.Stars
(_
,_
::_
),_
) ->
1088 failwith
"whencode not allowed in a pattern3"
1089 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1090 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1091 match_statement rea reb
1092 | (_
,Ast0.OptStm
(reb
))
1093 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1095 else return_false (ContextRequired
(Ast0.StmtTag s
))
1097 (* first should provide a subset of the information in the second *)
1098 and match_fninfo patterninfo cinfo
=
1099 let patterninfo = List.sort compare
patterninfo in
1100 let cinfo = List.sort compare
cinfo in
1101 let rec loop = function
1102 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1103 if mcode_equal sta stb
1104 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1106 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1107 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1108 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1109 if mcode_equal ia ib
1110 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1112 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1113 if mcode_equal ia ib
1114 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1116 | (x::resta
,((y
::_
) as restb
)) ->
1117 (match compare
x y
with
1119 | 1 -> loop (resta
,restb
)
1120 | _
-> failwith
"not possible")
1121 | _
-> return false in
1122 loop (patterninfo,cinfo)
1124 and match_case_line pattern c
=
1125 if not
(checks_needed
) or not
(context_required
) or is_context c
1127 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1128 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1129 conjunct_many_bindings
1130 [check_mcode d1 d
; check_mcode c1 c
;
1131 match_dots match_statement
is_slist_matcher do_slist_match
1133 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1134 conjunct_many_bindings
1135 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1136 match_dots match_statement
is_slist_matcher do_slist_match
1138 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1139 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1141 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1143 let match_statement_dots x y
=
1144 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1146 (match_expr, match_decl
, match_statement
, match_typeC
,
1147 match_statement_dots)
1149 let match_expr dochecks context_required whencode_allowed
=
1150 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1153 let match_decl dochecks context_required whencode_allowed
=
1154 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1157 let match_statement dochecks context_required whencode_allowed
=
1158 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1161 let match_typeC dochecks context_required whencode_allowed
=
1162 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1165 let match_statement_dots dochecks context_required whencode_allowed
=
1166 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1169 (* --------------------------------------------------------------------- *)
1170 (* make an entire tree MINUS *)
1173 let mcode (term,arity
,info
,mcodekind
,pos
) =
1175 match mcodekind
with
1178 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1179 | _
-> failwith
"make_minus: unexpected befaft")
1180 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1181 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1182 (term,arity
,info
,new_mcodekind,pos
) in
1184 let update_mc mcodekind e
=
1185 match !mcodekind
with
1188 (Ast.NOTHING
,_
,_
) ->
1189 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1190 | _
-> failwith
"make_minus: unexpected befaft")
1191 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1192 | Ast0.PLUS
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1193 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1195 let donothing r k e
=
1196 let mcodekind = Ast0.get_mcodekind_ref e
in
1197 let e = k
e in update_mc mcodekind e; e in
1199 (* special case for whencode, because it isn't processed by contextneg,
1200 since it doesn't appear in the + code *)
1201 (* cases for dots and nests *)
1202 let expression r k
e =
1203 let mcodekind = Ast0.get_mcodekind_ref
e in
1204 match Ast0.unwrap
e with
1205 Ast0.Edots
(d
,whencode
) ->
1206 (*don't recurse because whencode hasn't been processed by context_neg*)
1207 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1208 | Ast0.Ecircles
(d
,whencode
) ->
1209 (*don't recurse because whencode hasn't been processed by context_neg*)
1210 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1211 | Ast0.Estars
(d
,whencode
) ->
1212 (*don't recurse because whencode hasn't been processed by context_neg*)
1213 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1214 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1215 update_mc mcodekind e;
1217 (Ast0.NestExpr
(mcode starter
,
1218 r
.V0.rebuilder_expression_dots expr_dots
,
1219 mcode ender
,whencode
,multi
))
1220 | _
-> donothing r k
e in
1222 let declaration r k
e =
1223 let mcodekind = Ast0.get_mcodekind_ref
e in
1224 match Ast0.unwrap
e with
1225 Ast0.Ddots
(d
,whencode
) ->
1226 (*don't recurse because whencode hasn't been processed by context_neg*)
1227 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1228 | _
-> donothing r k
e in
1230 let statement r k
e =
1231 let mcodekind = Ast0.get_mcodekind_ref
e in
1232 match Ast0.unwrap
e with
1233 Ast0.Dots
(d
,whencode
) ->
1234 (*don't recurse because whencode hasn't been processed by context_neg*)
1235 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1236 | Ast0.Circles
(d
,whencode
) ->
1237 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1238 | Ast0.Stars
(d
,whencode
) ->
1239 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1240 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1241 update_mc mcodekind e;
1243 (Ast0.Nest
(mcode starter
,r
.V0.rebuilder_statement_dots stmt_dots
,
1244 mcode ender
,whencode
,multi
))
1245 | _
-> donothing r k
e in
1247 let initialiser r k
e =
1248 let mcodekind = Ast0.get_mcodekind_ref
e in
1249 match Ast0.unwrap
e with
1250 Ast0.Idots
(d
,whencode
) ->
1251 (*don't recurse because whencode hasn't been processed by context_neg*)
1252 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1253 | _
-> donothing r k
e in
1256 let info = Ast0.get_info
e in
1257 let mcodekind = Ast0.get_mcodekind_ref
e in
1258 match Ast0.unwrap
e with
1260 (* if context is - this should be - as well. There are no tokens
1261 here though, so the bottom-up minusifier in context_neg leaves it
1262 as mixed (or context for sgrep2). It would be better to fix
1263 context_neg, but that would
1264 require a special case for each term with a dots subterm. *)
1265 (match !mcodekind with
1266 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1268 (Ast.NOTHING
,_
,_
) ->
1269 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1271 | _
-> failwith
"make_minus: unexpected befaft")
1272 (* code already processed by an enclosing iso *)
1273 | Ast0.MINUS
(mc
) -> e
1277 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1278 info.Ast0.line_start
(Dumper.dump
e)))
1279 | _
-> donothing r k
e in
1282 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1284 dots dots dots dots dots dots
1285 donothing expression donothing initialiser donothing declaration
1286 statement donothing donothing
1288 (* --------------------------------------------------------------------- *)
1289 (* rebuild mcode cells in an instantiated alt *)
1291 (* mcodes will be side effected later with plus code, so we have to copy
1292 them on instantiating an isomorphism. One could wonder whether it would
1293 be better not to use side-effects, but they are convenient for insert_plus
1294 where is it useful to manipulate a list of the mcodes but side-effect a
1296 (* hmm... Insert_plus is called before Iso_pattern... *)
1297 let rebuild_mcode start_line
=
1298 let copy_mcodekind = function
1299 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1300 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1301 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1303 (* this function is used elsewhere where we need to rebuild the
1304 indices, and so we allow PLUS code as well *)
1307 let mcode (term,arity
,info,mcodekind,pos
) =
1309 match start_line
with
1310 Some
x -> {info with Ast0.line_start
= x; Ast0.line_end
= x}
1312 (term,arity
,info,copy_mcodekind mcodekind,pos
) in
1315 let old_info = Ast0.get_info
x in
1317 match start_line
with
1318 Some
x -> {old_info with Ast0.line_start
= x; Ast0.line_end
= x}
1319 | None
-> old_info in
1320 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1321 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1323 let donothing r k
e = copy_one (k
e) in
1325 (* case for control operators (if, etc) *)
1326 let statement r k
e =
1331 (match Ast0.unwrap
s with
1332 Ast0.Decl
((info,mc
),decl
) ->
1333 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1334 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1335 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1336 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1337 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1338 (info,copy_mcodekind mc
))
1339 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1340 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1341 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1342 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1343 (info,copy_mcodekind mc
))
1344 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,mc
)) ->
1345 Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1347 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1349 ((info,copy_mcodekind mc
),
1350 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1352 Ast0.set_dots_bef_aft
res
1353 (match Ast0.get_dots_bef_aft
res with
1354 Ast0.NoDots
-> Ast0.NoDots
1355 | Ast0.AddingBetweenDots
s ->
1356 Ast0.AddingBetweenDots
(r
.V0.rebuilder_statement
s)
1357 | Ast0.DroppingBetweenDots
s ->
1358 Ast0.DroppingBetweenDots
(r
.V0.rebuilder_statement
s)) in
1361 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1363 donothing donothing donothing donothing donothing donothing
1364 donothing donothing donothing donothing donothing
1365 donothing statement donothing donothing
1367 (* --------------------------------------------------------------------- *)
1368 (* The problem of whencode. If an isomorphism contains dots in multiple
1369 rules, then the code that is matched cannot contain whencode, because we
1370 won't know which dots it goes with. Should worry about nests, but they
1371 aren't allowed in isomorphisms for the moment. *)
1375 let option_default = 0 in
1376 let bind x y
= x + y
in
1377 let donothing r k
e = k
e in
1379 match Ast0.unwrap
e with
1380 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1383 V0.combiner
bind option_default
1384 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1386 donothing donothing donothing donothing donothing donothing
1387 donothing exprfn donothing donothing donothing donothing donothing
1392 let option_default = 0 in
1393 let bind x y
= x + y
in
1394 let donothing r k
e = k
e in
1396 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1398 V0.combiner
bind option_default
1399 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1401 donothing donothing donothing donothing donothing donothing
1402 donothing donothing donothing initfn donothing donothing donothing
1407 let option_default = 0 in
1408 let bind x y
= x + y
in
1409 let donothing r k
e = k
e in
1411 match Ast0.unwrap
e with
1412 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1415 V0.combiner
bind option_default
1416 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1418 donothing donothing donothing donothing donothing donothing
1419 donothing donothing donothing donothing donothing donothing stmtfn
1422 (* --------------------------------------------------------------------- *)
1424 let lookup name bindings mv_bindings
=
1425 try Common.Left
(List.assoc
(term name
) bindings
)
1428 (* failure is not possible anymore *)
1429 Common.Right
(List.assoc
(term name
) mv_bindings
)
1431 (* mv_bindings is for the fresh metavariables that are introduced by the
1433 let instantiate bindings mv_bindings
=
1435 match Ast0.get_pos
x with
1436 Ast0.MetaPos
(name
,_
,_
) ->
1438 match lookup name bindings mv_bindings
with
1439 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1440 | _
-> failwith
"not possible"
1441 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1443 let donothing r k
e = k
e in
1445 (* cases where metavariables can occur *)
1448 match Ast0.unwrap
e with
1449 Ast0.MetaId
(name
,constraints
,pure
) ->
1450 (rebuild_mcode None
).V0.rebuilder_ident
1451 (match lookup name bindings mv_bindings
with
1452 Common.Left
(Ast0.IdentTag
(id
)) -> id
1453 | Common.Left
(_
) -> failwith
"not possible 1"
1454 | Common.Right
(new_mv
) ->
1457 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1458 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1459 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1462 (* case for list metavariables *)
1463 let rec elist r same_dots
= function
1466 (match Ast0.unwrap
x with
1467 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1468 failwith
"meta_expr_list in iso not supported"
1469 (*match lookup name bindings mv_bindings with
1470 Common.Left(Ast0.DotsExprTag(exp)) ->
1471 (match same_dots exp with
1473 | None -> failwith "dots put in incompatible context")
1474 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1475 | Common.Left(_) -> failwith "not possible 1"
1476 | Common.Right(new_mv) ->
1477 failwith "MetaExprList in SP not supported"*)
1478 | _
-> [r
.V0.rebuilder_expression
x])
1479 | x::xs
-> (r
.V0.rebuilder_expression
x)::(elist r same_dots xs
) in
1481 let rec plist r same_dots
= function
1484 (match Ast0.unwrap
x with
1485 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1486 failwith
"meta_param_list in iso not supported"
1487 (*match lookup name bindings mv_bindings with
1488 Common.Left(Ast0.DotsParamTag(param)) ->
1489 (match same_dots param with
1491 | None -> failwith "dots put in incompatible context")
1492 | Common.Left(Ast0.ParamTag(param)) -> [param]
1493 | Common.Left(_) -> failwith "not possible 1"
1494 | Common.Right(new_mv) ->
1495 failwith "MetaExprList in SP not supported"*)
1496 | _
-> [r
.V0.rebuilder_parameter
x])
1497 | x::xs
-> (r
.V0.rebuilder_parameter
x)::(plist r same_dots xs
) in
1499 let rec slist r same_dots
= function
1502 (match Ast0.unwrap
x with
1503 Ast0.MetaStmtList
(name
,pure
) ->
1504 (match lookup name bindings mv_bindings
with
1505 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1506 (match same_dots stm
with
1508 | None
-> failwith
"dots put in incompatible context")
1509 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1510 | Common.Left
(_
) -> failwith
"not possible 1"
1511 | Common.Right
(new_mv
) ->
1512 failwith
"MetaExprList in SP not supported")
1513 | _
-> [r
.V0.rebuilder_statement
x])
1514 | x::xs
-> (r
.V0.rebuilder_statement
x)::(slist r same_dots xs
) in
1517 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1518 let same_circles d
=
1519 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1521 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1523 let dots list_fn r k d
=
1525 (match Ast0.unwrap d
with
1526 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1527 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1528 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1530 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1533 match Ast0.unwrap
e with
1534 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1535 (rebuild_mcode None
).V0.rebuilder_expression
1536 (match lookup name bindings mv_bindings
with
1537 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1538 | Common.Left
(_
) -> failwith
"not possible 1"
1539 | Common.Right
(new_mv
) ->
1544 let rec renamer = function
1545 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1547 lookup (name
,(),(),(),None
) bindings mv_bindings
1549 Common.Left
(Ast0.TypeCTag
(t
)) ->
1550 Ast0.ast0_type_to_type t
1552 failwith
"iso pattern: unexpected type"
1553 | Common.Right
(new_mv
) ->
1554 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1555 | Type_cocci.ConstVol
(cv
,ty
) ->
1556 Type_cocci.ConstVol
(cv
,renamer ty
)
1557 | Type_cocci.Pointer
(ty
) ->
1558 Type_cocci.Pointer
(renamer ty
)
1559 | Type_cocci.FunctionPointer
(ty
) ->
1560 Type_cocci.FunctionPointer
(renamer ty
)
1561 | Type_cocci.Array
(ty
) ->
1562 Type_cocci.Array
(renamer ty
)
1564 Some
(List.map
renamer types
) in
1567 (Ast0.set_mcode_data new_mv name
,constraints
,
1568 new_types,form
,pure
)))
1569 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1570 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1571 failwith
"metaexprlist not supported"
1572 | Ast0.Unary
(exp
,unop
) ->
1573 (match Ast0.unwrap_mcode unop
with
1576 (* k e doesn't change the outer structure of the term,
1577 only the metavars *)
1578 match Ast0.unwrap old_e
with
1579 Ast0.Unary
(exp
,_
) ->
1580 (match Ast0.unwrap exp
with
1581 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1583 | _
-> failwith
"not possible" in
1585 let mc = Ast0.get_mcodekind exp
in
1591 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1593 (Ast.NOTHING
,_
,_
) -> true
1595 | _
-> failwith
"plus not possible" in
1596 if was_meta && nomodif exp
&& nomodif e
1598 let rec negate e (*for rewrapping*) res (*code to process*) =
1599 match Ast0.unwrap
res with
1600 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
->
1601 Ast0.rewrap
e (Ast0.unwrap
e1)
1602 | Ast0.Edots
(_
,_
) -> Ast0.rewrap
e (Ast0.unwrap
res)
1603 | Ast0.Paren
(lp
,e,rp
) ->
1604 Ast0.rewrap
res (Ast0.Paren
(lp
,negate e e,rp
))
1605 | Ast0.Binary
(e1,op
,e2
) ->
1606 let reb nop
= Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1608 match Ast0.unwrap_mcode op
with
1609 Ast.Logical
(Ast.Inf
) ->
1610 Ast0.Binary
(e1,reb Ast.SupEq
,e2
)
1611 | Ast.Logical
(Ast.Sup
) ->
1612 Ast0.Binary
(e1,reb Ast.InfEq
,e2
)
1613 | Ast.Logical
(Ast.InfEq
) ->
1614 Ast0.Binary
(e1,reb Ast.Sup
,e2
)
1615 | Ast.Logical
(Ast.SupEq
) ->
1616 Ast0.Binary
(e1,reb Ast.Inf
,e2
)
1617 | Ast.Logical
(Ast.Eq
) ->
1618 Ast0.Binary
(e1,reb Ast.NotEq
,e2
)
1619 | Ast.Logical
(Ast.NotEq
) ->
1620 Ast0.Binary
(e1,reb Ast.Eq
,e2
)
1621 | Ast.Logical
(Ast.AndLog
) ->
1622 Ast0.Binary
(negate e1 e1,reb Ast.OrLog
,
1624 | Ast.Logical
(Ast.OrLog
) ->
1625 Ast0.Binary
(negate e1 e1,reb Ast.AndLog
,
1627 | _
-> Ast0.Unary
(res,Ast0.rewrap_mcode op
Ast.Not
) in
1629 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1630 (* use res because it is the transformed argument *)
1631 let exps = List.map
(function e -> negate e e) exps in
1632 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1634 (*use e, because this might be the toplevel expression*)
1636 (Ast0.Unary
(res,Ast0.rewrap_mcode unop
Ast.Not
)) in
1640 | Ast0.Edots
(d
,_
) ->
1642 (match List.assoc
(dot_term d
) bindings
with
1643 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1644 | _
-> failwith
"unexpected binding")
1645 with Not_found
-> e)
1646 | Ast0.Ecircles
(d
,_
) ->
1648 (match List.assoc
(dot_term d
) bindings
with
1649 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1650 | _
-> failwith
"unexpected binding")
1651 with Not_found
-> e)
1652 | Ast0.Estars
(d
,_
) ->
1654 (match List.assoc
(dot_term d
) bindings
with
1655 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1656 | _
-> failwith
"unexpected binding")
1657 with Not_found
-> e)
1659 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1663 match Ast0.unwrap
e with
1664 Ast0.MetaType
(name
,pure
) ->
1665 (rebuild_mcode None
).V0.rebuilder_typeC
1666 (match lookup name bindings mv_bindings
with
1667 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1668 | Common.Left
(_
) -> failwith
"not possible 1"
1669 | Common.Right
(new_mv
) ->
1671 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1676 match Ast0.unwrap
e with
1679 (match List.assoc
(dot_term d
) bindings
with
1680 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1681 | _
-> failwith
"unexpected binding")
1682 with Not_found
-> e)
1687 match Ast0.unwrap
e with
1688 Ast0.MetaParam
(name
,pure
) ->
1689 (rebuild_mcode None
).V0.rebuilder_parameter
1690 (match lookup name bindings mv_bindings
with
1691 Common.Left
(Ast0.ParamTag
(param)) -> param
1692 | Common.Left
(_
) -> failwith
"not possible 1"
1693 | Common.Right
(new_mv
) ->
1695 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1696 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1697 failwith
"metaparamlist not supported"
1702 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1703 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1704 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1705 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1706 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1707 | _
-> failwith
"unexpected binding" in
1711 match Ast0.unwrap
e with
1712 Ast0.MetaStmt
(name
,pure
) ->
1713 (rebuild_mcode None
).V0.rebuilder_statement
1714 (match lookup name bindings mv_bindings
with
1715 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1716 | Common.Left
(_
) -> failwith
"not possible 1"
1717 | Common.Right
(new_mv
) ->
1719 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1720 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1726 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1727 | Ast0.Circles
(d
,_
) ->
1732 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1733 | Ast0.Stars
(d
,_
) ->
1738 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1742 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1744 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1745 identfn exprfn tyfn donothing paramfn declfn stmtfn donothing donothing
1747 (* --------------------------------------------------------------------- *)
1750 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1752 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1754 let disj_fail bindings
e =
1756 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1759 (* isomorphism code is by default CONTEXT *)
1760 let merge_plus model_mcode e_mcode
=
1761 match model_mcode
with
1763 (* add the replacement information at the root *)
1767 (match (!mc,!emc
) with
1768 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1769 | _
-> failwith
"how can we combine minuses?")
1770 | _
-> failwith
"not possible 6")
1771 | Ast0.CONTEXT
(mc) ->
1773 Ast0.CONTEXT
(emc
) ->
1774 (* keep the logical line info as in the model *)
1775 let (mba
,tb
,ta
) = !mc in
1776 let (eba
,_
,_
) = !emc
in
1777 (* merging may be required when a term is replaced by a subterm *)
1779 match (mba
,eba
) with
1780 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1781 | (Ast.BEFORE
(b1
),Ast.BEFORE
(b2
)) -> Ast.BEFORE
(b1
@b2
)
1782 | (Ast.BEFORE
(b
),Ast.AFTER
(a
)) -> Ast.BEFOREAFTER
(b
,a
)
1783 | (Ast.BEFORE
(b1
),Ast.BEFOREAFTER
(b2
,a
)) ->
1784 Ast.BEFOREAFTER
(b1
@b2
,a
)
1785 | (Ast.AFTER
(a
),Ast.BEFORE
(b
)) -> Ast.BEFOREAFTER
(b
,a
)
1786 | (Ast.AFTER
(a1
),Ast.AFTER
(a2
)) ->Ast.AFTER
(a2
@a1
)
1787 | (Ast.AFTER
(a1
),Ast.BEFOREAFTER
(b
,a2
)) -> Ast.BEFOREAFTER
(b
,a2
@a1
)
1788 | (Ast.BEFOREAFTER
(b1
,a
),Ast.BEFORE
(b2
)) ->
1789 Ast.BEFOREAFTER
(b1
@b2
,a
)
1790 | (Ast.BEFOREAFTER
(b
,a1
),Ast.AFTER
(a2
)) ->
1791 Ast.BEFOREAFTER
(b
,a2
@a1
)
1792 | (Ast.BEFOREAFTER
(b1
,a1
),Ast.BEFOREAFTER
(b2
,a2
)) ->
1793 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
) in
1794 emc
:= (merged,tb
,ta
)
1795 | Ast0.MINUS
(emc
) ->
1796 let (anything_bef_aft
,_
,_
) = !mc in
1797 let (anythings
,t
) = !emc
in
1799 (match anything_bef_aft
with
1800 Ast.BEFORE
(b
) -> (b
@anythings
,t
)
1801 | Ast.AFTER
(a
) -> (anythings
@a
,t
)
1802 | Ast.BEFOREAFTER
(b
,a
) -> (b
@anythings
@a
,t
)
1803 | Ast.NOTHING
-> (anythings
,t
))
1804 | _
-> failwith
"not possible 7")
1805 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1806 | Ast0.PLUS
-> failwith
"not possible 9"
1808 let copy_plus printer minusify model
e =
1809 if !Flag.sgrep_mode2
1810 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1813 match Ast0.get_mcodekind model
with
1814 Ast0.MINUS
(mc) -> minusify
e
1815 | Ast0.CONTEXT
(mc) -> e
1816 | _
-> failwith
"not possible: copy_plus\n" in
1817 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1820 let copy_minus printer minusify model
e =
1821 match Ast0.get_mcodekind model
with
1822 Ast0.MINUS
(mc) -> minusify
e
1823 | Ast0.CONTEXT
(mc) -> e
1825 if !Flag.sgrep_mode2
1827 else failwith
"not possible 8"
1828 | Ast0.PLUS
-> failwith
"not possible 9"
1830 let whencode_allowed prev_ecount prev_icount prev_dcount
1831 ecount icount dcount rest
=
1832 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1834 let other_ecount = (* number of edots *)
1835 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1837 let other_icount = (* number of dots *)
1838 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1840 let other_dcount = (* number of dots *)
1841 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1843 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1844 dcount
= 0 or other_dcount = 0)
1846 (* copy the befores and afters to the instantiated code *)
1847 let extra_copy_stmt_plus model
e =
1848 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1850 (match Ast0.unwrap model
with
1851 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1852 | Ast0.Decl
((info,bef
),_
) ->
1853 (match Ast0.unwrap
e with
1854 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1855 | Ast0.Decl
((info,bef1
),_
) ->
1857 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1858 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1859 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1860 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1861 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1862 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1863 (match Ast0.unwrap
e with
1864 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1865 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1866 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1867 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1868 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1870 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1874 let extra_copy_other_plus model
e = e
1876 (* --------------------------------------------------------------------- *)
1878 let mv_count = ref 0
1880 let ct = !mv_count in
1881 mv_count := !mv_count + 1;
1882 "_"^
s^
"_"^
(string_of_int
ct)
1884 let get_name = function
1885 Ast.MetaIdDecl
(ar
,nm
) ->
1886 (nm
,function nm
-> Ast.MetaIdDecl
(ar
,nm
))
1887 | Ast.MetaFreshIdDecl
(ar
,nm
) ->
1888 (nm
,function nm
-> Ast.MetaFreshIdDecl
(ar
,nm
))
1889 | Ast.MetaTypeDecl
(ar
,nm
) ->
1890 (nm
,function nm
-> Ast.MetaTypeDecl
(ar
,nm
))
1891 | Ast.MetaListlenDecl
(nm
) ->
1892 failwith
"should not be rebuilt"
1893 | Ast.MetaParamDecl
(ar
,nm
) ->
1894 (nm
,function nm
-> Ast.MetaParamDecl
(ar
,nm
))
1895 | Ast.MetaParamListDecl
(ar
,nm
,nm1
) ->
1896 (nm
,function nm
-> Ast.MetaParamListDecl
(ar
,nm
,nm1
))
1897 | Ast.MetaConstDecl
(ar
,nm
,ty
) ->
1898 (nm
,function nm
-> Ast.MetaConstDecl
(ar
,nm
,ty
))
1899 | Ast.MetaErrDecl
(ar
,nm
) ->
1900 (nm
,function nm
-> Ast.MetaErrDecl
(ar
,nm
))
1901 | Ast.MetaExpDecl
(ar
,nm
,ty
) ->
1902 (nm
,function nm
-> Ast.MetaExpDecl
(ar
,nm
,ty
))
1903 | Ast.MetaIdExpDecl
(ar
,nm
,ty
) ->
1904 (nm
,function nm
-> Ast.MetaIdExpDecl
(ar
,nm
,ty
))
1905 | Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
) ->
1906 (nm
,function nm
-> Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
))
1907 | Ast.MetaExpListDecl
(ar
,nm
,nm1
) ->
1908 (nm
,function nm
-> Ast.MetaExpListDecl
(ar
,nm
,nm1
))
1909 | Ast.MetaStmDecl
(ar
,nm
) ->
1910 (nm
,function nm
-> Ast.MetaStmDecl
(ar
,nm
))
1911 | Ast.MetaStmListDecl
(ar
,nm
) ->
1912 (nm
,function nm
-> Ast.MetaStmListDecl
(ar
,nm
))
1913 | Ast.MetaFuncDecl
(ar
,nm
) ->
1914 (nm
,function nm
-> Ast.MetaFuncDecl
(ar
,nm
))
1915 | Ast.MetaLocalFuncDecl
(ar
,nm
) ->
1916 (nm
,function nm
-> Ast.MetaLocalFuncDecl
(ar
,nm
))
1917 | Ast.MetaPosDecl
(ar
,nm
) ->
1918 (nm
,function nm
-> Ast.MetaPosDecl
(ar
,nm
))
1919 | Ast.MetaDeclarerDecl
(ar
,nm
) ->
1920 (nm
,function nm
-> Ast.MetaDeclarerDecl
(ar
,nm
))
1921 | Ast.MetaIteratorDecl
(ar
,nm
) ->
1922 (nm
,function nm
-> Ast.MetaIteratorDecl
(ar
,nm
))
1924 let make_new_metavars metavars bindings
=
1928 let (s,_
) = get_name mv
in
1929 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
1934 let (s,rebuild
) = get_name mv
in
1935 let new_s = (!current_rule,new_mv s) in
1936 (rebuild
new_s, (s,new_s)))
1939 (* --------------------------------------------------------------------- *)
1941 let do_nothing x = x
1943 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
1944 rebuild_mcodes name printer extra_plus update_others
=
1945 let call_instantiate bindings mv_bindings alts
=
1948 (function (a
,_,_,_) ->
1950 (* no need to create duplicates when the bindings have no effect *)
1952 (function bindings
->
1954 (copy_plus printer minusify
e
1956 (instantiater bindings mv_bindings
1957 (rebuild_mcodes a
))))
1958 (Common.union_set
[(name
,mkiso a
)] (Ast0.get_iso
e)))
1961 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
1962 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
1963 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
1965 whencode_allowed prev_ecount prev_icount prev_dcount
1966 ecount dcount icount rest
in
1967 (match matcher
true (context_required e) wc pattern
e init_env with
1969 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
1972 (match matcher
false false wc pattern
e init_env with
1974 interpret_reason name
(Ast0.get_line
e) reason
1975 (function () -> printer
e)
1977 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
1978 (prev_dcount
+ dcount
) rest
1979 | OK
(bindings
: (((string * string) * 'a
) list list
)) ->
1981 (* apply update_others to all patterns other than the matched
1982 one. This is used to desigate the others as test
1983 expressions in the TestExpression case *)
1985 (function (x,e,i
,d
) as all
->
1988 else (update_others
x,e,i
,d
))
1989 (List.hd
all_alts)) ::
1991 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
1992 (List.tl
all_alts)) in
1993 (match List.concat
all_alts with
1994 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
1996 let (new_metavars,mv_bindings
) =
1997 make_new_metavars metavars
(nub(List.concat bindings
)) in
2000 call_instantiate bindings mv_bindings
all_alts))) in
2001 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2002 [] | [[_]] (*only one alternative*) -> ([],e) (* nothing matched *)
2003 | (alts
::rest
) as all_alts ->
2004 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2005 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2006 outer_loop prev_ecount prev_icount prev_dcount rest
2007 | Common.Right
(new_metavars,res) ->
2009 copy_minus printer minusify
e (disj_maker
res)) in
2010 outer_loop 0 0 0 alts
2012 (* no one should ever look at the information stored in these mcodes *)
2013 let disj_starter lst
=
2014 let old_info = Ast0.get_info
(List.hd lst
) in
2017 Ast0.line_end
= old_info.Ast0.line_start
;
2018 Ast0.logical_end
= old_info.Ast0.logical_start
;
2019 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2020 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2021 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2022 Ast0.make_mcode_info
"(" info
2024 let disj_ender lst
=
2025 let old_info = Ast0.get_info
(List.hd lst
) in
2028 Ast0.line_start
= old_info.Ast0.line_end
;
2029 Ast0.logical_start
= old_info.Ast0.logical_end
;
2030 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2031 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2032 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2033 Ast0.make_mcode_info
")" info
2035 let disj_mid _ = Ast0.make_mcode
"|"
2037 let make_disj_type tl
=
2040 [] -> failwith
"bad disjunction"
2041 | x::xs
-> List.map
disj_mid xs
in
2042 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2043 let make_disj_stmt_list tl
=
2046 [] -> failwith
"bad disjunction"
2047 | x::xs
-> List.map
disj_mid xs
in
2048 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2049 let make_disj_expr model el
=
2052 [] -> failwith
"bad disjunction"
2053 | x::xs
-> List.map
disj_mid xs
in
2055 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2057 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2058 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2059 let el = List.map
update_arg (List.map
update_test el) in
2060 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2061 let make_disj_decl dl
=
2064 [] -> failwith
"bad disjunction"
2065 | x::xs
-> List.map
disj_mid xs
in
2066 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2067 let make_disj_stmt sl
=
2068 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2071 [] -> failwith
"bad disjunction"
2072 | x::xs
-> List.map
disj_mid xs
in
2074 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2076 let transform_type (metavars
,alts
,name
) e =
2078 (Ast0.TypeCTag
(_)::_)::_ ->
2079 (* start line is given to any leaves in the iso code *)
2080 let start_line = Some
((Ast0.get_info
e).Ast0.line_start
) in
2086 (p
,count_edots.V0.combiner_typeC p
,
2087 count_idots.V0.combiner_typeC p
,
2088 count_dots.V0.combiner_typeC p
)
2089 | _ -> failwith
"invalid alt"))
2091 mkdisj match_typeC metavars
alts e
2092 (function b
-> function mv_b
->
2093 (instantiate b mv_b
).V0.rebuilder_typeC
)
2094 (function t
-> Ast0.TypeCTag t
)
2095 make_disj_type make_minus.V0.rebuilder_typeC
2096 (rebuild_mcode start_line).V0.rebuilder_typeC
2097 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2101 let transform_expr (metavars
,alts,name
) e =
2102 let process update_others
=
2103 (* start line is given to any leaves in the iso code *)
2104 let start_line = Some
((Ast0.get_info
e).Ast0.line_start
) in
2109 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2110 (p
,count_edots.V0.combiner_expression p
,
2111 count_idots.V0.combiner_expression p
,
2112 count_dots.V0.combiner_expression p
)
2113 | _ -> failwith
"invalid alt"))
2115 mkdisj match_expr metavars
alts e
2116 (function b
-> function mv_b
->
2117 (instantiate b mv_b
).V0.rebuilder_expression
)
2118 (function e -> Ast0.ExprTag
e)
2120 make_minus.V0.rebuilder_expression
2121 (rebuild_mcode start_line).V0.rebuilder_expression
2122 name
Unparse_ast0.expression extra_copy_other_plus update_others
in
2124 (Ast0.ExprTag
(_)::_)::_ -> process do_nothing
2125 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e -> process do_nothing
2126 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2127 process Ast0.set_test_exp
2130 let transform_decl (metavars
,alts,name
) e =
2132 (Ast0.DeclTag
(_)::_)::_ ->
2133 (* start line is given to any leaves in the iso code *)
2134 let start_line = Some
(Ast0.get_info
e).Ast0.line_start
in
2140 (p
,count_edots.V0.combiner_declaration p
,
2141 count_idots.V0.combiner_declaration p
,
2142 count_dots.V0.combiner_declaration p
)
2143 | _ -> failwith
"invalid alt"))
2145 mkdisj match_decl metavars
alts e
2146 (function b
-> function mv_b
->
2147 (instantiate b mv_b
).V0.rebuilder_declaration
)
2148 (function d
-> Ast0.DeclTag d
)
2150 make_minus.V0.rebuilder_declaration
2151 (rebuild_mcode start_line).V0.rebuilder_declaration
2152 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2155 let transform_stmt (metavars
,alts,name
) e =
2157 (Ast0.StmtTag
(_)::_)::_ ->
2158 (* start line is given to any leaves in the iso code *)
2159 let start_line = Some
(Ast0.get_info
e).Ast0.line_start
in
2165 (p
,count_edots.V0.combiner_statement p
,
2166 count_idots.V0.combiner_statement p
,
2167 count_dots.V0.combiner_statement p
)
2168 | _ -> failwith
"invalid alt"))
2170 mkdisj match_statement metavars
alts e
2171 (function b
-> function mv_b
->
2172 (instantiate b mv_b
).V0.rebuilder_statement
)
2173 (function s -> Ast0.StmtTag
s)
2174 make_disj_stmt make_minus.V0.rebuilder_statement
2175 (rebuild_mcode start_line).V0.rebuilder_statement
2176 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2179 (* sort of a hack, because there is no disj at top level *)
2180 let transform_top (metavars
,alts,name
) e =
2181 match Ast0.unwrap
e with
2182 Ast0.DECL
(declstm
) ->
2188 Ast0.DotsStmtTag
(d
) ->
2189 (match Ast0.unwrap d
with
2190 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2191 | _ -> raise
(Failure
""))
2192 | _ -> raise
(Failure
"")))
2194 let (mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2195 (mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2196 with Failure
_ -> ([],e))
2197 | Ast0.CODE
(stmts
) ->
2200 (Ast0.DotsStmtTag
(_)::_)::_ ->
2201 (* start line is given to any leaves in the iso code *)
2202 let start_line = Some
((Ast0.get_info
e).Ast0.line_start
) in
2207 Ast0.DotsStmtTag
(p
) ->
2208 (p
,count_edots.V0.combiner_statement_dots p
,
2209 count_idots.V0.combiner_statement_dots p
,
2210 count_dots.V0.combiner_statement_dots p
)
2211 | _ -> failwith
"invalid alt"))
2213 mkdisj match_statement_dots metavars
alts stmts
2214 (function b
-> function mv_b
->
2215 (instantiate b mv_b
).V0.rebuilder_statement_dots
)
2216 (function s -> Ast0.DotsStmtTag
s)
2218 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2220 make_minus.V0.rebuilder_statement_dots
x)
2221 (rebuild_mcode start_line).V0.rebuilder_statement_dots
2222 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2223 | _ -> ([],stmts
) in
2224 (mv
,Ast0.rewrap
e (Ast0.CODE
res))
2227 (* --------------------------------------------------------------------- *)
2229 let transform (alts : isomorphism
) t
=
2230 (* the following ugliness is because rebuilder only returns a new term *)
2231 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2233 let donothing r k
e = k
e in
2235 let (extra_meta
,exp
) = transform_expr alts (k
e) in
2236 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2240 let (extra_meta
,dec
) = transform_decl alts (k
e) in
2241 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2245 let (extra_meta
,stm
) = transform_stmt alts (k
e) in
2246 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2250 let (extra_meta
,ty
) = transform_type alts (k
e) in
2251 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2255 let (extra_meta
,ty
) = transform_top alts (k
e) in
2256 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2261 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2263 donothing donothing donothing donothing donothing donothing
2264 donothing exprfn typefn donothing donothing declfn stmtfn
2266 let res = res.V0.rebuilder_top_level t
in
2267 (!extra_meta_decls,res)
2269 (* --------------------------------------------------------------------- *)
2271 (* should be done by functorizing the parser to use wrap or context_wrap *)
2273 let mcode (x,a
,i
,mc,pos
) = (x,a
,i
,Ast0.context_befaft
(),pos
) in
2274 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2276 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2278 donothing donothing donothing donothing donothing donothing
2279 donothing donothing donothing donothing donothing donothing donothing
2282 let rewrap_anything = function
2283 Ast0.DotsExprTag
(d
) ->
2284 Ast0.DotsExprTag
(rewrap.V0.rebuilder_expression_dots d
)
2285 | Ast0.DotsInitTag
(d
) ->
2286 Ast0.DotsInitTag
(rewrap.V0.rebuilder_initialiser_list d
)
2287 | Ast0.DotsParamTag
(d
) ->
2288 Ast0.DotsParamTag
(rewrap.V0.rebuilder_parameter_list d
)
2289 | Ast0.DotsStmtTag
(d
) ->
2290 Ast0.DotsStmtTag
(rewrap.V0.rebuilder_statement_dots d
)
2291 | Ast0.DotsDeclTag
(d
) ->
2292 Ast0.DotsDeclTag
(rewrap.V0.rebuilder_declaration_dots d
)
2293 | Ast0.DotsCaseTag
(d
) ->
2294 Ast0.DotsCaseTag
(rewrap.V0.rebuilder_case_line_dots d
)
2295 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.V0.rebuilder_ident d
)
2296 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.V0.rebuilder_expression d
)
2297 | Ast0.ArgExprTag
(d
) -> Ast0.ArgExprTag
(rewrap.V0.rebuilder_expression d
)
2298 | Ast0.TestExprTag
(d
) -> Ast0.TestExprTag
(rewrap.V0.rebuilder_expression d
)
2299 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.V0.rebuilder_typeC d
)
2300 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.V0.rebuilder_initialiser d
)
2301 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.V0.rebuilder_parameter d
)
2302 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.V0.rebuilder_declaration d
)
2303 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.V0.rebuilder_statement d
)
2304 | Ast0.CaseLineTag
(d
) -> Ast0.CaseLineTag
(rewrap.V0.rebuilder_case_line d
)
2305 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.V0.rebuilder_top_level d
)
2306 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2307 failwith
"only for isos within iso phase"
2308 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2310 (* --------------------------------------------------------------------- *)
2312 let apply_isos isos rule rule_name
=
2317 current_rule := rule_name
;
2320 (function (metavars
,iso
,name
) ->
2321 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2323 let (extra_meta
,rule
) =
2328 (function (extra_meta
,t
) -> function iso
->
2329 let (new_extra_meta
,t
) = transform iso t
in
2330 (new_extra_meta
@extra_meta
,t
))
2333 (List.concat extra_meta
, Compute_lines.compute_lines rule
)