1 (* Potential problem: offset of mcode is not updated when an iso is
2 instantiated, implying that a term may end up with many mcodes with the
3 same offset. On the other hand, at the moment offset only seems to be used
4 before this phase. Furthermore add_dot_binding relies on the offset to
5 remain the same between matching an iso and instantiating it with bindings. *)
7 (* --------------------------------------------------------------------- *)
8 (* match a SmPL expression against a SmPL abstract syntax tree,
11 module Ast
= Ast_cocci
12 module Ast0
= Ast0_cocci
13 module V0
= Visitor_ast0
14 module VT0
= Visitor_ast0_types
16 let current_rule = ref ""
18 (* --------------------------------------------------------------------- *)
21 Ast_cocci.metavar list
* Ast0_cocci.anything list list
* string (* name *)
24 let mcode (term
,_
,_
,_
,_
,_
) =
25 (term
,Ast0.NONE
,Ast0.default_info
(),Ast0.PLUS
Ast.ONE
,
26 ref Ast0.NoMetaPos
,-1) in
29 {(Ast0.wrap
(Ast0.unwrap
x)) with
30 Ast0.mcodekind
= ref (Ast0.PLUS
Ast.ONE
);
31 Ast0.true_if_test
= x.Ast0.true_if_test
} in
33 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
34 donothing donothing donothing donothing donothing donothing
35 donothing donothing donothing donothing donothing donothing donothing
38 let anything_equal = function
39 (Ast0.DotsExprTag
(d1
),Ast0.DotsExprTag
(d2
)) ->
40 failwith
"not a possible variable binding" (*not sure why these are pbs*)
41 | (Ast0.DotsInitTag
(d1
),Ast0.DotsInitTag
(d2
)) ->
42 failwith
"not a possible variable binding"
43 | (Ast0.DotsParamTag
(d1
),Ast0.DotsParamTag
(d2
)) ->
44 failwith
"not a possible variable binding"
45 | (Ast0.DotsStmtTag
(d1
),Ast0.DotsStmtTag
(d2
)) ->
46 (strip_info.VT0.rebuilder_rec_statement_dots d1
) =
47 (strip_info.VT0.rebuilder_rec_statement_dots d2
)
48 | (Ast0.DotsDeclTag
(d1
),Ast0.DotsDeclTag
(d2
)) ->
49 failwith
"not a possible variable binding"
50 | (Ast0.DotsCaseTag
(d1
),Ast0.DotsCaseTag
(d2
)) ->
51 failwith
"not a possible variable binding"
52 | (Ast0.IdentTag
(d1
),Ast0.IdentTag
(d2
)) ->
53 (strip_info.VT0.rebuilder_rec_ident d1
) =
54 (strip_info.VT0.rebuilder_rec_ident d2
)
55 | (Ast0.ExprTag
(d1
),Ast0.ExprTag
(d2
)) ->
56 (strip_info.VT0.rebuilder_rec_expression d1
) =
57 (strip_info.VT0.rebuilder_rec_expression d2
)
58 | (Ast0.ArgExprTag
(_
),_
) | (_
,Ast0.ArgExprTag
(_
)) ->
59 failwith
"not possible - only in isos1"
60 | (Ast0.TestExprTag
(_
),_
) | (_
,Ast0.TestExprTag
(_
)) ->
61 failwith
"not possible - only in isos1"
62 | (Ast0.TypeCTag
(d1
),Ast0.TypeCTag
(d2
)) ->
63 (strip_info.VT0.rebuilder_rec_typeC d1
) =
64 (strip_info.VT0.rebuilder_rec_typeC d2
)
65 | (Ast0.InitTag
(d1
),Ast0.InitTag
(d2
)) ->
66 (strip_info.VT0.rebuilder_rec_initialiser d1
) =
67 (strip_info.VT0.rebuilder_rec_initialiser d2
)
68 | (Ast0.ParamTag
(d1
),Ast0.ParamTag
(d2
)) ->
69 (strip_info.VT0.rebuilder_rec_parameter d1
) =
70 (strip_info.VT0.rebuilder_rec_parameter d2
)
71 | (Ast0.DeclTag
(d1
),Ast0.DeclTag
(d2
)) ->
72 (strip_info.VT0.rebuilder_rec_declaration d1
) =
73 (strip_info.VT0.rebuilder_rec_declaration d2
)
74 | (Ast0.StmtTag
(d1
),Ast0.StmtTag
(d2
)) ->
75 (strip_info.VT0.rebuilder_rec_statement d1
) =
76 (strip_info.VT0.rebuilder_rec_statement d2
)
77 | (Ast0.CaseLineTag
(d1
),Ast0.CaseLineTag
(d2
)) ->
78 (strip_info.VT0.rebuilder_rec_case_line d1
) =
79 (strip_info.VT0.rebuilder_rec_case_line d2
)
80 | (Ast0.TopTag
(d1
),Ast0.TopTag
(d2
)) ->
81 (strip_info.VT0.rebuilder_rec_top_level d1
) =
82 (strip_info.VT0.rebuilder_rec_top_level d2
)
83 | (Ast0.IsoWhenTTag
(_
),_
) | (_
,Ast0.IsoWhenTTag
(_
)) ->
84 failwith
"only for isos within iso phase"
85 | (Ast0.IsoWhenFTag
(_
),_
) | (_
,Ast0.IsoWhenFTag
(_
)) ->
86 failwith
"only for isos within iso phase"
87 | (Ast0.IsoWhenTag
(_
),_
) | (_
,Ast0.IsoWhenTag
(_
)) ->
88 failwith
"only for isos within iso phase"
91 let term (var1
,_
,_
,_
,_
,_
) = var1
92 let dot_term (var1
,_
,info
,_
,_
,_
) =
93 ("", var1 ^
(string_of_int info
.Ast0.pos_info
.Ast0.offset
))
97 NotPure
of Ast0.pure
* (string * string) * Ast0.anything
98 | NotPureLength
of (string * string)
99 | ContextRequired
of Ast0.anything
101 | Braces
of Ast0.statement
102 | Position
of string * string
103 | TypeMatch
of reason list
105 let rec interpret_reason name line reason printer
=
107 "warning: iso %s does not match the code below on line %d\n" name line
;
108 printer
(); Format.print_newline
();
110 NotPure
(Ast0.Pure
,(_
,var
),nonpure
) ->
112 "pure metavariable %s is matched against the following nonpure code:\n"
114 Unparse_ast0.unparse_anything nonpure
115 | NotPure
(Ast0.Context
,(_
,var
),nonpure
) ->
117 "context metavariable %s is matched against the following\nnoncontext code:\n"
119 Unparse_ast0.unparse_anything nonpure
120 | NotPure
(Ast0.PureContext
,(_
,var
),nonpure
) ->
122 "pure context metavariable %s is matched against the following\nnonpure or noncontext code:\n"
124 Unparse_ast0.unparse_anything nonpure
125 | NotPureLength
((_
,var
)) ->
127 "pure metavariable %s is matched against too much or too little code\n"
129 | ContextRequired
(term) ->
131 "the following code matched is not uniformly minus or context,\nor contains a disjunction:\n";
132 Unparse_ast0.unparse_anything
term
134 Printf.printf
"braces must be all minus (plus code allowed) or all\ncontext (plus code not allowed in the body) to match:\n";
135 Unparse_ast0.statement
"" s
;
136 Format.print_newline
()
137 | Position
(rule
,name
) ->
138 Printf.printf
"position variable %s.%s conflicts with an isomorphism\n"
140 | TypeMatch reason_list
->
141 List.iter
(function r
-> interpret_reason name line r printer
)
143 | _
-> failwith
"not possible"
145 type 'a either
= OK
of 'a
| Fail
of reason
147 let add_binding var exp bindings
=
148 let var = term var in
149 let attempt bindings
=
151 let cur = List.assoc
var bindings
in
152 if anything_equal(exp
,cur) then [bindings
] else []
153 with Not_found
-> [((var,exp
)::bindings
)] in
154 match List.concat
(List.map
attempt bindings
) with
158 let add_dot_binding var exp bindings
=
159 let var = dot_term var in
160 let attempt bindings
=
162 let cur = List.assoc
var bindings
in
163 if anything_equal(exp
,cur) then [bindings
] else []
164 with Not_found
-> [((var,exp
)::bindings
)] in
165 match List.concat
(List.map
attempt bindings
) with
170 let add_multi_dot_binding var exp bindings
=
171 let var = dot_term var in
172 let attempt bindings
= [((var,exp
)::bindings
)] in
173 match List.concat
(List.map
attempt bindings
) with
180 | (x::xs
) when (List.mem
x xs
) -> nub xs
181 | (x::xs
) -> x::(nub xs
)
183 (* --------------------------------------------------------------------- *)
187 let debug str m binding
=
188 let res = m binding
in
190 None
-> Printf.printf
"%s: failed\n" str
194 Printf.printf
"%s: %s\n" str
195 (String.concat
" " (List.map
(function (x,_
) -> x) binding
)))
199 let conjunct_bindings
200 (m1
: 'binding
-> 'binding either
)
201 (m2
: 'binding
-> 'binding either
)
202 (binding
: 'binding
) : 'binding either
=
203 match m1 binding
with Fail
(reason
) -> Fail
(reason
) | OK binding
-> m2 binding
205 let rec conjunct_many_bindings = function
206 [] -> failwith
"not possible"
208 | x::xs
-> conjunct_bindings x (conjunct_many_bindings xs
)
210 let mcode_equal (x,_
,_
,_
,_
,_
) (y
,_
,_
,_
,_
,_
) = x = y
212 let return b binding
= if b
then OK binding
else Fail NonMatch
213 let return_false reason binding
= Fail reason
215 let match_option f t1 t2
=
217 (Some t1
, Some t2
) -> f t1 t2
218 | (None
, None
) -> return true
221 let bool_match_option f t1 t2
=
223 (Some t1
, Some t2
) -> f t1 t2
224 | (None
, None
) -> true
227 (* context_required is for the example
231 where we can't change x == NULL to eg NULL == x. So there can either be
232 nothing attached to the root or the term has to be all removed.
233 if would be nice if we knew more about the relationship between the - and +
234 code, because in the case where the + code is a separate statement in a
235 sequence, this is not a problem. Perhaps something could be done in
238 The example seems strange. Why isn't the cast attached to x?
241 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
242 (match Ast0.get_mcodekind e
with
243 Ast0.CONTEXT
(cell
) -> true
246 (* needs a special case when there is a Disj or an empty DOTS
247 the following stops at the statement level, and gives true if one
248 statement is replaced by another *)
249 let rec is_pure_context s
=
250 !Flag.sgrep_mode2
or (* everything is context for sgrep *)
251 (match Ast0.unwrap s
with
252 Ast0.Disj
(starter
,statement_dots_list
,mids
,ender
) ->
255 match Ast0.undots
x with
256 [s
] -> is_pure_context s
257 | _
-> false (* could we do better? *))
260 (match Ast0.get_mcodekind s
with
263 (Ast.NOTHING
,_
,_
) -> true
267 (* do better for the common case of replacing a stmt by another one *)
268 ([[Ast.StatementTag
(s
)]],_
) ->
269 (match Ast.unwrap s
with
270 Ast.IfThen
(_
,_
,_
) -> false (* potentially dangerous *)
276 match Ast0.get_mcodekind e
with Ast0.MINUS
(cell
) -> true | _
-> false
278 let match_list matcher is_list_matcher do_list_match la lb
=
279 let rec loop = function
280 ([],[]) -> return true
281 | ([x],lb
) when is_list_matcher
x -> do_list_match
x lb
282 | (x::xs
,y
::ys
) -> conjunct_bindings (matcher
x y
) (loop (xs
,ys
))
283 | _
-> return false in
286 let match_maker checks_needed context_required whencode_allowed
=
288 let check_mcode pmc cmc binding
=
291 match Ast0.get_pos cmc
with
292 (Ast0.MetaPos
(name
,_
,_
)) as x ->
293 (match Ast0.get_pos pmc
with
294 Ast0.MetaPos
(name1
,_
,_
) ->
295 add_binding name1
(Ast0.MetaPosTag
x) binding
297 let (rule
,name
) = Ast0.unwrap_mcode name
in
298 Fail
(Position
(rule
,name
)))
299 | Ast0.NoMetaPos
-> OK binding
302 let match_dots matcher is_list_matcher do_list_match d1 d2
=
303 match (Ast0.unwrap d1
, Ast0.unwrap d2
) with
304 (Ast0.DOTS
(la
),Ast0.DOTS
(lb
))
305 | (Ast0.CIRCLES
(la
),Ast0.CIRCLES
(lb
))
306 | (Ast0.STARS
(la
),Ast0.STARS
(lb
)) ->
307 match_list matcher is_list_matcher
(do_list_match d2
) la lb
308 | _
-> return false in
310 let is_elist_matcher el
=
311 match Ast0.unwrap el
with Ast0.MetaExprList
(_
,_
,_
) -> true | _
-> false in
313 let is_plist_matcher pl
=
314 match Ast0.unwrap pl
with Ast0.MetaParamList
(_
,_
,_
) -> true | _
-> false in
316 let is_slist_matcher pl
=
317 match Ast0.unwrap pl
with Ast0.MetaStmtList
(_
,_
) -> true | _
-> false in
319 let no_list _
= false in
321 let build_dots pattern data
=
322 match Ast0.unwrap pattern
with
323 Ast0.DOTS
(_
) -> Ast0.rewrap pattern
(Ast0.DOTS
(data
))
324 | Ast0.CIRCLES
(_
) -> Ast0.rewrap pattern
(Ast0.CIRCLES
(data
))
325 | Ast0.STARS
(_
) -> Ast0.rewrap pattern
(Ast0.STARS
(data
)) in
328 let bind = Ast0.lub_pure
in
329 let option_default = Ast0.Context
in
330 let pure_mcodekind mc
=
332 then Ast0.PureContext
337 (Ast.NOTHING
,_
,_
) -> Ast0.PureContext
340 (match !mc
with ([],_
) -> Ast0.Pure
| _
-> Ast0.Impure
)
341 | _
-> Ast0.Impure
in
342 let donothing r k e
=
343 bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
) in
345 let mcode m
= pure_mcodekind (Ast0.get_mcode_mcodekind m
) in
347 (* a case for everything that has a metavariable *)
348 (* pure is supposed to match only unitary metavars, not anything that
349 contains only unitary metavars *)
351 bind (bind (pure_mcodekind (Ast0.get_mcodekind i
)) (k i
))
352 (match Ast0.unwrap i
with
353 Ast0.MetaId
(name
,_
,pure
) | Ast0.MetaFunc
(name
,_
,pure
)
354 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> pure
355 | _
-> Ast0.Impure
) in
357 let expression r k e
=
358 bind (bind (pure_mcodekind (Ast0.get_mcodekind e
)) (k e
))
359 (match Ast0.unwrap e
with
360 Ast0.MetaErr
(name
,_
,pure
)
361 | Ast0.MetaExpr
(name
,_
,_
,_
,pure
) | Ast0.MetaExprList
(name
,_
,pure
) ->
363 | _
-> Ast0.Impure
) in
366 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
367 (match Ast0.unwrap t
with
368 Ast0.MetaType
(name
,pure
) -> pure
369 | _
-> Ast0.Impure
) in
372 bind (bind (pure_mcodekind (Ast0.get_mcodekind t
)) (k t
))
373 (match Ast0.unwrap t
with
374 Ast0.MetaInit
(name
,pure
) -> pure
375 | _
-> Ast0.Impure
) in
378 bind (bind (pure_mcodekind (Ast0.get_mcodekind p
)) (k p
))
379 (match Ast0.unwrap p
with
380 Ast0.MetaParam
(name
,pure
) | Ast0.MetaParamList
(name
,_
,pure
) -> pure
381 | _
-> Ast0.Impure
) in
384 bind (bind (pure_mcodekind (Ast0.get_mcodekind s
)) (k s
))
385 (match Ast0.unwrap s
with
386 Ast0.MetaStmt
(name
,pure
) | Ast0.MetaStmtList
(name
,pure
) -> pure
387 | _
-> Ast0.Impure
) in
389 V0.flat_combiner
bind option_default
390 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
391 donothing donothing donothing donothing donothing donothing
392 ident expression typeC init param donothing stmt donothing
395 let add_pure_list_binding name pure is_pure builder1 builder2 lst
=
396 match (checks_needed
,pure
) with
397 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
400 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
401 then add_binding name
(builder1 lst
)
402 else return_false (NotPure
(pure
,term name
,builder1 lst
))
403 | _
-> return_false (NotPureLength
(term name
)))
404 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder2 lst
) in
406 let add_pure_binding name pure is_pure builder
x =
407 match (checks_needed
,pure
) with
408 (true,Ast0.Pure
) | (true,Ast0.Context
) | (true,Ast0.PureContext
) ->
409 if (Ast0.lub_pure
(is_pure
x) pure
) = pure
410 then add_binding name
(builder
x)
411 else return_false (NotPure
(pure
,term name
, builder
x))
412 | (false,_
) | (_
,Ast0.Impure
) -> add_binding name
(builder
x) in
414 let do_elist_match builder el lst
=
415 match Ast0.unwrap el
with
416 Ast0.MetaExprList
(name
,lenname
,pure
) ->
417 (*how to handle lenname? should it be an option type and always None?*)
418 failwith
"expr list pattern not supported in iso"
419 (*add_pure_list_binding name pure
420 pure_sp_code.V0.combiner_expression
421 (function lst -> Ast0.ExprTag(List.hd lst))
422 (function lst -> Ast0.DotsExprTag(build_dots builder lst))
424 | _
-> failwith
"not possible" in
426 let do_plist_match builder pl lst
=
427 match Ast0.unwrap pl
with
428 Ast0.MetaParamList
(name
,lename
,pure
) ->
429 failwith
"param list pattern not supported in iso"
430 (*add_pure_list_binding name pure
431 pure_sp_code.V0.combiner_parameter
432 (function lst -> Ast0.ParamTag(List.hd lst))
433 (function lst -> Ast0.DotsParamTag(build_dots builder lst))
435 | _
-> failwith
"not possible" in
437 let do_slist_match builder sl lst
=
438 match Ast0.unwrap sl
with
439 Ast0.MetaStmtList
(name
,pure
) ->
440 add_pure_list_binding name pure
441 pure_sp_code.VT0.combiner_rec_statement
442 (function lst
-> Ast0.StmtTag
(List.hd lst
))
443 (function lst
-> Ast0.DotsStmtTag
(build_dots builder lst
))
445 | _
-> failwith
"not possible" in
447 let do_nolist_match _ _
= failwith
"not possible" in
449 let rec match_ident pattern id
=
450 match Ast0.unwrap pattern
with
451 Ast0.MetaId
(name
,_
,pure
) ->
452 (add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_ident
453 (function id
-> Ast0.IdentTag id
) id
)
454 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
455 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
457 if not
(checks_needed
) or not
(context_required
) or is_context id
459 match (up
,Ast0.unwrap id
) with
460 (Ast0.Id
(namea
),Ast0.Id
(nameb
)) ->
461 if mcode_equal namea nameb
462 then check_mcode namea nameb
464 | (Ast0.OptIdent
(ida
),Ast0.OptIdent
(idb
))
465 | (Ast0.UniqueIdent
(ida
),Ast0.UniqueIdent
(idb
)) ->
467 | (_
,Ast0.OptIdent
(idb
))
468 | (_
,Ast0.UniqueIdent
(idb
)) -> match_ident pattern idb
470 else return_false (ContextRequired
(Ast0.IdentTag id
)) in
472 (* should we do something about matching metavars against ...? *)
473 let rec match_expr pattern expr
=
474 match Ast0.unwrap pattern
with
475 Ast0.MetaExpr
(name
,_
,ty
,form
,pure
) ->
477 match (form
,expr
) with
481 match Ast0.unwrap e
with
482 Ast0.Constant
(c
) -> true
483 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
484 | Ast0.SizeOfExpr
(se
,exp
) -> true
485 | Ast0.SizeOfType
(se
,lp
,ty
,rp
) -> true
486 | Ast0.MetaExpr
(nm
,_
,_
,Ast.CONST
,p
) ->
487 (Ast0.lub_pure p pure
) = pure
490 | (Ast.ID
,e
) | (Ast.LocalID
,e
) ->
492 match Ast0.unwrap e
with
493 Ast0.Ident
(c
) -> true
494 | Ast0.Cast
(lp
,ty
,rp
,e
) -> matches e
495 | Ast0.MetaExpr
(nm
,_
,_
,Ast.ID
,p
) ->
496 (Ast0.lub_pure p pure
) = pure
504 (function Type_cocci.MetaType
(_
,_
,_
) -> true | _
-> false)
508 [Type_cocci.MetaType
(tyname
,_
,_
)] ->
510 match (Ast0.unwrap expr
,Ast0.get_type expr
) with
511 (* easier than updating type inferencer to manage multiple
513 (Ast0.MetaExpr
(_
,_
,Some tts
,_
,_
),_
) -> Some tts
514 | (_
,Some ty
) -> Some
[ty
]
518 let tyname = Ast0.rewrap_mcode name
tyname in
520 (add_pure_binding name pure
521 pure_sp_code.VT0.combiner_rec_expression
522 (function expr
-> Ast0.ExprTag expr
)
524 (function bindings
->
529 add_pure_binding tyname Ast0.Impure
530 (function _
-> Ast0.Impure
)
531 (function ty
-> Ast0.TypeCTag ty
)
533 (Ast0.reverse_type
expty))
537 "warning: unconvertible type";
538 return false bindings
))
541 (function Fail _
-> false | OK
x -> true)
544 (* not sure why this is ok. can there be more
548 (function Fail _
-> [] | OK
x -> x)
556 | OK
x -> failwith
"not possible")
560 "warning: type metavar can only match one type";*)
564 "mixture of metatype and other types not supported")
566 let expty = Ast0.get_type expr
in
567 if List.exists
(function t
-> Type_cocci.compatible t
expty) ts
569 add_pure_binding name pure
570 pure_sp_code.VT0.combiner_rec_expression
571 (function expr
-> Ast0.ExprTag expr
)
575 add_pure_binding name pure
576 pure_sp_code.VT0.combiner_rec_expression
577 (function expr
-> Ast0.ExprTag expr
)
580 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
581 | Ast0.MetaExprList
(_
,_
,_
) -> failwith
"metaexprlist not supported"
583 if not
(checks_needed
) or not
(context_required
) or is_context expr
585 match (up
,Ast0.unwrap expr
) with
586 (Ast0.Ident
(ida
),Ast0.Ident
(idb
)) ->
588 | (Ast0.Constant
(consta
),Ast0.Constant
(constb
)) ->
589 if mcode_equal consta constb
590 then check_mcode consta constb
592 | (Ast0.FunCall
(fna
,lp1
,argsa
,rp1
),Ast0.FunCall
(fnb
,lp
,argsb
,rp
)) ->
593 conjunct_many_bindings
594 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr fna fnb
;
595 match_dots match_expr is_elist_matcher do_elist_match
597 | (Ast0.Assignment
(lefta
,opa
,righta
,_
),
598 Ast0.Assignment
(leftb
,opb
,rightb
,_
)) ->
599 if mcode_equal opa opb
601 conjunct_many_bindings
602 [check_mcode opa opb
; match_expr lefta leftb
;
603 match_expr righta rightb
]
605 | (Ast0.CondExpr
(exp1a
,lp1
,exp2a
,rp1
,exp3a
),
606 Ast0.CondExpr
(exp1b
,lp
,exp2b
,rp
,exp3b
)) ->
607 conjunct_many_bindings
608 [check_mcode lp1 lp
; check_mcode rp1 rp
;
609 match_expr exp1a exp1b
; match_option match_expr exp2a exp2b
;
610 match_expr exp3a exp3b
]
611 | (Ast0.Postfix
(expa
,opa
),Ast0.Postfix
(expb
,opb
)) ->
612 if mcode_equal opa opb
614 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
616 | (Ast0.Infix
(expa
,opa
),Ast0.Infix
(expb
,opb
)) ->
617 if mcode_equal opa opb
619 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
621 | (Ast0.Unary
(expa
,opa
),Ast0.Unary
(expb
,opb
)) ->
622 if mcode_equal opa opb
624 conjunct_bindings (check_mcode opa opb
) (match_expr expa expb
)
626 | (Ast0.Binary
(lefta
,opa
,righta
),Ast0.Binary
(leftb
,opb
,rightb
)) ->
627 if mcode_equal opa opb
629 conjunct_many_bindings
630 [check_mcode opa opb
; match_expr lefta leftb
;
631 match_expr righta rightb
]
633 | (Ast0.Paren
(lp1
,expa
,rp1
),Ast0.Paren
(lp
,expb
,rp
)) ->
634 conjunct_many_bindings
635 [check_mcode lp1 lp
; check_mcode rp1 rp
; match_expr expa expb
]
636 | (Ast0.ArrayAccess
(exp1a
,lb1
,exp2a
,rb1
),
637 Ast0.ArrayAccess
(exp1b
,lb
,exp2b
,rb
)) ->
638 conjunct_many_bindings
639 [check_mcode lb1 lb
; check_mcode rb1 rb
;
640 match_expr exp1a exp1b
; match_expr exp2a exp2b
]
641 | (Ast0.RecordAccess
(expa
,opa
,fielda
),
642 Ast0.RecordAccess
(expb
,op
,fieldb
))
643 | (Ast0.RecordPtAccess
(expa
,opa
,fielda
),
644 Ast0.RecordPtAccess
(expb
,op
,fieldb
)) ->
645 conjunct_many_bindings
646 [check_mcode opa op
; match_expr expa expb
;
647 match_ident fielda fieldb
]
648 | (Ast0.Cast
(lp1
,tya
,rp1
,expa
),Ast0.Cast
(lp
,tyb
,rp
,expb
)) ->
649 conjunct_many_bindings
650 [check_mcode lp1 lp
; check_mcode rp1 rp
;
651 match_typeC tya tyb
; match_expr expa expb
]
652 | (Ast0.SizeOfExpr
(szf1
,expa
),Ast0.SizeOfExpr
(szf
,expb
)) ->
653 conjunct_bindings (check_mcode szf1 szf
) (match_expr expa expb
)
654 | (Ast0.SizeOfType
(szf1
,lp1
,tya
,rp1
),
655 Ast0.SizeOfType
(szf
,lp
,tyb
,rp
)) ->
656 conjunct_many_bindings
657 [check_mcode lp1 lp
; check_mcode rp1 rp
;
658 check_mcode szf1 szf
; match_typeC tya tyb
]
659 | (Ast0.TypeExp
(tya
),Ast0.TypeExp
(tyb
)) ->
661 | (Ast0.EComma
(cm1
),Ast0.EComma
(cm
)) -> check_mcode cm1 cm
662 | (Ast0.DisjExpr
(_
,expsa
,_
,_
),_
) ->
663 failwith
"not allowed in the pattern of an isomorphism"
664 | (Ast0.NestExpr
(_
,exp_dotsa
,_
,_
,_
),_
) ->
665 failwith
"not allowed in the pattern of an isomorphism"
666 | (Ast0.Edots
(d
,None
),Ast0.Edots
(d1
,None
))
667 | (Ast0.Ecircles
(d
,None
),Ast0.Ecircles
(d1
,None
))
668 | (Ast0.Estars
(d
,None
),Ast0.Estars
(d1
,None
)) -> check_mcode d d1
669 | (Ast0.Edots
(ed
,None
),Ast0.Edots
(ed1
,Some wc
))
670 | (Ast0.Ecircles
(ed
,None
),Ast0.Ecircles
(ed1
,Some wc
))
671 | (Ast0.Estars
(ed
,None
),Ast0.Estars
(ed1
,Some wc
)) ->
672 (* hope that mcode of edots is unique somehow *)
673 conjunct_bindings (check_mcode ed ed1
)
674 (let (edots_whencode_allowed
,_
,_
) = whencode_allowed
in
675 if edots_whencode_allowed
676 then add_dot_binding ed
(Ast0.ExprTag wc
)
679 "warning: not applying iso because of whencode";
681 | (Ast0.Edots
(_
,Some _
),_
) | (Ast0.Ecircles
(_
,Some _
),_
)
682 | (Ast0.Estars
(_
,Some _
),_
) ->
683 failwith
"whencode not allowed in a pattern1"
684 | (Ast0.OptExp
(expa
),Ast0.OptExp
(expb
))
685 | (Ast0.UniqueExp
(expa
),Ast0.UniqueExp
(expb
)) -> match_expr expa expb
686 | (_
,Ast0.OptExp
(expb
))
687 | (_
,Ast0.UniqueExp
(expb
)) -> match_expr pattern expb
689 else return_false (ContextRequired
(Ast0.ExprTag expr
))
691 (* the special case for function types prevents the eg T X; -> T X = E; iso
692 from applying, which doesn't seem very relevant, but it also avoids a
693 mysterious bug that is obtained with eg int attach(...); *)
694 and match_typeC pattern t
=
695 match Ast0.unwrap pattern
with
696 Ast0.MetaType
(name
,pure
) ->
697 (match Ast0.unwrap t
with
698 Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
) -> return false
700 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_typeC
701 (function ty
-> Ast0.TypeCTag ty
)
704 if not
(checks_needed
) or not
(context_required
) or is_context t
706 match (up
,Ast0.unwrap t
) with
707 (Ast0.ConstVol
(cva
,tya
),Ast0.ConstVol
(cvb
,tyb
)) ->
708 if mcode_equal cva cvb
710 conjunct_bindings (check_mcode cva cvb
) (match_typeC tya tyb
)
712 | (Ast0.BaseType
(tya
,stringsa
),Ast0.BaseType
(tyb
,stringsb
)) ->
715 match_list check_mcode
716 (function _
-> false) (function _
-> failwith
"")
719 | (Ast0.Signed
(signa
,tya
),Ast0.Signed
(signb
,tyb
)) ->
720 if mcode_equal signa signb
722 conjunct_bindings (check_mcode signa signb
)
723 (match_option match_typeC tya tyb
)
725 | (Ast0.Pointer
(tya
,star1
),Ast0.Pointer
(tyb
,star
)) ->
726 conjunct_bindings (check_mcode star1 star
) (match_typeC tya tyb
)
727 | (Ast0.FunctionPointer
(tya
,lp1a
,stara
,rp1a
,lp2a
,paramsa
,rp2a
),
728 Ast0.FunctionPointer
(tyb
,lp1b
,starb
,rp1b
,lp2b
,paramsb
,rp2b
)) ->
729 conjunct_many_bindings
730 [check_mcode stara starb
; check_mcode lp1a lp1b
;
731 check_mcode rp1a rp1b
; check_mcode lp2a lp2b
;
732 check_mcode rp2a rp2b
; match_typeC tya tyb
;
733 match_dots match_param
is_plist_matcher
734 do_plist_match paramsa paramsb
]
735 | (Ast0.FunctionType
(tya
,lp1a
,paramsa
,rp1a
),
736 Ast0.FunctionType
(tyb
,lp1b
,paramsb
,rp1b
)) ->
737 conjunct_many_bindings
738 [check_mcode lp1a lp1b
; check_mcode rp1a rp1b
;
739 match_option match_typeC tya tyb
;
740 match_dots match_param
is_plist_matcher do_plist_match
742 | (Ast0.Array
(tya
,lb1
,sizea
,rb1
),Ast0.Array
(tyb
,lb
,sizeb
,rb
)) ->
743 conjunct_many_bindings
744 [check_mcode lb1 lb
; check_mcode rb1 rb
;
745 match_typeC tya tyb
; match_option match_expr sizea sizeb
]
746 | (Ast0.EnumName
(kinda
,namea
),Ast0.EnumName
(kindb
,nameb
)) ->
747 conjunct_bindings (check_mcode kinda kindb
)
748 (match_ident namea nameb
)
749 | (Ast0.StructUnionName
(kinda
,Some namea
),
750 Ast0.StructUnionName
(kindb
,Some nameb
)) ->
751 if mcode_equal kinda kindb
753 conjunct_bindings (check_mcode kinda kindb
)
754 (match_ident namea nameb
)
756 | (Ast0.StructUnionDef
(tya
,lb1
,declsa
,rb1
),
757 Ast0.StructUnionDef
(tyb
,lb
,declsb
,rb
)) ->
758 conjunct_many_bindings
759 [check_mcode lb1 lb
; check_mcode rb1 rb
;
761 match_dots match_decl
no_list do_nolist_match declsa declsb
]
762 | (Ast0.TypeName
(namea
),Ast0.TypeName
(nameb
)) ->
763 if mcode_equal namea nameb
764 then check_mcode namea nameb
766 | (Ast0.DisjType
(_
,typesa
,_
,_
),Ast0.DisjType
(_
,typesb
,_
,_
)) ->
767 failwith
"not allowed in the pattern of an isomorphism"
768 | (Ast0.OptType
(tya
),Ast0.OptType
(tyb
))
769 | (Ast0.UniqueType
(tya
),Ast0.UniqueType
(tyb
)) -> match_typeC tya tyb
770 | (_
,Ast0.OptType
(tyb
))
771 | (_
,Ast0.UniqueType
(tyb
)) -> match_typeC pattern tyb
773 else return_false (ContextRequired
(Ast0.TypeCTag t
))
775 and match_decl pattern d
=
776 if not
(checks_needed
) or not
(context_required
) or is_context d
778 match (Ast0.unwrap pattern
,Ast0.unwrap d
) with
779 (Ast0.Init
(stga
,tya
,ida
,eq1
,inia
,sc1
),
780 Ast0.Init
(stgb
,tyb
,idb
,eq
,inib
,sc
)) ->
781 if bool_match_option mcode_equal stga stgb
783 conjunct_many_bindings
784 [check_mcode eq1 eq
; check_mcode sc1 sc
;
785 match_option check_mcode stga stgb
;
786 match_typeC tya tyb
; match_ident ida idb
;
787 match_init inia inib
]
789 | (Ast0.UnInit
(stga
,tya
,ida
,sc1
),Ast0.UnInit
(stgb
,tyb
,idb
,sc
)) ->
790 if bool_match_option mcode_equal stga stgb
792 conjunct_many_bindings
793 [check_mcode sc1 sc
; match_option check_mcode stga stgb
;
794 match_typeC tya tyb
; match_ident ida idb
]
796 | (Ast0.MacroDecl
(namea
,lp1
,argsa
,rp1
,sc1
),
797 Ast0.MacroDecl
(nameb
,lp
,argsb
,rp
,sc
)) ->
798 conjunct_many_bindings
799 [match_ident namea nameb
;
800 check_mcode lp1 lp
; check_mcode rp1 rp
;
802 match_dots match_expr is_elist_matcher do_elist_match
804 | (Ast0.TyDecl
(tya
,sc1
),Ast0.TyDecl
(tyb
,sc
)) ->
805 conjunct_bindings (check_mcode sc1 sc
) (match_typeC tya tyb
)
806 | (Ast0.Typedef
(stga
,tya
,ida
,sc1
),Ast0.Typedef
(stgb
,tyb
,idb
,sc
)) ->
807 conjunct_bindings (check_mcode sc1 sc
)
808 (conjunct_bindings (match_typeC tya tyb
) (match_typeC ida idb
))
809 | (Ast0.DisjDecl
(_
,declsa
,_
,_
),Ast0.DisjDecl
(_
,declsb
,_
,_
)) ->
810 failwith
"not allowed in the pattern of an isomorphism"
811 | (Ast0.Ddots
(d1
,None
),Ast0.Ddots
(d
,None
)) -> check_mcode d1 d
812 | (Ast0.Ddots
(dd
,None
),Ast0.Ddots
(d
,Some wc
)) ->
813 conjunct_bindings (check_mcode dd d
)
814 (* hope that mcode of ddots is unique somehow *)
815 (let (ddots_whencode_allowed
,_
,_
) = whencode_allowed
in
816 if ddots_whencode_allowed
817 then add_dot_binding dd
(Ast0.DeclTag wc
)
819 (Printf.printf
"warning: not applying iso because of whencode";
821 | (Ast0.Ddots
(_
,Some _
),_
) ->
822 failwith
"whencode not allowed in a pattern1"
824 | (Ast0.OptDecl
(decla
),Ast0.OptDecl
(declb
))
825 | (Ast0.UniqueDecl
(decla
),Ast0.UniqueDecl
(declb
)) ->
826 match_decl decla declb
827 | (_
,Ast0.OptDecl
(declb
))
828 | (_
,Ast0.UniqueDecl
(declb
)) ->
829 match_decl pattern declb
831 else return_false (ContextRequired
(Ast0.DeclTag d
))
833 and match_init pattern i
=
834 match Ast0.unwrap pattern
with
835 Ast0.MetaInit
(name
,pure
) ->
836 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_initialiser
837 (function ini
-> Ast0.InitTag ini
)
840 if not
(checks_needed
) or not
(context_required
) or is_context i
842 match (up
,Ast0.unwrap i
) with
843 (Ast0.InitExpr
(expa
),Ast0.InitExpr
(expb
)) ->
845 | (Ast0.InitList
(lb1
,initlista
,rb1
),Ast0.InitList
(lb
,initlistb
,rb
))
847 conjunct_many_bindings
848 [check_mcode lb1 lb
; check_mcode rb1 rb
;
849 match_dots match_init
no_list do_nolist_match
851 | (Ast0.InitGccExt
(designators1
,e1
,inia
),
852 Ast0.InitGccExt
(designators2
,e2
,inib
)) ->
853 conjunct_many_bindings
854 [match_list match_designator
855 (function _
-> false) (function _
-> failwith
"")
856 designators1 designators2
;
858 match_init inia inib
]
859 | (Ast0.InitGccName
(namea
,c1
,inia
),Ast0.InitGccName
(nameb
,c
,inib
)) ->
860 conjunct_many_bindings
861 [check_mcode c1 c
; match_ident namea nameb
;
862 match_init inia inib
]
863 | (Ast0.IComma
(c1
),Ast0.IComma
(c
)) -> check_mcode c1 c
864 | (Ast0.Idots
(d1
,None
),Ast0.Idots
(d
,None
)) -> check_mcode d1 d
865 | (Ast0.Idots
(id
,None
),Ast0.Idots
(d
,Some wc
)) ->
866 conjunct_bindings (check_mcode id d
)
867 (* hope that mcode of edots is unique somehow *)
868 (let (_
,idots_whencode_allowed
,_
) = whencode_allowed
in
869 if idots_whencode_allowed
870 then add_dot_binding id
(Ast0.InitTag wc
)
873 "warning: not applying iso because of whencode";
875 | (Ast0.Idots
(_
,Some _
),_
) ->
876 failwith
"whencode not allowed in a pattern2"
877 | (Ast0.OptIni
(ia
),Ast0.OptIni
(ib
))
878 | (Ast0.UniqueIni
(ia
),Ast0.UniqueIni
(ib
)) -> match_init ia ib
879 | (_
,Ast0.OptIni
(ib
))
880 | (_
,Ast0.UniqueIni
(ib
)) -> match_init pattern ib
882 else return_false (ContextRequired
(Ast0.InitTag i
))
884 and match_designator pattern d
=
885 match (pattern
,d
) with
886 (Ast0.DesignatorField
(dota
,ida
),Ast0.DesignatorField
(dotb
,idb
)) ->
887 conjunct_bindings (check_mcode dota dotb
) (match_ident ida idb
)
888 | (Ast0.DesignatorIndex
(lba
,expa
,rba
),
889 Ast0.DesignatorIndex
(lbb
,expb
,rbb
)) ->
890 conjunct_many_bindings
891 [check_mcode lba lbb
; match_expr expa expb
;
893 | (Ast0.DesignatorRange
(lba
,mina
,dotsa
,maxa
,rba
),
894 Ast0.DesignatorRange
(lbb
,minb
,dotsb
,maxb
,rbb
)) ->
895 conjunct_many_bindings
896 [check_mcode lba lbb
; match_expr mina minb
;
897 check_mcode dotsa dotsb
; match_expr maxa maxb
;
901 and match_param pattern p
=
902 match Ast0.unwrap pattern
with
903 Ast0.MetaParam
(name
,pure
) ->
904 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_parameter
905 (function p
-> Ast0.ParamTag p
)
907 | Ast0.MetaParamList
(name
,_
,pure
) -> failwith
"metaparamlist not supported"
909 if not
(checks_needed
) or not
(context_required
) or is_context p
911 match (up
,Ast0.unwrap p
) with
912 (Ast0.VoidParam
(tya
),Ast0.VoidParam
(tyb
)) -> match_typeC tya tyb
913 | (Ast0.Param
(tya
,ida
),Ast0.Param
(tyb
,idb
)) ->
914 conjunct_bindings (match_typeC tya tyb
)
915 (match_option match_ident ida idb
)
916 | (Ast0.PComma
(c1
),Ast0.PComma
(c
)) -> check_mcode c1 c
917 | (Ast0.Pdots
(d1
),Ast0.Pdots
(d
))
918 | (Ast0.Pcircles
(d1
),Ast0.Pcircles
(d
)) -> check_mcode d1 d
919 | (Ast0.OptParam
(parama
),Ast0.OptParam
(paramb
))
920 | (Ast0.UniqueParam
(parama
),Ast0.UniqueParam
(paramb
)) ->
921 match_param parama paramb
922 | (_
,Ast0.OptParam
(paramb
))
923 | (_
,Ast0.UniqueParam
(paramb
)) -> match_param pattern paramb
925 else return_false (ContextRequired
(Ast0.ParamTag p
))
927 and match_statement pattern s
=
928 match Ast0.unwrap pattern
with
929 Ast0.MetaStmt
(name
,pure
) ->
930 (match Ast0.unwrap s
with
931 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) ->
932 return false (* ... is not a single statement *)
934 add_pure_binding name pure
pure_sp_code.VT0.combiner_rec_statement
935 (function ty
-> Ast0.StmtTag ty
)
937 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
939 if not
(checks_needed
) or not
(context_required
) or is_context s
941 match (up
,Ast0.unwrap s
) with
942 (Ast0.FunDecl
(_
,fninfoa
,namea
,lp1
,paramsa
,rp1
,lb1
,bodya
,rb1
),
943 Ast0.FunDecl
(_
,fninfob
,nameb
,lp
,paramsb
,rp
,lb
,bodyb
,rb
)) ->
944 conjunct_many_bindings
945 [check_mcode lp1 lp
; check_mcode rp1 rp
;
946 check_mcode lb1 lb
; check_mcode rb1 rb
;
947 match_fninfo fninfoa fninfob
; match_ident namea nameb
;
948 match_dots match_param
is_plist_matcher do_plist_match
950 match_dots match_statement
is_slist_matcher do_slist_match
952 | (Ast0.Decl
(_
,decla
),Ast0.Decl
(_
,declb
)) ->
953 match_decl decla declb
954 | (Ast0.Seq
(lb1
,bodya
,rb1
),Ast0.Seq
(lb
,bodyb
,rb
)) ->
955 (* seqs can only match if they are all minus (plus code
956 allowed) or all context (plus code not allowed in the body).
957 we could be more permissive if the expansions of the isos are
958 also all seqs, but this would be hard to check except at top
959 level, and perhaps not worth checking even in that case.
960 Overall, the issue is that braces are used where single
961 statements are required, and something not satisfying these
962 conditions can cause a single statement to become a
963 non-single statement after the transformation.
965 example: if { ... -foo(); ... }
966 if we let the sequence convert to just -foo();
967 then we produce invalid code. For some reason,
968 single_statement can't deal with this case, perhaps because
969 it starts introducing too many braces? don't remember the
972 conjunct_bindings (check_mcode lb1 lb
)
973 (conjunct_bindings (check_mcode rb1 rb
)
974 (if not
(checks_needed
) or is_minus s
or
976 List.for_all
is_pure_context (Ast0.undots bodyb
))
978 match_dots match_statement
is_slist_matcher do_slist_match
980 else return_false (Braces
(s
))))
981 | (Ast0.ExprStatement
(expa
,sc1
),Ast0.ExprStatement
(expb
,sc
)) ->
982 conjunct_bindings (check_mcode sc1 sc
) (match_expr expa expb
)
983 | (Ast0.IfThen
(if1
,lp1
,expa
,rp1
,branch1a
,_
),
984 Ast0.IfThen
(if2
,lp2
,expb
,rp2
,branch1b
,_
)) ->
985 conjunct_many_bindings
986 [check_mcode if1 if2
; check_mcode lp1 lp2
;
988 match_expr expa expb
;
989 match_statement branch1a branch1b
]
990 | (Ast0.IfThenElse
(if1
,lp1
,expa
,rp1
,branch1a
,e1
,branch2a
,_
),
991 Ast0.IfThenElse
(if2
,lp2
,expb
,rp2
,branch1b
,e2
,branch2b
,_
)) ->
992 conjunct_many_bindings
993 [check_mcode if1 if2
; check_mcode lp1 lp2
;
994 check_mcode rp1 rp2
; check_mcode e1 e2
;
995 match_expr expa expb
;
996 match_statement branch1a branch1b
;
997 match_statement branch2a branch2b
]
998 | (Ast0.While
(w1
,lp1
,expa
,rp1
,bodya
,_
),
999 Ast0.While
(w
,lp
,expb
,rp
,bodyb
,_
)) ->
1000 conjunct_many_bindings
1001 [check_mcode w1 w
; check_mcode lp1 lp
;
1002 check_mcode rp1 rp
; match_expr expa expb
;
1003 match_statement bodya bodyb
]
1004 | (Ast0.Do
(d1
,bodya
,w1
,lp1
,expa
,rp1
,_
),
1005 Ast0.Do
(d
,bodyb
,w
,lp
,expb
,rp
,_
)) ->
1006 conjunct_many_bindings
1007 [check_mcode d1 d
; check_mcode w1 w
; check_mcode lp1 lp
;
1008 check_mcode rp1 rp
; match_statement bodya bodyb
;
1009 match_expr expa expb
]
1010 | (Ast0.For
(f1
,lp1
,e1a
,sc1a
,e2a
,sc2a
,e3a
,rp1
,bodya
,_
),
1011 Ast0.For
(f
,lp
,e1b
,sc1b
,e2b
,sc2b
,e3b
,rp
,bodyb
,_
)) ->
1012 conjunct_many_bindings
1013 [check_mcode f1 f
; check_mcode lp1 lp
; check_mcode sc1a sc1b
;
1014 check_mcode sc2a sc2b
; check_mcode rp1 rp
;
1015 match_option match_expr e1a e1b
;
1016 match_option match_expr e2a e2b
;
1017 match_option match_expr e3a e3b
;
1018 match_statement bodya bodyb
]
1019 | (Ast0.Iterator
(nma
,lp1
,argsa
,rp1
,bodya
,_
),
1020 Ast0.Iterator
(nmb
,lp
,argsb
,rp
,bodyb
,_
)) ->
1021 conjunct_many_bindings
1022 [match_ident nma nmb
;
1023 check_mcode lp1 lp
; check_mcode rp1 rp
;
1024 match_dots match_expr is_elist_matcher do_elist_match
1026 match_statement bodya bodyb
]
1027 | (Ast0.Switch
(s1
,lp1
,expa
,rp1
,lb1
,declsa
,casesa
,rb1
),
1028 Ast0.Switch
(s
,lp
,expb
,rp
,lb
,declsb
,casesb
,rb
)) ->
1029 conjunct_many_bindings
1030 [check_mcode s1 s
; check_mcode lp1 lp
; check_mcode rp1 rp
;
1031 check_mcode lb1 lb
; check_mcode rb1 rb
;
1032 match_expr expa expb
;
1033 match_dots match_statement
is_slist_matcher do_slist_match
1035 match_dots match_case_line
no_list do_nolist_match
1037 | (Ast0.Break
(b1
,sc1
),Ast0.Break
(b
,sc
))
1038 | (Ast0.Continue
(b1
,sc1
),Ast0.Continue
(b
,sc
)) ->
1039 conjunct_bindings (check_mcode b1 b
) (check_mcode sc1 sc
)
1040 | (Ast0.Label
(l1
,c1
),Ast0.Label
(l2
,c
)) ->
1041 conjunct_bindings (match_ident l1 l2
) (check_mcode c1 c
)
1042 | (Ast0.Goto
(g1
,l1
,sc1
),Ast0.Goto
(g
,l2
,sc
)) ->
1043 conjunct_many_bindings
1044 [check_mcode g1 g
; check_mcode sc1 sc
; match_ident l1 l2
]
1045 | (Ast0.Return
(r1
,sc1
),Ast0.Return
(r
,sc
)) ->
1046 conjunct_bindings (check_mcode r1 r
) (check_mcode sc1 sc
)
1047 | (Ast0.ReturnExpr
(r1
,expa
,sc1
),Ast0.ReturnExpr
(r
,expb
,sc
)) ->
1048 conjunct_many_bindings
1049 [check_mcode r1 r
; check_mcode sc1 sc
; match_expr expa expb
]
1050 | (Ast0.Disj
(_
,statement_dots_lista
,_
,_
),_
) ->
1051 failwith
"disj not supported in patterns"
1052 | (Ast0.Nest
(_
,stmt_dotsa
,_
,_
,_
),_
) ->
1053 failwith
"nest not supported in patterns"
1054 | (Ast0.Exp
(expa
),Ast0.Exp
(expb
)) -> match_expr expa expb
1055 | (Ast0.TopExp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1056 | (Ast0.Exp
(expa
),Ast0.TopExp
(expb
)) -> match_expr expa expb
1057 | (Ast0.TopInit
(inita
),Ast0.TopInit
(initb
)) -> match_init inita initb
1058 | (Ast0.Ty
(tya
),Ast0.Ty
(tyb
)) -> match_typeC tya tyb
1059 | (Ast0.Dots
(d
,[]),Ast0.Dots
(d1
,wc
))
1060 | (Ast0.Circles
(d
,[]),Ast0.Circles
(d1
,wc
))
1061 | (Ast0.Stars
(d
,[]),Ast0.Stars
(d1
,wc
)) ->
1063 [] -> check_mcode d d1
1065 let (_
,_
,dots_whencode_allowed
) = whencode_allowed
in
1066 if dots_whencode_allowed
1068 conjunct_bindings (check_mcode d d1
)
1072 | Ast0.WhenNot wc
->
1073 conjunct_bindings prev
1074 (add_multi_dot_binding d
1075 (Ast0.DotsStmtTag wc
))
1076 | Ast0.WhenAlways wc
->
1077 conjunct_bindings prev
1078 (add_multi_dot_binding d
(Ast0.StmtTag wc
))
1079 | Ast0.WhenNotTrue wc
->
1080 conjunct_bindings prev
1081 (add_multi_dot_binding d
1082 (Ast0.IsoWhenTTag wc
))
1083 | Ast0.WhenNotFalse wc
->
1084 conjunct_bindings prev
1085 (add_multi_dot_binding d
1086 (Ast0.IsoWhenFTag wc
))
1087 | Ast0.WhenModifier
(x) ->
1088 conjunct_bindings prev
1089 (add_multi_dot_binding d
1090 (Ast0.IsoWhenTag
x)))
1094 "warning: not applying iso because of whencode";
1096 | (Ast0.Dots
(_
,_
::_
),_
) | (Ast0.Circles
(_
,_
::_
),_
)
1097 | (Ast0.Stars
(_
,_
::_
),_
) ->
1098 failwith
"whencode not allowed in a pattern3"
1099 | (Ast0.OptStm
(rea
),Ast0.OptStm
(reb
))
1100 | (Ast0.UniqueStm
(rea
),Ast0.UniqueStm
(reb
)) ->
1101 match_statement rea reb
1102 | (_
,Ast0.OptStm
(reb
))
1103 | (_
,Ast0.UniqueStm
(reb
)) -> match_statement pattern reb
1105 else return_false (ContextRequired
(Ast0.StmtTag s
))
1107 (* first should provide a subset of the information in the second *)
1108 and match_fninfo patterninfo cinfo
=
1109 let patterninfo = List.sort compare
patterninfo in
1110 let cinfo = List.sort compare
cinfo in
1111 let rec loop = function
1112 (Ast0.FStorage
(sta
)::resta
,Ast0.FStorage
(stb
)::restb
) ->
1113 if mcode_equal sta stb
1114 then conjunct_bindings (check_mcode sta stb
) (loop (resta
,restb
))
1116 | (Ast0.FType
(tya
)::resta
,Ast0.FType
(tyb
)::restb
) ->
1117 conjunct_bindings (match_typeC tya tyb
) (loop (resta
,restb
))
1118 | (Ast0.FInline
(ia
)::resta
,Ast0.FInline
(ib
)::restb
) ->
1119 if mcode_equal ia ib
1120 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1122 | (Ast0.FAttr
(ia
)::resta
,Ast0.FAttr
(ib
)::restb
) ->
1123 if mcode_equal ia ib
1124 then conjunct_bindings (check_mcode ia ib
) (loop (resta
,restb
))
1126 | (x::resta
,((y
::_
) as restb
)) ->
1127 (match compare
x y
with
1129 | 1 -> loop (resta
,restb
)
1130 | _
-> failwith
"not possible")
1131 | _
-> return false in
1132 loop (patterninfo,cinfo)
1134 and match_case_line pattern c
=
1135 if not
(checks_needed
) or not
(context_required
) or is_context c
1137 match (Ast0.unwrap pattern
,Ast0.unwrap c
) with
1138 (Ast0.Default
(d1
,c1
,codea
),Ast0.Default
(d
,c
,codeb
)) ->
1139 conjunct_many_bindings
1140 [check_mcode d1 d
; check_mcode c1 c
;
1141 match_dots match_statement
is_slist_matcher do_slist_match
1143 | (Ast0.Case
(ca1
,expa
,c1
,codea
),Ast0.Case
(ca
,expb
,c
,codeb
)) ->
1144 conjunct_many_bindings
1145 [check_mcode ca1 ca
; check_mcode c1 c
; match_expr expa expb
;
1146 match_dots match_statement
is_slist_matcher do_slist_match
1148 | (Ast0.DisjCase
(_
,case_linesa
,_
,_
),_
) ->
1149 failwith
"not allowed in the pattern of an isomorphism"
1150 | (Ast0.OptCase
(ca
),Ast0.OptCase
(cb
)) -> match_case_line ca cb
1151 | (_
,Ast0.OptCase
(cb
)) -> match_case_line pattern cb
1153 else return_false (ContextRequired
(Ast0.CaseLineTag c
)) in
1155 let match_statement_dots x y
=
1156 match_dots match_statement
is_slist_matcher do_slist_match x y
in
1158 (match_expr, match_decl
, match_statement
, match_typeC
,
1159 match_statement_dots)
1161 let match_expr dochecks context_required whencode_allowed
=
1162 let (fn
,_
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1165 let match_decl dochecks context_required whencode_allowed
=
1166 let (_
,fn
,_
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1169 let match_statement dochecks context_required whencode_allowed
=
1170 let (_
,_
,fn
,_
,_
) = match_maker dochecks context_required whencode_allowed
in
1173 let match_typeC dochecks context_required whencode_allowed
=
1174 let (_
,_
,_
,fn
,_
) = match_maker dochecks context_required whencode_allowed
in
1177 let match_statement_dots dochecks context_required whencode_allowed
=
1178 let (_
,_
,_
,_
,fn
) = match_maker dochecks context_required whencode_allowed
in
1181 (* --------------------------------------------------------------------- *)
1182 (* make an entire tree MINUS *)
1185 let mcode (term,arity
,info
,mcodekind
,pos
,adj
) =
1187 match mcodekind
with
1190 (Ast.NOTHING
,_
,_
) -> Ast0.MINUS
(ref([],Ast0.default_token_info
))
1191 | _
-> failwith
"make_minus: unexpected befaft")
1192 | Ast0.MINUS
(mc
) -> mcodekind
(* in the part copied from the src term *)
1193 | _
-> failwith
"make_minus mcode: unexpected mcodekind" in
1194 (term,arity
,info
,new_mcodekind,pos
,adj
) in
1196 let update_mc mcodekind e
=
1197 match !mcodekind
with
1200 (Ast.NOTHING
,_
,_
) ->
1201 mcodekind
:= Ast0.MINUS
(ref([],Ast0.default_token_info
))
1202 | _
-> failwith
"make_minus: unexpected befaft")
1203 | Ast0.MINUS
(_mc
) -> () (* in the part copied from the src term *)
1204 | Ast0.PLUS _
-> failwith
"make_minus donothing: unexpected plus mcodekind"
1205 | _
-> failwith
"make_minus donothing: unexpected mcodekind" in
1207 let donothing r k e
=
1208 let mcodekind = Ast0.get_mcodekind_ref e
in
1209 let e = k
e in update_mc mcodekind e; e in
1211 (* special case for whencode, because it isn't processed by contextneg,
1212 since it doesn't appear in the + code *)
1213 (* cases for dots and nests *)
1214 let expression r k
e =
1215 let mcodekind = Ast0.get_mcodekind_ref
e in
1216 match Ast0.unwrap
e with
1217 Ast0.Edots
(d
,whencode
) ->
1218 (*don't recurse because whencode hasn't been processed by context_neg*)
1219 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Edots
(mcode d
,whencode
))
1220 | Ast0.Ecircles
(d
,whencode
) ->
1221 (*don't recurse because whencode hasn't been processed by context_neg*)
1222 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ecircles
(mcode d
,whencode
))
1223 | Ast0.Estars
(d
,whencode
) ->
1224 (*don't recurse because whencode hasn't been processed by context_neg*)
1225 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Estars
(mcode d
,whencode
))
1226 | Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
1227 update_mc mcodekind e;
1229 (Ast0.NestExpr
(mcode starter
,
1230 r
.VT0.rebuilder_rec_expression_dots expr_dots
,
1231 mcode ender
,whencode
,multi
))
1232 | _
-> donothing r k
e in
1234 let declaration r k
e =
1235 let mcodekind = Ast0.get_mcodekind_ref
e in
1236 match Ast0.unwrap
e with
1237 Ast0.Ddots
(d
,whencode
) ->
1238 (*don't recurse because whencode hasn't been processed by context_neg*)
1239 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Ddots
(mcode d
,whencode
))
1240 | _
-> donothing r k
e in
1242 let statement r k
e =
1243 let mcodekind = Ast0.get_mcodekind_ref
e in
1244 match Ast0.unwrap
e with
1245 Ast0.Dots
(d
,whencode
) ->
1246 (*don't recurse because whencode hasn't been processed by context_neg*)
1247 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Dots
(mcode d
,whencode
))
1248 | Ast0.Circles
(d
,whencode
) ->
1249 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Circles
(mcode d
,whencode
))
1250 | Ast0.Stars
(d
,whencode
) ->
1251 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Stars
(mcode d
,whencode
))
1252 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
1253 update_mc mcodekind e;
1256 (mcode starter
,r
.VT0.rebuilder_rec_statement_dots stmt_dots
,
1257 mcode ender
,whencode
,multi
))
1258 | _
-> donothing r k
e in
1260 let initialiser r k
e =
1261 let mcodekind = Ast0.get_mcodekind_ref
e in
1262 match Ast0.unwrap
e with
1263 Ast0.Idots
(d
,whencode
) ->
1264 (*don't recurse because whencode hasn't been processed by context_neg*)
1265 update_mc mcodekind e; Ast0.rewrap
e (Ast0.Idots
(mcode d
,whencode
))
1266 | _
-> donothing r k
e in
1269 let info = Ast0.get_info
e in
1270 let mcodekind = Ast0.get_mcodekind_ref
e in
1271 match Ast0.unwrap
e with
1273 (* if context is - this should be - as well. There are no tokens
1274 here though, so the bottom-up minusifier in context_neg leaves it
1275 as mixed (or context for sgrep2). It would be better to fix
1276 context_neg, but that would
1277 require a special case for each term with a dots subterm. *)
1278 (match !mcodekind with
1279 Ast0.MIXED
(mc
) | Ast0.CONTEXT
(mc
) ->
1281 (Ast.NOTHING
,_
,_
) ->
1282 mcodekind := Ast0.MINUS
(ref([],Ast0.default_token_info
));
1284 | _
-> failwith
"make_minus: unexpected befaft")
1285 (* code already processed by an enclosing iso *)
1286 | Ast0.MINUS
(mc
) -> e
1290 "%d: make_minus donothingxxx: unexpected mcodekind: %s"
1291 info.Ast0.pos_info
.Ast0.line_start
(Dumper.dump
e)))
1292 | _
-> donothing r k
e in
1295 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1296 dots dots dots dots dots dots
1297 donothing expression donothing initialiser donothing declaration
1298 statement donothing donothing
1300 (* --------------------------------------------------------------------- *)
1301 (* rebuild mcode cells in an instantiated alt *)
1303 (* mcodes will be side effected later with plus code, so we have to copy
1304 them on instantiating an isomorphism. One could wonder whether it would
1305 be better not to use side-effects, but they are convenient for insert_plus
1306 where is it useful to manipulate a list of the mcodes but side-effect a
1308 (* hmm... Insert_plus is called before Iso_pattern... *)
1309 let rebuild_mcode start_line
=
1310 let copy_mcodekind = function
1311 Ast0.CONTEXT
(mc
) -> Ast0.CONTEXT
(ref (!mc
))
1312 | Ast0.MINUS
(mc
) -> Ast0.MINUS
(ref (!mc
))
1313 | Ast0.MIXED
(mc
) -> Ast0.MIXED
(ref (!mc
))
1314 | Ast0.PLUS count
->
1315 (* this function is used elsewhere where we need to rebuild the
1316 indices, and so we allow PLUS code as well *)
1319 let mcode (term,arity
,info,mcodekind,pos
,adj
) =
1321 match start_line
with
1324 {info.Ast0.pos_info
with
1325 Ast0.line_start
= x;
1326 Ast0.line_end
= x; } in
1327 {info with Ast0.pos_info
= new_pos_info}
1329 (term,arity
,info,copy_mcodekind mcodekind,pos
,adj
) in
1332 let old_info = Ast0.get_info
x in
1334 match start_line
with
1337 {old_info.Ast0.pos_info
with
1338 Ast0.line_start
= x;
1339 Ast0.line_end
= x; } in
1340 {old_info with Ast0.pos_info
= new_pos_info}
1341 | None
-> old_info in
1342 {x with Ast0.info = info; Ast0.index
= ref(Ast0.get_index
x);
1343 Ast0.mcodekind = ref (copy_mcodekind (Ast0.get_mcodekind
x))} in
1345 let donothing r k
e = copy_one (k
e) in
1347 (* case for control operators (if, etc) *)
1348 let statement r k
e =
1353 (match Ast0.unwrap
s with
1354 Ast0.Decl
((info,mc
),decl
) ->
1355 Ast0.Decl
((info,copy_mcodekind mc
),decl
)
1356 | Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,mc
)) ->
1357 Ast0.IfThen
(iff
,lp
,tst
,rp
,branch
,(info,copy_mcodekind mc
))
1358 | Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,(info,mc
)) ->
1359 Ast0.IfThenElse
(iff
,lp
,tst
,rp
,branch1
,els
,branch2
,
1360 (info,copy_mcodekind mc
))
1361 | Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,mc
)) ->
1362 Ast0.While
(whl
,lp
,exp
,rp
,body
,(info,copy_mcodekind mc
))
1363 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,(info,mc
)) ->
1364 Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,
1365 (info,copy_mcodekind mc
))
1366 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,mc
)) ->
1367 Ast0.Iterator
(nm
,lp
,args
,rp
,body
,(info,copy_mcodekind mc
))
1369 ((info,mc
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1371 ((info,copy_mcodekind mc
),
1372 fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
)
1374 Ast0.set_dots_bef_aft
res
1375 (match Ast0.get_dots_bef_aft
res with
1376 Ast0.NoDots
-> Ast0.NoDots
1377 | Ast0.AddingBetweenDots
s ->
1378 Ast0.AddingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)
1379 | Ast0.DroppingBetweenDots
s ->
1380 Ast0.DroppingBetweenDots
(r
.VT0.rebuilder_rec_statement
s)) in
1383 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1384 donothing donothing donothing donothing donothing donothing
1385 donothing donothing donothing donothing donothing
1386 donothing statement donothing donothing
1388 (* --------------------------------------------------------------------- *)
1389 (* The problem of whencode. If an isomorphism contains dots in multiple
1390 rules, then the code that is matched cannot contain whencode, because we
1391 won't know which dots it goes with. Should worry about nests, but they
1392 aren't allowed in isomorphisms for the moment. *)
1395 let option_default = 0 in
1396 let bind x y
= x + y
in
1398 match Ast0.unwrap
e with
1399 Ast0.Edots
(_
,_
) | Ast0.Ecircles
(_
,_
) | Ast0.Estars
(_
,_
) -> 1
1402 V0.combiner
bind option_default
1403 {V0.combiner_functions
with VT0.combiner_exprfn
= exprfn}
1406 let option_default = 0 in
1407 let bind x y
= x + y
in
1409 match Ast0.unwrap
e with Ast0.Idots
(_
,_
) -> 1 | _
-> 0 in
1411 V0.combiner
bind option_default
1412 {V0.combiner_functions
with VT0.combiner_initfn
= initfn}
1415 let option_default = 0 in
1416 let bind x y
= x + y
in
1418 match Ast0.unwrap
e with
1419 Ast0.Dots
(_
,_
) | Ast0.Circles
(_
,_
) | Ast0.Stars
(_
,_
) -> 1
1422 V0.combiner
bind option_default
1423 {V0.combiner_functions
with VT0.combiner_stmtfn
= stmtfn}
1425 (* --------------------------------------------------------------------- *)
1427 let lookup name bindings mv_bindings
=
1428 try Common.Left
(List.assoc
(term name
) bindings
)
1431 (* failure is not possible anymore *)
1432 Common.Right
(List.assoc
(term name
) mv_bindings
)
1434 (* mv_bindings is for the fresh metavariables that are introduced by the
1436 let instantiate bindings mv_bindings
=
1438 match Ast0.get_pos
x with
1439 Ast0.MetaPos
(name
,_
,_
) ->
1441 match lookup name bindings mv_bindings
with
1442 Common.Left
(Ast0.MetaPosTag
(id
)) -> Ast0.set_pos id
x
1443 | _
-> failwith
"not possible"
1444 with Not_found
-> Ast0.set_pos
Ast0.NoMetaPos
x)
1446 let donothing r k
e = k
e in
1448 (* cases where metavariables can occur *)
1451 match Ast0.unwrap
e with
1452 Ast0.MetaId
(name
,constraints
,pure
) ->
1453 (rebuild_mcode None
).VT0.rebuilder_rec_ident
1454 (match lookup name bindings mv_bindings
with
1455 Common.Left
(Ast0.IdentTag
(id
)) -> id
1456 | Common.Left
(_
) -> failwith
"not possible 1"
1457 | Common.Right
(new_mv
) ->
1460 (Ast0.set_mcode_data new_mv name
,constraints
,pure
)))
1461 | Ast0.MetaFunc
(name
,_
,pure
) -> failwith
"metafunc not supported"
1462 | Ast0.MetaLocalFunc
(name
,_
,pure
) -> failwith
"metalocalfunc not supported"
1465 (* case for list metavariables *)
1466 let rec elist r same_dots
= function
1469 (match Ast0.unwrap
x with
1470 Ast0.MetaExprList
(name
,lenname
,pure
) ->
1471 failwith
"meta_expr_list in iso not supported"
1472 (*match lookup name bindings mv_bindings with
1473 Common.Left(Ast0.DotsExprTag(exp)) ->
1474 (match same_dots exp with
1476 | None -> failwith "dots put in incompatible context")
1477 | Common.Left(Ast0.ExprTag(exp)) -> [exp]
1478 | Common.Left(_) -> failwith "not possible 1"
1479 | Common.Right(new_mv) ->
1480 failwith "MetaExprList in SP not supported"*)
1481 | _
-> [r
.VT0.rebuilder_rec_expression
x])
1482 | x::xs
-> (r
.VT0.rebuilder_rec_expression
x)::(elist r same_dots xs
) in
1484 let rec plist r same_dots
= function
1487 (match Ast0.unwrap
x with
1488 Ast0.MetaParamList
(name
,lenname
,pure
) ->
1489 failwith
"meta_param_list in iso not supported"
1490 (*match lookup name bindings mv_bindings with
1491 Common.Left(Ast0.DotsParamTag(param)) ->
1492 (match same_dots param with
1494 | None -> failwith "dots put in incompatible context")
1495 | Common.Left(Ast0.ParamTag(param)) -> [param]
1496 | Common.Left(_) -> failwith "not possible 1"
1497 | Common.Right(new_mv) ->
1498 failwith "MetaExprList in SP not supported"*)
1499 | _
-> [r
.VT0.rebuilder_rec_parameter
x])
1500 | x::xs
-> (r
.VT0.rebuilder_rec_parameter
x)::(plist r same_dots xs
) in
1502 let rec slist r same_dots
= function
1505 (match Ast0.unwrap
x with
1506 Ast0.MetaStmtList
(name
,pure
) ->
1507 (match lookup name bindings mv_bindings
with
1508 Common.Left
(Ast0.DotsStmtTag
(stm
)) ->
1509 (match same_dots stm
with
1511 | None
-> failwith
"dots put in incompatible context")
1512 | Common.Left
(Ast0.StmtTag
(stm
)) -> [stm
]
1513 | Common.Left
(_
) -> failwith
"not possible 1"
1514 | Common.Right
(new_mv
) ->
1515 failwith
"MetaExprList in SP not supported")
1516 | _
-> [r
.VT0.rebuilder_rec_statement
x])
1517 | x::xs
-> (r
.VT0.rebuilder_rec_statement
x)::(slist r same_dots xs
) in
1520 match Ast0.unwrap d
with Ast0.DOTS
(l
) -> Some l
|_
-> None
in
1521 let same_circles d
=
1522 match Ast0.unwrap d
with Ast0.CIRCLES
(l
) -> Some l
|_
-> None
in
1524 match Ast0.unwrap d
with Ast0.STARS
(l
) -> Some l
|_
-> None
in
1526 let dots list_fn r k d
=
1528 (match Ast0.unwrap d
with
1529 Ast0.DOTS
(l
) -> Ast0.DOTS
(list_fn r
same_dots l
)
1530 | Ast0.CIRCLES
(l
) -> Ast0.CIRCLES
(list_fn r
same_circles l
)
1531 | Ast0.STARS
(l
) -> Ast0.STARS
(list_fn r
same_stars l
)) in
1533 let exprfn r k old_e
= (* need to keep the original code for ! optim *)
1536 match Ast0.unwrap
e with
1537 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) ->
1538 (rebuild_mcode None
).VT0.rebuilder_rec_expression
1539 (match lookup name bindings mv_bindings
with
1540 Common.Left
(Ast0.ExprTag
(exp
)) -> exp
1541 | Common.Left
(_
) -> failwith
"not possible 1"
1542 | Common.Right
(new_mv
) ->
1547 let rec renamer = function
1548 Type_cocci.MetaType
(name
,keep
,inherited
) ->
1550 lookup (name
,(),(),(),None
,-1) bindings mv_bindings
1552 Common.Left
(Ast0.TypeCTag
(t
)) ->
1553 Ast0.ast0_type_to_type t
1555 failwith
"iso pattern: unexpected type"
1556 | Common.Right
(new_mv
) ->
1557 Type_cocci.MetaType
(new_mv
,keep
,inherited
))
1558 | Type_cocci.ConstVol
(cv
,ty
) ->
1559 Type_cocci.ConstVol
(cv
,renamer ty
)
1560 | Type_cocci.Pointer
(ty
) ->
1561 Type_cocci.Pointer
(renamer ty
)
1562 | Type_cocci.FunctionPointer
(ty
) ->
1563 Type_cocci.FunctionPointer
(renamer ty
)
1564 | Type_cocci.Array
(ty
) ->
1565 Type_cocci.Array
(renamer ty
)
1567 Some
(List.map
renamer types
) in
1570 (Ast0.set_mcode_data new_mv name
,constraints
,
1571 new_types,form
,pure
)))
1572 | Ast0.MetaErr
(namea
,_
,pure
) -> failwith
"metaerr not supported"
1573 | Ast0.MetaExprList
(namea
,lenname
,pure
) ->
1574 failwith
"metaexprlist not supported"
1575 | Ast0.Unary
(exp
,unop
) ->
1576 (match Ast0.unwrap_mcode unop
with
1577 (* propagate negation only when the propagated and the encountered
1578 negation have the same transformation, when there is nothing
1579 added to the original one, and when there is nothing added to
1580 the expression into which we are doing the propagation. This
1581 may be too conservative. *)
1584 (* k e doesn't change the outer structure of the term,
1585 only the metavars *)
1586 match Ast0.unwrap old_e
with
1587 Ast0.Unary
(exp
,_
) ->
1588 (match Ast0.unwrap exp
with
1589 Ast0.MetaExpr
(name
,constraints
,x,form
,pure
) -> true
1591 | _
-> failwith
"not possible" in
1592 let nomodif = function
1597 | Ast0.CONTEXT
(x) | Ast0.MIXED
(x) ->
1599 (Ast.NOTHING
,_
,_
) -> true
1601 | _
-> failwith
"plus not possible" in
1602 let same_modif newop oldop
=
1603 (* only propagate ! is they have the same modification
1604 and no + code on the old one (the new one from the iso
1605 surely has no + code) *)
1606 match (newop
,oldop
) with
1607 (Ast0.MINUS
(x1
),Ast0.MINUS
(x2
)) -> nomodif oldop
1608 | (Ast0.CONTEXT
(x1
),Ast0.CONTEXT
(x2
)) -> nomodif oldop
1609 | (Ast0.MIXED
(x1
),Ast0.MIXED
(x2
)) -> nomodif oldop
1614 let rec negate e (*for rewrapping*) res (*code to process*) k
=
1615 (* k accumulates parens, to keep negation outside if no
1616 propagation is possible *)
1617 if nomodif (Ast0.get_mcodekind
e)
1619 match Ast0.unwrap
res with
1620 Ast0.Unary
(e1,op
) when Ast0.unwrap_mcode op
= Ast.Not
&&
1622 (Ast0.get_mcode_mcodekind unop
)
1623 (Ast0.get_mcode_mcodekind op
) ->
1625 | Ast0.Edots
(_
,_
) -> k
(Ast0.rewrap
e (Ast0.unwrap
res))
1626 | Ast0.Paren
(lp
,e1,rp
) ->
1629 k
(Ast0.rewrap
res (Ast0.Paren
(lp
,x,rp
))))
1630 | Ast0.Binary
(e1,op
,e2
) when
1632 (Ast0.get_mcode_mcodekind unop
)
1633 (Ast0.get_mcode_mcodekind op
)->
1635 Ast0.rewrap_mcode op
(Ast.Logical
(nop
)) in
1636 let k1 x = k
(Ast0.rewrap
e x) in
1637 (match Ast0.unwrap_mcode op
with
1638 Ast.Logical
(Ast.Inf
) ->
1639 k1 (Ast0.Binary
(e1,reb Ast.SupEq
,e2
))
1640 | Ast.Logical
(Ast.Sup
) ->
1641 k1 (Ast0.Binary
(e1,reb Ast.InfEq
,e2
))
1642 | Ast.Logical
(Ast.InfEq
) ->
1643 k1 (Ast0.Binary
(e1,reb Ast.Sup
,e2
))
1644 | Ast.Logical
(Ast.SupEq
) ->
1645 k1 (Ast0.Binary
(e1,reb Ast.Inf
,e2
))
1646 | Ast.Logical
(Ast.Eq
) ->
1647 k1 (Ast0.Binary
(e1,reb Ast.NotEq
,e2
))
1648 | Ast.Logical
(Ast.NotEq
) ->
1649 k1 (Ast0.Binary
(e1,reb Ast.Eq
,e2
))
1650 | Ast.Logical
(Ast.AndLog
) ->
1651 k1 (Ast0.Binary
(negate e1 e1 idcont,
1653 negate e2 e2
idcont))
1654 | Ast.Logical
(Ast.OrLog
) ->
1655 k1 (Ast0.Binary
(negate e1 e1 idcont,
1657 negate e2 e2
idcont))
1661 Ast0.rewrap_mcode op
Ast.Not
)))
1662 | Ast0.DisjExpr
(lp
,exps
,mids
,rp
) ->
1663 (* use res because it is the transformed argument *)
1664 let exps = List.map
(function e -> negate e e k
) exps in
1665 Ast0.rewrap
res (Ast0.DisjExpr
(lp
,exps,mids
,rp
))
1667 (*use e, because this might be the toplevel expression*)
1669 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
))
1672 (Ast0.Unary
(k
res,Ast0.rewrap_mcode unop
Ast.Not
)) in
1676 | Ast0.Edots
(d
,_
) ->
1678 (match List.assoc
(dot_term d
) bindings
with
1679 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Edots
(d
,Some exp
))
1680 | _
-> failwith
"unexpected binding")
1681 with Not_found
-> e)
1682 | Ast0.Ecircles
(d
,_
) ->
1684 (match List.assoc
(dot_term d
) bindings
with
1685 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Ecircles
(d
,Some exp
))
1686 | _
-> failwith
"unexpected binding")
1687 with Not_found
-> e)
1688 | Ast0.Estars
(d
,_
) ->
1690 (match List.assoc
(dot_term d
) bindings
with
1691 Ast0.ExprTag
(exp
) -> Ast0.rewrap
e (Ast0.Estars
(d
,Some exp
))
1692 | _
-> failwith
"unexpected binding")
1693 with Not_found
-> e)
1695 if Ast0.get_test_exp old_e
then Ast0.set_test_exp
e1 else e1 in
1699 match Ast0.unwrap
e with
1700 Ast0.MetaType
(name
,pure
) ->
1701 (rebuild_mcode None
).VT0.rebuilder_rec_typeC
1702 (match lookup name bindings mv_bindings
with
1703 Common.Left
(Ast0.TypeCTag
(ty
)) -> ty
1704 | Common.Left
(_
) -> failwith
"not possible 1"
1705 | Common.Right
(new_mv
) ->
1707 (Ast0.MetaType
(Ast0.set_mcode_data new_mv name
,pure
)))
1712 match Ast0.unwrap
e with
1713 Ast0.MetaInit
(name
,pure
) ->
1714 (rebuild_mcode None
).VT0.rebuilder_rec_initialiser
1715 (match lookup name bindings mv_bindings
with
1716 Common.Left
(Ast0.InitTag
(ty
)) -> ty
1717 | Common.Left
(_
) -> failwith
"not possible 1"
1718 | Common.Right
(new_mv
) ->
1720 (Ast0.MetaInit
(Ast0.set_mcode_data new_mv name
,pure
)))
1725 match Ast0.unwrap
e with
1728 (match List.assoc
(dot_term d
) bindings
with
1729 Ast0.DeclTag
(exp
) -> Ast0.rewrap
e (Ast0.Ddots
(d
,Some exp
))
1730 | _
-> failwith
"unexpected binding")
1731 with Not_found
-> e)
1736 match Ast0.unwrap
e with
1737 Ast0.MetaParam
(name
,pure
) ->
1738 (rebuild_mcode None
).VT0.rebuilder_rec_parameter
1739 (match lookup name bindings mv_bindings
with
1740 Common.Left
(Ast0.ParamTag
(param)) -> param
1741 | Common.Left
(_
) -> failwith
"not possible 1"
1742 | Common.Right
(new_mv
) ->
1744 (Ast0.MetaParam
(Ast0.set_mcode_data new_mv name
, pure
)))
1745 | Ast0.MetaParamList
(name
,lenname
,pure
) ->
1746 failwith
"metaparamlist not supported"
1751 Ast0.DotsStmtTag
(stms
) -> Ast0.WhenNot stms
1752 | Ast0.StmtTag
(stm
) -> Ast0.WhenAlways stm
1753 | Ast0.IsoWhenTTag
(stm
) -> Ast0.WhenNotTrue stm
1754 | Ast0.IsoWhenFTag
(stm
) -> Ast0.WhenNotFalse stm
1755 | Ast0.IsoWhenTag
(x) -> Ast0.WhenModifier
(x)
1756 | _
-> failwith
"unexpected binding" in
1760 match Ast0.unwrap
e with
1761 Ast0.MetaStmt
(name
,pure
) ->
1762 (rebuild_mcode None
).VT0.rebuilder_rec_statement
1763 (match lookup name bindings mv_bindings
with
1764 Common.Left
(Ast0.StmtTag
(stm
)) -> stm
1765 | Common.Left
(_
) -> failwith
"not possible 1"
1766 | Common.Right
(new_mv
) ->
1768 (Ast0.MetaStmt
(Ast0.set_mcode_data new_mv name
,pure
)))
1769 | Ast0.MetaStmtList
(name
,pure
) -> failwith
"metastmtlist not supported"
1775 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1776 | Ast0.Circles
(d
,_
) ->
1781 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1782 | Ast0.Stars
(d
,_
) ->
1787 (List.filter
(function (x,v
) -> x = (dot_term d
)) bindings
)))
1791 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1792 (dots elist) donothing (dots plist) (dots slist) donothing donothing
1793 identfn exprfn tyfn initfn paramfn declfn stmtfn donothing donothing
1795 (* --------------------------------------------------------------------- *)
1798 match Ast0.get_mcodekind
e with Ast0.MINUS
(cell
) -> true | _
-> false
1800 let context_required e = not
(is_minus e) && not
!Flag.sgrep_mode2
1802 let disj_fail bindings
e =
1804 Some
x -> Printf.fprintf stderr
"no disj available at this type"; e
1807 (* isomorphism code is by default CONTEXT *)
1808 let merge_plus model_mcode e_mcode
=
1809 match model_mcode
with
1811 (* add the replacement information at the root *)
1815 (match (!mc
,!emc
) with
1816 (([],_
),(x,t
)) | ((x,_
),([],t
)) -> (x,t
)
1817 | _
-> failwith
"how can we combine minuses?")
1818 | _
-> failwith
"not possible 6")
1819 | Ast0.CONTEXT
(mc
) ->
1821 Ast0.CONTEXT
(emc
) ->
1822 (* keep the logical line info as in the model *)
1823 let (mba
,tb
,ta
) = !mc
in
1824 let (eba
,_
,_
) = !emc
in
1825 (* merging may be required when a term is replaced by a subterm *)
1827 match (mba
,eba
) with
1828 (x,Ast.NOTHING
) | (Ast.NOTHING
,x) -> x
1829 | (Ast.BEFORE
(b1
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1830 Ast.BEFORE
(b1
@b2
,Ast.lub_count it1 it2
)
1831 | (Ast.BEFORE
(b
,it1
),Ast.AFTER
(a
,it2
)) ->
1832 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1833 | (Ast.BEFORE
(b1
,it1
),Ast.BEFOREAFTER
(b2
,a
,it2
)) ->
1834 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1835 | (Ast.AFTER
(a
,it1
),Ast.BEFORE
(b
,it2
)) ->
1836 Ast.BEFOREAFTER
(b
,a
,Ast.lub_count it1 it2
)
1837 | (Ast.AFTER
(a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1838 Ast.AFTER
(a2
@a1
,Ast.lub_count it1 it2
)
1839 | (Ast.AFTER
(a1
,it1
),Ast.BEFOREAFTER
(b
,a2
,it2
)) ->
1840 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1841 | (Ast.BEFOREAFTER
(b1
,a
,it1
),Ast.BEFORE
(b2
,it2
)) ->
1842 Ast.BEFOREAFTER
(b1
@b2
,a
,Ast.lub_count it1 it2
)
1843 | (Ast.BEFOREAFTER
(b
,a1
,it1
),Ast.AFTER
(a2
,it2
)) ->
1844 Ast.BEFOREAFTER
(b
,a2
@a1
,Ast.lub_count it1 it2
)
1845 | (Ast.BEFOREAFTER
(b1
,a1
,it1
),Ast.BEFOREAFTER
(b2
,a2
,it2
)) ->
1846 Ast.BEFOREAFTER
(b1
@b2
,a2
@a1
,Ast.lub_count it1 it2
) in
1847 emc
:= (merged,tb
,ta
)
1848 | Ast0.MINUS
(emc
) ->
1849 let (anything_bef_aft
,_
,_
) = !mc
in
1850 let (anythings
,t
) = !emc
in
1852 (match anything_bef_aft
with
1853 Ast.BEFORE
(b
,_
) -> (b
@anythings
,t
)
1854 | Ast.AFTER
(a
,_
) -> (anythings
@a
,t
)
1855 | Ast.BEFOREAFTER
(b
,a
,_
) -> (b
@anythings
@a
,t
)
1856 | Ast.NOTHING
-> (anythings
,t
))
1857 | Ast0.MIXED
(_
) -> failwith
"how did this become mixed?"
1858 | _
-> failwith
"not possible 7")
1859 | Ast0.MIXED
(_
) -> failwith
"not possible 8"
1860 | Ast0.PLUS _
-> failwith
"not possible 9"
1862 let copy_plus printer minusify model
e =
1863 if !Flag.sgrep_mode2
1864 then e (* no plus code, can cause a "not possible" error, so just avoid it *)
1867 match Ast0.get_mcodekind model
with
1868 Ast0.MINUS
(mc
) -> minusify
e
1869 | Ast0.CONTEXT
(mc
) -> e
1870 | _
-> failwith
"not possible: copy_plus\n" in
1871 merge_plus (Ast0.get_mcodekind model
) (Ast0.get_mcodekind
e);
1874 let copy_minus printer minusify model
e =
1875 match Ast0.get_mcodekind model
with
1876 Ast0.MINUS
(mc
) -> minusify
e
1877 | Ast0.CONTEXT
(mc
) -> e
1879 if !Flag.sgrep_mode2
1881 else failwith
"not possible 8"
1882 | Ast0.PLUS _
-> failwith
"not possible 9"
1884 let whencode_allowed prev_ecount prev_icount prev_dcount
1885 ecount icount dcount rest
=
1886 (* actually, if ecount or dcount is 0, the flag doesn't matter, because it
1888 let other_ecount = (* number of edots *)
1889 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ec
+ rest
)
1891 let other_icount = (* number of dots *)
1892 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> ic
+ rest
)
1894 let other_dcount = (* number of dots *)
1895 List.fold_left
(function rest
-> function (_
,ec
,ic
,dc
) -> dc
+ rest
)
1897 (ecount
= 0 or other_ecount = 0, icount
= 0 or other_icount = 0,
1898 dcount
= 0 or other_dcount = 0)
1900 (* copy the befores and afters to the instantiated code *)
1901 let extra_copy_stmt_plus model
e =
1902 (if not
!Flag.sgrep_mode2
(* sgrep has no plus code, so nothing to do *)
1904 (match Ast0.unwrap model
with
1905 Ast0.FunDecl
((info,bef
),_
,_
,_
,_
,_
,_
,_
,_
)
1906 | Ast0.Decl
((info,bef
),_
) ->
1907 (match Ast0.unwrap
e with
1908 Ast0.FunDecl
((info,bef1
),_
,_
,_
,_
,_
,_
,_
,_
)
1909 | Ast0.Decl
((info,bef1
),_
) ->
1911 | _
-> merge_plus bef
(Ast0.get_mcodekind
e))
1912 | Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft
))
1913 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1914 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft
))
1915 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft
))
1916 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft
)) ->
1917 (match Ast0.unwrap
e with
1918 Ast0.IfThen
(_
,_
,_
,_
,_
,(info,aft1
))
1919 | Ast0.IfThenElse
(_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1920 | Ast0.While
(_
,_
,_
,_
,_
,(info,aft1
))
1921 | Ast0.For
(_
,_
,_
,_
,_
,_
,_
,_
,_
,(info,aft1
))
1922 | Ast0.Iterator
(_
,_
,_
,_
,_
,(info,aft1
)) ->
1924 | _
-> merge_plus aft
(Ast0.get_mcodekind
e))
1928 let extra_copy_other_plus model
e = e
1930 (* --------------------------------------------------------------------- *)
1932 let mv_count = ref 0
1934 let ct = !mv_count in
1935 mv_count := !mv_count + 1;
1936 "_"^
s^
"_"^
(string_of_int
ct)
1938 let get_name = function
1939 Ast.MetaIdDecl
(ar
,nm
) ->
1940 (nm
,function nm
-> Ast.MetaIdDecl
(ar
,nm
))
1941 | Ast.MetaFreshIdDecl
(nm
,seed
) ->
1942 (nm
,function nm
-> Ast.MetaFreshIdDecl
(nm
,seed
))
1943 | Ast.MetaTypeDecl
(ar
,nm
) ->
1944 (nm
,function nm
-> Ast.MetaTypeDecl
(ar
,nm
))
1945 | Ast.MetaInitDecl
(ar
,nm
) ->
1946 (nm
,function nm
-> Ast.MetaInitDecl
(ar
,nm
))
1947 | Ast.MetaListlenDecl
(nm
) ->
1948 failwith
"should not be rebuilt"
1949 | Ast.MetaParamDecl
(ar
,nm
) ->
1950 (nm
,function nm
-> Ast.MetaParamDecl
(ar
,nm
))
1951 | Ast.MetaParamListDecl
(ar
,nm
,nm1
) ->
1952 (nm
,function nm
-> Ast.MetaParamListDecl
(ar
,nm
,nm1
))
1953 | Ast.MetaConstDecl
(ar
,nm
,ty
) ->
1954 (nm
,function nm
-> Ast.MetaConstDecl
(ar
,nm
,ty
))
1955 | Ast.MetaErrDecl
(ar
,nm
) ->
1956 (nm
,function nm
-> Ast.MetaErrDecl
(ar
,nm
))
1957 | Ast.MetaExpDecl
(ar
,nm
,ty
) ->
1958 (nm
,function nm
-> Ast.MetaExpDecl
(ar
,nm
,ty
))
1959 | Ast.MetaIdExpDecl
(ar
,nm
,ty
) ->
1960 (nm
,function nm
-> Ast.MetaIdExpDecl
(ar
,nm
,ty
))
1961 | Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
) ->
1962 (nm
,function nm
-> Ast.MetaLocalIdExpDecl
(ar
,nm
,ty
))
1963 | Ast.MetaExpListDecl
(ar
,nm
,nm1
) ->
1964 (nm
,function nm
-> Ast.MetaExpListDecl
(ar
,nm
,nm1
))
1965 | Ast.MetaStmDecl
(ar
,nm
) ->
1966 (nm
,function nm
-> Ast.MetaStmDecl
(ar
,nm
))
1967 | Ast.MetaStmListDecl
(ar
,nm
) ->
1968 (nm
,function nm
-> Ast.MetaStmListDecl
(ar
,nm
))
1969 | Ast.MetaFuncDecl
(ar
,nm
) ->
1970 (nm
,function nm
-> Ast.MetaFuncDecl
(ar
,nm
))
1971 | Ast.MetaLocalFuncDecl
(ar
,nm
) ->
1972 (nm
,function nm
-> Ast.MetaLocalFuncDecl
(ar
,nm
))
1973 | Ast.MetaPosDecl
(ar
,nm
) ->
1974 (nm
,function nm
-> Ast.MetaPosDecl
(ar
,nm
))
1975 | Ast.MetaDeclarerDecl
(ar
,nm
) ->
1976 (nm
,function nm
-> Ast.MetaDeclarerDecl
(ar
,nm
))
1977 | Ast.MetaIteratorDecl
(ar
,nm
) ->
1978 (nm
,function nm
-> Ast.MetaIteratorDecl
(ar
,nm
))
1980 let make_new_metavars metavars bindings
=
1984 let (s,_
) = get_name mv
in
1985 try let _ = List.assoc
s bindings
in false with Not_found
-> true)
1990 let (s,rebuild
) = get_name mv
in
1991 let new_s = (!current_rule,new_mv s) in
1992 (rebuild
new_s, (s,new_s)))
1995 (* --------------------------------------------------------------------- *)
1997 let do_nothing x = x
1999 let mkdisj matcher metavars alts
e instantiater mkiso disj_maker minusify
2000 rebuild_mcodes name printer extra_plus update_others
=
2001 let call_instantiate bindings mv_bindings alts
=
2004 (function (a
,_,_,_) ->
2006 (* no need to create duplicates when the bindings have no effect *)
2008 (function bindings
->
2010 (copy_plus printer minusify
e
2012 (instantiater bindings mv_bindings
2013 (rebuild_mcodes a
))))
2014 ((name
,mkiso a
)::(Ast0.get_iso
e))) (* keep count, not U *)
2017 let rec inner_loop all_alts prev_ecount prev_icount prev_dcount
= function
2018 [] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2019 | ((pattern
,ecount
,icount
,dcount
)::rest
) ->
2021 whencode_allowed prev_ecount prev_icount prev_dcount
2022 ecount dcount icount rest
in
2023 (match matcher
true (context_required e) wc pattern
e init_env with
2025 if reason
= NonMatch
|| not
!Flag_parsing_cocci.show_iso_failures
2028 (match matcher
false false wc pattern
e init_env with
2030 interpret_reason name
(Ast0.get_line
e) reason
2031 (function () -> printer
e)
2033 inner_loop all_alts
(prev_ecount
+ ecount
) (prev_icount
+ icount
)
2034 (prev_dcount
+ dcount
) rest
2035 | OK
(bindings
: (((string * string) * 'a
) list list
)) ->
2037 (* apply update_others to all patterns other than the matched
2038 one. This is used to desigate the others as test
2039 expressions in the TestExpression case *)
2041 (function (x,e,i
,d
) as all
->
2044 else (update_others
x,e,i
,d
))
2045 (List.hd
all_alts)) ::
2047 (List.map
(function (x,e,i
,d
) -> (update_others
x,e,i
,d
)))
2048 (List.tl
all_alts)) in
2049 (match List.concat
all_alts with
2050 [x] -> Common.Left
(prev_ecount
, prev_icount
, prev_dcount
)
2052 let (new_metavars,mv_bindings
) =
2053 make_new_metavars metavars
(nub(List.concat bindings
)) in
2056 call_instantiate bindings mv_bindings
all_alts))) in
2057 let rec outer_loop prev_ecount prev_icount prev_dcount
= function
2058 [] | [[_]] (*only one alternative*) -> (0,[],e) (* nothing matched *)
2059 | (alts
::rest
) as all_alts ->
2060 match inner_loop all_alts prev_ecount prev_icount prev_dcount alts
with
2061 Common.Left
(prev_ecount
, prev_icount
, prev_dcount
) ->
2062 outer_loop prev_ecount prev_icount prev_dcount rest
2063 | Common.Right
(new_metavars,res) ->
2065 copy_minus printer minusify
e (disj_maker
res)) in
2066 let (count
,metavars
,e) = outer_loop 0 0 0 alts
in
2067 (count
, metavars
, e)
2069 (* no one should ever look at the information stored in these mcodes *)
2070 let disj_starter lst
=
2071 let old_info = Ast0.get_info
(List.hd lst
) in
2073 { old_info.Ast0.pos_info
with
2074 Ast0.line_end
= old_info.Ast0.pos_info
.Ast0.line_start
;
2075 Ast0.logical_end
= old_info.Ast0.pos_info
.Ast0.logical_start
; } in
2077 { Ast0.pos_info
= new_pos_info;
2078 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2079 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2080 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2081 Ast0.make_mcode_info
"(" info
2083 let disj_ender lst
=
2084 let old_info = Ast0.get_info
(List.hd lst
) in
2086 { old_info.Ast0.pos_info
with
2087 Ast0.line_start
= old_info.Ast0.pos_info
.Ast0.line_end
;
2088 Ast0.logical_start
= old_info.Ast0.pos_info
.Ast0.logical_end
; } in
2090 { Ast0.pos_info
= new_pos_info;
2091 Ast0.attachable_start
= false; Ast0.attachable_end
= false;
2092 Ast0.mcode_start
= []; Ast0.mcode_end
= [];
2093 Ast0.strings_before
= []; Ast0.strings_after
= [] } in
2094 Ast0.make_mcode_info
")" info
2096 let disj_mid _ = Ast0.make_mcode
"|"
2098 let make_disj_type tl
=
2101 [] -> failwith
"bad disjunction"
2102 | x::xs
-> List.map
disj_mid xs
in
2103 Ast0.context_wrap
(Ast0.DisjType
(disj_starter tl
,tl
,mids,disj_ender tl
))
2104 let make_disj_stmt_list tl
=
2107 [] -> failwith
"bad disjunction"
2108 | x::xs
-> List.map
disj_mid xs
in
2109 Ast0.context_wrap
(Ast0.Disj
(disj_starter tl
,tl
,mids,disj_ender tl
))
2110 let make_disj_expr model el
=
2113 [] -> failwith
"bad disjunction"
2114 | x::xs
-> List.map
disj_mid xs
in
2116 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
x else x in
2118 let x = if Ast0.get_test_pos model
then Ast0.set_test_pos
x else x in
2119 if Ast0.get_test_exp model
then Ast0.set_test_exp
x else x in
2120 let el = List.map
update_arg (List.map
update_test el) in
2121 Ast0.context_wrap
(Ast0.DisjExpr
(disj_starter el,el,mids,disj_ender el))
2122 let make_disj_decl dl
=
2125 [] -> failwith
"bad disjunction"
2126 | x::xs
-> List.map
disj_mid xs
in
2127 Ast0.context_wrap
(Ast0.DisjDecl
(disj_starter dl
,dl
,mids,disj_ender dl
))
2128 let make_disj_stmt sl
=
2129 let dotify x = Ast0.context_wrap
(Ast0.DOTS
[x]) in
2132 [] -> failwith
"bad disjunction"
2133 | x::xs
-> List.map
disj_mid xs
in
2135 (Ast0.Disj
(disj_starter sl
,List.map
dotify sl
,mids,disj_ender sl
))
2137 let transform_type (metavars
,alts
,name
) e =
2139 (Ast0.TypeCTag
(_)::_)::_ ->
2140 (* start line is given to any leaves in the iso code *)
2142 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2148 (p
,count_edots.VT0.combiner_rec_typeC p
,
2149 count_idots.VT0.combiner_rec_typeC p
,
2150 count_dots.VT0.combiner_rec_typeC p
)
2151 | _ -> failwith
"invalid alt"))
2153 mkdisj match_typeC metavars
alts e
2154 (function b
-> function mv_b
->
2155 (instantiate b mv_b
).VT0.rebuilder_rec_typeC
)
2156 (function t
-> Ast0.TypeCTag t
)
2157 make_disj_type make_minus.VT0.rebuilder_rec_typeC
2158 (rebuild_mcode start_line).VT0.rebuilder_rec_typeC
2159 name
Unparse_ast0.typeC extra_copy_other_plus do_nothing
2163 let transform_expr (metavars
,alts,name
) e =
2164 let process update_others
=
2165 (* start line is given to any leaves in the iso code *)
2167 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2172 Ast0.ExprTag
(p
) | Ast0.ArgExprTag
(p
) | Ast0.TestExprTag
(p
) ->
2173 (p
,count_edots.VT0.combiner_rec_expression p
,
2174 count_idots.VT0.combiner_rec_expression p
,
2175 count_dots.VT0.combiner_rec_expression p
)
2176 | _ -> failwith
"invalid alt"))
2178 mkdisj match_expr metavars
alts e
2179 (function b
-> function mv_b
->
2180 (instantiate b mv_b
).VT0.rebuilder_rec_expression
)
2181 (function e -> Ast0.ExprTag
e)
2183 make_minus.VT0.rebuilder_rec_expression
2184 (rebuild_mcode start_line).VT0.rebuilder_rec_expression
2185 name
Unparse_ast0.expression extra_copy_other_plus update_others
in
2186 let set_property model
e =
2187 let e = if Ast0.get_test_pos model
then Ast0.set_test_exp
e else e in
2188 if Ast0.get_arg_exp model
then Ast0.set_arg_exp
e else e in
2190 (Ast0.ExprTag
(_)::_)::_ ->
2191 process (set_property e)
2192 | (Ast0.ArgExprTag
(_)::_)::_ when Ast0.get_arg_exp
e ->
2193 process (set_property e)
2194 | (Ast0.TestExprTag
(_)::_)::_ when Ast0.get_test_pos
e ->
2195 process (set_property e)
2198 let transform_decl (metavars
,alts,name
) e =
2200 (Ast0.DeclTag
(_)::_)::_ ->
2201 (* start line is given to any leaves in the iso code *)
2203 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2209 (p
,count_edots.VT0.combiner_rec_declaration p
,
2210 count_idots.VT0.combiner_rec_declaration p
,
2211 count_dots.VT0.combiner_rec_declaration p
)
2212 | _ -> failwith
"invalid alt"))
2214 mkdisj match_decl metavars
alts e
2215 (function b
-> function mv_b
->
2216 (instantiate b mv_b
).VT0.rebuilder_rec_declaration
)
2217 (function d
-> Ast0.DeclTag d
)
2219 make_minus.VT0.rebuilder_rec_declaration
2220 (rebuild_mcode start_line).VT0.rebuilder_rec_declaration
2221 name
Unparse_ast0.declaration extra_copy_other_plus do_nothing
2224 let transform_stmt (metavars
,alts,name
) e =
2226 (Ast0.StmtTag
(_)::_)::_ ->
2227 (* start line is given to any leaves in the iso code *)
2229 Some
(Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
in
2235 (p
,count_edots.VT0.combiner_rec_statement p
,
2236 count_idots.VT0.combiner_rec_statement p
,
2237 count_dots.VT0.combiner_rec_statement p
)
2238 | _ -> failwith
"invalid alt"))
2240 mkdisj match_statement metavars
alts e
2241 (function b
-> function mv_b
->
2242 (instantiate b mv_b
).VT0.rebuilder_rec_statement
)
2243 (function s -> Ast0.StmtTag
s)
2244 make_disj_stmt make_minus.VT0.rebuilder_rec_statement
2245 (rebuild_mcode start_line).VT0.rebuilder_rec_statement
2246 name
(Unparse_ast0.statement "") extra_copy_stmt_plus do_nothing
2249 (* sort of a hack, because there is no disj at top level *)
2250 let transform_top (metavars
,alts,name
) e =
2251 match Ast0.unwrap
e with
2252 Ast0.DECL
(declstm
) ->
2258 Ast0.DotsStmtTag
(d
) ->
2259 (match Ast0.unwrap d
with
2260 Ast0.DOTS
([s]) -> Ast0.StmtTag
(s)
2261 | _ -> raise
(Failure
""))
2262 | _ -> raise
(Failure
"")))
2264 let (count
,mv
,s) = transform_stmt (metavars
,strip alts,name
) declstm
in
2265 (count
,mv
,Ast0.rewrap
e (Ast0.DECL
(s)))
2266 with Failure
_ -> (0,[],e))
2267 | Ast0.CODE
(stmts
) ->
2268 let (count
,mv
,res) =
2270 (Ast0.DotsStmtTag
(_)::_)::_ ->
2271 (* start line is given to any leaves in the iso code *)
2273 Some
((Ast0.get_info
e).Ast0.pos_info
.Ast0.line_start
) in
2278 Ast0.DotsStmtTag
(p
) ->
2279 (p
,count_edots.VT0.combiner_rec_statement_dots p
,
2280 count_idots.VT0.combiner_rec_statement_dots p
,
2281 count_dots.VT0.combiner_rec_statement_dots p
)
2282 | _ -> failwith
"invalid alt"))
2284 mkdisj match_statement_dots metavars
alts stmts
2285 (function b
-> function mv_b
->
2286 (instantiate b mv_b
).VT0.rebuilder_rec_statement_dots
)
2287 (function s -> Ast0.DotsStmtTag
s)
2289 Ast0.rewrap
e (Ast0.DOTS
([make_disj_stmt_list x])))
2291 make_minus.VT0.rebuilder_rec_statement_dots
x)
2292 (rebuild_mcode start_line).VT0.rebuilder_rec_statement_dots
2293 name
Unparse_ast0.statement_dots
extra_copy_other_plus do_nothing
2294 | _ -> (0,[],stmts
) in
2295 (count
,mv
,Ast0.rewrap
e (Ast0.CODE
res))
2298 (* --------------------------------------------------------------------- *)
2300 let transform (alts : isomorphism
) t
=
2301 (* the following ugliness is because rebuilder only returns a new term *)
2302 let extra_meta_decls = ref ([] : Ast_cocci.metavar list
) in
2303 let in_limit n
= function
2307 ((if !Flag_parsing_cocci.show_iso_failures
2308 then Common.pr2_once
"execeeded iso threshold, see -iso_limit option");
2310 let bind x y
= x + y
in
2311 let option_default = 0 in
2313 let (e_count
,e) = k
e in
2314 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2316 let (count
,extra_meta
,exp
) = transform_expr alts e in
2317 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2318 (bind count e_count
,exp
)
2322 let (e_count
,e) = k
e in
2323 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2325 let (count
,extra_meta
,dec
) = transform_decl alts e in
2326 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2327 (bind count e_count
,dec
)
2331 let (e_count
,e) = k
e in
2332 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2334 let (count
,extra_meta
,stm
) = transform_stmt alts e in
2335 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2336 (bind count e_count
,stm
)
2340 let (continue
,e_count
,e) =
2341 match Ast0.unwrap
e with
2342 Ast0.Signed
(signb
,tyb
) ->
2343 (* Hack! How else to prevent iso from applying under an
2347 let (e_count
,e) = k
e in
2348 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2349 then (true,e_count
,e)
2350 else (false,e_count
,e) in
2353 let (count
,extra_meta
,ty
) = transform_type alts e in
2354 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2355 (bind count e_count
,ty
)
2359 let (e_count
,e) = k
e in
2360 if in_limit e_count
!Flag_parsing_cocci.iso_limit
2362 let (count
,extra_meta
,ty
) = transform_top alts e in
2363 extra_meta_decls := extra_meta
@ !extra_meta_decls;
2364 (bind count e_count
,ty
)
2368 V0.combiner_rebuilder
bind option_default
2369 {V0.combiner_rebuilder_functions
with
2370 VT0.combiner_rebuilder_exprfn
= exprfn;
2371 VT0.combiner_rebuilder_tyfn
= typefn;
2372 VT0.combiner_rebuilder_declfn
= declfn;
2373 VT0.combiner_rebuilder_stmtfn
= stmtfn;
2374 VT0.combiner_rebuilder_topfn
= topfn} in
2375 let (_,res) = res.VT0.top_level t
in
2376 (!extra_meta_decls,res)
2378 (* --------------------------------------------------------------------- *)
2380 (* should be done by functorizing the parser to use wrap or context_wrap *)
2382 let mcode (x,a
,i
,mc
,pos
,adj
) = (x,a
,i
,Ast0.context_befaft
(),pos
,adj
) in
2383 let donothing r k
e = Ast0.context_wrap
(Ast0.unwrap
(k
e)) in
2385 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
2386 donothing donothing donothing donothing donothing donothing
2387 donothing donothing donothing donothing donothing donothing donothing
2390 let rewrap_anything = function
2391 Ast0.DotsExprTag
(d
) ->
2392 Ast0.DotsExprTag
(rewrap.VT0.rebuilder_rec_expression_dots d
)
2393 | Ast0.DotsInitTag
(d
) ->
2394 Ast0.DotsInitTag
(rewrap.VT0.rebuilder_rec_initialiser_list d
)
2395 | Ast0.DotsParamTag
(d
) ->
2396 Ast0.DotsParamTag
(rewrap.VT0.rebuilder_rec_parameter_list d
)
2397 | Ast0.DotsStmtTag
(d
) ->
2398 Ast0.DotsStmtTag
(rewrap.VT0.rebuilder_rec_statement_dots d
)
2399 | Ast0.DotsDeclTag
(d
) ->
2400 Ast0.DotsDeclTag
(rewrap.VT0.rebuilder_rec_declaration_dots d
)
2401 | Ast0.DotsCaseTag
(d
) ->
2402 Ast0.DotsCaseTag
(rewrap.VT0.rebuilder_rec_case_line_dots d
)
2403 | Ast0.IdentTag
(d
) -> Ast0.IdentTag
(rewrap.VT0.rebuilder_rec_ident d
)
2404 | Ast0.ExprTag
(d
) -> Ast0.ExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2405 | Ast0.ArgExprTag
(d
) ->
2406 Ast0.ArgExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2407 | Ast0.TestExprTag
(d
) ->
2408 Ast0.TestExprTag
(rewrap.VT0.rebuilder_rec_expression d
)
2409 | Ast0.TypeCTag
(d
) -> Ast0.TypeCTag
(rewrap.VT0.rebuilder_rec_typeC d
)
2410 | Ast0.InitTag
(d
) -> Ast0.InitTag
(rewrap.VT0.rebuilder_rec_initialiser d
)
2411 | Ast0.ParamTag
(d
) -> Ast0.ParamTag
(rewrap.VT0.rebuilder_rec_parameter d
)
2412 | Ast0.DeclTag
(d
) -> Ast0.DeclTag
(rewrap.VT0.rebuilder_rec_declaration d
)
2413 | Ast0.StmtTag
(d
) -> Ast0.StmtTag
(rewrap.VT0.rebuilder_rec_statement d
)
2414 | Ast0.CaseLineTag
(d
) ->
2415 Ast0.CaseLineTag
(rewrap.VT0.rebuilder_rec_case_line d
)
2416 | Ast0.TopTag
(d
) -> Ast0.TopTag
(rewrap.VT0.rebuilder_rec_top_level d
)
2417 | Ast0.IsoWhenTag
(_) | Ast0.IsoWhenTTag
(_) | Ast0.IsoWhenFTag
(_) ->
2418 failwith
"only for isos within iso phase"
2419 | Ast0.MetaPosTag
(p
) -> Ast0.MetaPosTag
(p
)
2421 (* --------------------------------------------------------------------- *)
2423 let apply_isos isos rule rule_name
=
2428 current_rule := rule_name
;
2431 (function (metavars
,iso
,name
) ->
2432 (metavars
,List.map
(List.map
rewrap_anything) iso
,name
))
2434 let (extra_meta
,rule
) =
2439 (function (extra_meta
,t
) -> function iso
->
2440 let (new_extra_meta
,t
) = transform iso t
in
2441 (new_extra_meta
@extra_meta
,t
))
2444 (List.concat extra_meta
, (Compute_lines.compute_lines
true) rule
)
HCoop / bpt / coccinelle.git / blob