2 * Copyright 2012, INRIA
3 * Julia Lawall, Gilles Muller
4 * Copyright 2010-2011, INRIA, University of Copenhagen
5 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
6 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
7 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
8 * This file is part of Coccinelle.
10 * Coccinelle is free software: you can redistribute it and/or modify
11 * it under the terms of the GNU General Public License as published by
12 * the Free Software Foundation, according to version 2 of the License.
14 * Coccinelle is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 * GNU General Public License for more details.
19 * You should have received a copy of the GNU General Public License
20 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
22 * The authors reserve the right to distribute this or future versions of
23 * Coccinelle under other licenses.
27 #
0 "./insert_plus.ml"
28 (* The error message "no available token to attach to" often comes in an
29 argument list of unbounded length. In this case, one should move a comma so
30 that there is a comma after the + code. *)
32 (* Start at all of the corresponding BindContext nodes in the minus and
33 plus trees, and traverse their children. We take the same strategy as
34 before: collect the list of minus/context nodes/tokens and the list of plus
35 tokens, and then merge them. *)
37 module Ast
= Ast_cocci
38 module Ast0
= Ast0_cocci
39 module V0
= Visitor_ast0
40 module VT0
= Visitor_ast0_types
41 module CN
= Context_neg
43 let empty_isos = ref false
45 let get_option f
= function
49 (* --------------------------------------------------------------------- *)
50 (* Collect root and all context nodes in a tree *)
52 let collect_context e
=
53 let bind x y
= x
@ y
in
54 let option_default = [] in
58 let donothing builder r k e
=
59 match Ast0.get_mcodekind e
with
60 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
63 (* special case for everything that contains whencode, so that we skip over
65 let expression r k e
=
66 donothing Ast0.expr r k
68 (match Ast0.unwrap e
with
69 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
70 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
71 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
72 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
73 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
76 let initialiser r k i
=
77 donothing Ast0.ini r k
79 (match Ast0.unwrap i
with
80 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
84 donothing Ast0.stmt r k
86 (match Ast0.unwrap s
with
87 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
88 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
89 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
90 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
91 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
94 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
97 V0.flat_combiner
bind option_default
98 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
99 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
100 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
101 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
102 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
103 (donothing Ast0.param
) (donothing Ast0.decl
) statement
104 (donothing Ast0.forinfo
) (donothing Ast0.case_line
) topfn in
105 res.VT0.combiner_rec_top_level e
107 (* --------------------------------------------------------------------- *)
108 (* --------------------------------------------------------------------- *)
109 (* collect the possible join points, in order, among the children of a
110 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
111 because their delimiters take up a line by themselves *)
113 (* An Unfavored token is one that is in a BindContext node; using this causes
114 the node to become Neither, meaning that isomorphisms can't be applied *)
115 (* Toplevel is for the bef token of a function declaration and is for
116 attaching top-level definitions that should come before the complete
118 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
120 (* Maps the index of a node to the indices of the mcodes it contains *)
121 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
123 let create_root_token_table minus
=
129 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
130 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
131 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
132 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
133 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
134 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
135 | Ast0.IdentTag
(d
) -> Ast0.get_index d
136 | Ast0.ExprTag
(d
) -> Ast0.get_index d
137 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
138 failwith
"not possible - iso only"
139 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
140 | Ast0.ParamTag
(d
) -> Ast0.get_index d
141 | Ast0.InitTag
(d
) -> Ast0.get_index d
142 | Ast0.DeclTag
(d
) -> Ast0.get_index d
143 | Ast0.StmtTag
(d
) -> Ast0.get_index d
144 | Ast0.ForInfoTag
(d
) -> Ast0.get_index d
145 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
146 | Ast0.TopTag
(d
) -> Ast0.get_index d
147 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
148 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
149 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
150 | Ast0.MetaPosTag
(p
) -> failwith
"not in plus code"
151 | Ast0.HiddenVarTag
(p
) -> failwith
"only within iso phase"
153 Hashtbl.add
root_token_table key tokens
)
157 let index = Ast0.get_index r
in
158 try let _ = Hashtbl.find
root_token_table index in ()
159 with Not_found
-> Hashtbl.add
root_token_table index [])
162 let collect_minus_join_points root
=
163 let root_index = Ast0.get_index root
in
164 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
165 let bind x y
= x
@ y
in
166 let option_default = [] in
168 let mcode (x
,_,info
,mcodekind
,_,_) =
169 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
170 then [(Unfavored
,info
,mcodekind
)]
171 else [(Favored
,info
,mcodekind
)] in
173 let do_nothing r k e
=
174 let info = Ast0.get_info e
in
175 let index = Ast0.get_index e
in
176 match Ast0.get_mcodekind e
with
177 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
178 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
179 (* This was unfavored at one point, but I don't remember why *)
183 (* don't want to attach to the outside of DOTS, because metavariables can't
184 bind to that; not good for isomorphisms *)
188 let rec loop = function
191 | x
::xs
-> bind x
(loop xs
) in
194 match Ast0.unwrap d
with
195 Ast0.DOTS
(l
) -> multibind (List.map f l
)
196 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
197 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
199 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
200 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
201 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
202 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
203 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
204 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
206 (* a case for everything that has a Opt *)
208 let statement r k s
=
210 let redo_branched res (ifinfo,aftmc) =
211 let redo fv info mc rest =
212 let new_info = {info with Ast0.attachable_end = false} in
213 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
214 match List.rev res with
217 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
218 (* even for -, better for isos not to integrate code after an
220 but the problem is that this can extend the region in
221 which a variable is bound, because a variable bound in the
222 aft node would seem to have to be live in the whole if,
223 whereas we might like it to be live in only one branch.
224 ie ideally, if we can keep the minus code in the right
225 order, we would like to drop it as close to the bindings
226 of its free variables. This could be anywhere in the minus
227 code. Perhaps we would like to do this after the
228 application of isomorphisms, though.
232 | (fv
,info,mc
)::rest
->
234 Ast0.CONTEXT
(_) -> redo fv
info mc rest
236 | _ -> failwith
"unexpected empty code" in *)
237 match Ast0.unwrap s
with
238 (* Ast0.IfThen(_,_,_,_,_,aft)
239 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
240 | Ast0.While(_,_,_,_,_,aft)
241 | Ast0.For(_,_,_,_,_,_,_,_,aft)
242 | Ast0.Iterator(_,_,_,_,_,aft) ->
243 redo_branched (do_nothing r k s) aft*)
244 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
245 (Toplevel
,info,bef
)::(k s
)
246 | Ast0.Decl
((info,bef
),decl
) ->
247 (Decl
,info,bef
)::(k s
)
248 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
249 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
251 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
252 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
253 | Ast0.OptStm s
| Ast0.UniqueStm s
->
254 (* put the + code on the thing, not on the opt *)
255 r
.VT0.combiner_rec_statement s
256 | _ -> do_nothing r k s
in
259 match Ast0.unwrap s
with
260 Ast0.ForDecl
((info,bef
),decl
) ->
261 (Decl
,info,bef
)::(k s
)
264 let expression r k e
=
265 match Ast0.unwrap e
with
266 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
268 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
269 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
270 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
271 | Ast0.OptExp e
| Ast0.UniqueExp e
->
272 (* put the + code on the thing, not on the opt *)
273 r
.VT0.combiner_rec_expression e
274 | _ -> do_nothing r k e
in
277 match Ast0.unwrap e
with
278 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
279 (* put the + code on the thing, not on the opt *)
280 r
.VT0.combiner_rec_ident i
281 | _ -> do_nothing r k e
in
284 match Ast0.unwrap e
with
285 Ast0.OptType t
| Ast0.UniqueType t
->
286 (* put the + code on the thing, not on the opt *)
287 r
.VT0.combiner_rec_typeC t
288 | _ -> do_nothing r k e
in
291 match Ast0.unwrap e
with
292 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
293 (* put the + code on the thing, not on the opt *)
294 r
.VT0.combiner_rec_declaration d
295 | _ -> do_nothing r k e
in
297 let initialiser r k e
=
298 match Ast0.unwrap e
with
299 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
300 | Ast0.OptIni i
| Ast0.UniqueIni i
->
301 (* put the + code on the thing, not on the opt *)
302 r
.VT0.combiner_rec_initialiser i
303 | _ -> do_nothing r k e
in
306 match Ast0.unwrap e
with
307 Ast0.OptParam p
| Ast0.UniqueParam p
->
308 (* put the + code on the thing, not on the opt *)
309 r
.VT0.combiner_rec_parameter p
310 | _ -> do_nothing r k e
in
312 let case_line r k e
=
313 match Ast0.unwrap e
with
315 (* put the + code on the thing, not on the opt *)
316 r
.VT0.combiner_rec_case_line c
317 | _ -> do_nothing r k e
in
319 let do_top r k
(e
: Ast0.top_level
) = k e
in
321 V0.flat_combiner
bind option_default
322 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
323 edots idots pdots sdots ddots cdots
324 ident expression typeC initialiser param decl statement forinfo
328 let call_collect_minus context_nodes
:
329 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
333 Ast0.DotsExprTag
(e
) ->
335 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
336 | Ast0.DotsInitTag
(e
) ->
338 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
339 | Ast0.DotsParamTag
(e
) ->
341 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
342 | Ast0.DotsStmtTag
(e
) ->
344 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
345 | Ast0.DotsDeclTag
(e
) ->
347 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
348 | Ast0.DotsCaseTag
(e
) ->
350 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
351 | Ast0.IdentTag
(e
) ->
353 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
356 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
357 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
358 failwith
"not possible - iso only"
359 | Ast0.TypeCTag
(e
) ->
361 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
362 | Ast0.ParamTag
(e
) ->
364 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
367 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
370 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
373 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
374 | Ast0.ForInfoTag
(e
) ->
376 (collect_minus_join_points e
).VT0.combiner_rec_forinfo e
)
377 | Ast0.CaseLineTag
(e
) ->
379 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
382 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
383 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
384 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
385 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
386 | Ast0.MetaPosTag
(p
) -> failwith
"not in plus code"
387 | Ast0.HiddenVarTag
(p
) -> failwith
"only within iso phase")
390 (* result of collecting the join points should be sorted in nondecreasing
393 let get_info = function
394 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
395 | (Decl
,info,_) -> info in
396 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
397 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
398 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
399 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
402 (index,((_::_) as l1
)) ->
405 (function (prev
,real_prev
) ->
407 let ln = token_start_line cur
in
412 "error in collection of - tokens: line %d less than line %d"
413 (token_real_start_line cur
) real_prev
);
414 (token_end_line cur
,token_real_end_line cur
))
415 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
418 | _ -> ()) (* dots, in eg f() has no join points *)
421 let process_minus minus
=
422 Hashtbl.clear
root_token_table;
423 create_root_token_table minus
;
427 let res = call_collect_minus (collect_context x
) in
432 (* --------------------------------------------------------------------- *)
433 (* --------------------------------------------------------------------- *)
434 (* collect the plus tokens *)
436 let mk_structUnion x
= Ast.StructUnionTag x
437 let mk_sign x
= Ast.SignTag x
438 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
439 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
440 let mk_constant x
= Ast.ConstantTag x
441 let mk_unaryOp x
= Ast.UnaryOpTag x
442 let mk_assignOp x
= Ast.AssignOpTag x
443 let mk_fixOp x
= Ast.FixOpTag x
444 let mk_binaryOp x
= Ast.BinaryOpTag x
445 let mk_arithOp x
= Ast.ArithOpTag x
446 let mk_logicalOp x
= Ast.LogicalOpTag x
447 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
448 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
449 let mk_storage x
= Ast.StorageTag x
450 let mk_inc_file x
= Ast.IncFileTag x
451 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
452 let mk_forinfo x
= Ast.ForInfoTag
(Ast0toast.forinfo x
)
453 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
454 let mk_const_vol x
= Ast.ConstVolTag x
455 let mk_token x
info = Ast.Token
(x
,Some
info)
456 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
457 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
459 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
460 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
461 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
462 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
463 let mk_casedots x
= failwith
"+ case lines not supported"
464 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC false x
)
465 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
466 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
468 let collect_plus_nodes root
=
469 let root_index = Ast0.get_index root
in
471 let bind x y
= x
@ y
in
472 let option_default = [] in
474 let extract_strings info =
476 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
477 let extract = function
480 let (_,first
) = List.hd strings_before
in
481 let (_,last
) = List.hd
(List.rev strings_before
) in
483 {Ast0.line_start
= first
.Ast0.line_start
;
484 Ast0.line_end
= last
.Ast0.line_start
;
485 Ast0.logical_start
= first
.Ast0.logical_start
;
486 Ast0.logical_end
= last
.Ast0.logical_start
;
487 Ast0.column
= first
.Ast0.column
;
488 Ast0.offset
= first
.Ast0.offset
} in
489 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
490 let string = List.map
(function (s
,_) -> s
) strings_before
in
491 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
492 let bef = extract info.Ast0.strings_before
in
493 let aft = extract info.Ast0.strings_after
in
496 let mcode fn
(term
,_,info,mcodekind
,_,_) =
498 Ast0.PLUS c
-> [(info,c
,fn term
)]
499 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
502 let imcode fn
(term
,_,info,mcodekind
,_,_) =
504 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
505 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
508 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
510 let do_nothing fn r k e
=
511 match Ast0.get_mcodekind e
with
512 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
513 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
516 (* case for everything that is just a wrapper for a simpler thing *)
517 (* case for things with bef aft *)
519 match Ast0.unwrap e
with
520 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
521 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
522 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
523 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
524 | Ast0.Decl
(bef,decl) ->
525 (info bef) @ (do_nothing mk_statement r k e
)
526 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
527 (info bef) @ (do_nothing mk_statement r k e
)
528 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
529 (do_nothing mk_statement r k e
) @ (info aft)
530 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
531 (do_nothing mk_statement r k e
) @ (info aft)
532 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
533 (do_nothing mk_statement r k e
) @ (info aft)
534 | Ast0.For
(fr
,lp
,first
,e2
,sem2
,e3
,rp
,body
,aft) ->
535 (do_nothing mk_statement r k e
) @ (info aft)
536 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
537 (do_nothing mk_statement r k e
) @ (info aft)
538 | _ -> do_nothing mk_statement r k e
in
540 (* statementTag is preferred, because it indicates that one statement is
541 replaced by one statement, in single_statement *)
542 let stmt_dots r k e
=
543 match Ast0.unwrap e
with
544 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
545 r
.VT0.combiner_rec_statement s
546 | _ -> do_nothing mk_stmtdots r k e
in
549 match Ast0.unwrap e
with
550 Ast0.NONDECL
(s
) -> r
.VT0.combiner_rec_statement s
551 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
552 | _ -> do_nothing mk_code r k e
in
554 let initdots r k e
= k e
in
556 V0.flat_combiner
bind option_default
557 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
559 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
560 (mcode mk_sign) (mcode mk_structUnion)
561 (mcode mk_storage) (mcode mk_inc_file)
562 (do_nothing mk_exprdots) initdots
563 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
564 (do_nothing mk_casedots)
565 (do_nothing mk_ident) (do_nothing mk_expression)
566 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
567 (do_nothing mk_declaration)
568 stmt (do_nothing mk_forinfo) (do_nothing mk_case_line) toplevel
570 let call_collect_plus context_nodes
:
571 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
575 Ast0.DotsExprTag
(e
) ->
577 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
578 | Ast0.DotsInitTag
(e
) ->
580 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
581 | Ast0.DotsParamTag
(e
) ->
583 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
584 | Ast0.DotsStmtTag
(e
) ->
586 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
587 | Ast0.DotsDeclTag
(e
) ->
589 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
590 | Ast0.DotsCaseTag
(e
) ->
592 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
593 | Ast0.IdentTag
(e
) ->
595 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
598 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
599 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
600 failwith
"not possible - iso only"
601 | Ast0.TypeCTag
(e
) ->
603 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
606 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
607 | Ast0.ParamTag
(e
) ->
609 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
612 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
615 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
616 | Ast0.ForInfoTag
(e
) ->
618 (collect_plus_nodes e
).VT0.combiner_rec_forinfo e
)
619 | Ast0.CaseLineTag
(e
) ->
621 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
624 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
625 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
626 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
627 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
628 | Ast0.MetaPosTag
(p
) -> failwith
"not visible here"
629 | Ast0.HiddenVarTag
(_) -> failwith
"only within iso phase")
632 (* The plus fragments are converted to a list of lists of lists.
633 Innermost list: Elements have type anything. For any pair of successive
634 elements, n and n+1, the ending line of n is the same as the starting line
636 Middle lists: For any pair of successive elements, n and n+1, the ending
637 line of n is one less than the starting line of n+1.
638 Outer list: For any pair of successive elements, n and n+1, the ending
639 line of n is more than one less than the starting line of n+1. *)
641 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
642 let logend info = info.Ast0.pos_info
.Ast0.logical_end
644 let redo info start finish
=
646 {info.Ast0.pos_info
with
647 Ast0.logical_start
= start
;
648 Ast0.logical_end
= finish
} in
649 {info with Ast0.pos_info
= new_pos_info}
651 let rec find_neighbors (index,l
) :
652 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
653 let rec loop = function
656 (match loop rest
with
657 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
658 let finish1 = logend i
in
659 let start2 = logstart i1
in
662 ((if not
(c
= c1
) then failwith
"inconsistent + code");
663 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
666 else if finish1 + 1 = start2
667 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
669 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
670 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
674 let (start_info
,start_count
,_) = List.hd l
in
675 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
676 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
677 (redo start_info
(logstart start_info
) (logend end_info
),
679 List.map
(function (_,_,x
) -> x
) l
))
683 let process_plus plus
:
684 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
688 List.map
find_neighbors (call_collect_plus (collect_context x
)))
691 (* --------------------------------------------------------------------- *)
692 (* --------------------------------------------------------------------- *)
695 let merge_one = function
696 (m1::m2::minus_info,p::plus_info) ->
698 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
699 if p > m1 && p < m2, then consider the following possibilities, in order
700 m1 is Good and favored: attach to the beginning of m1.aft
701 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
702 m1 is Good and unfavored: attach to the beginning of m1.aft
703 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
704 also flip m1.bef if the first where > m1
705 if we drop m1, then flip m1.aft first
707 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
710 (* end of first argument < start/end of second argument *)
711 let less_than_start info1 info2
=
712 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
713 let less_than_end info1 info2
=
714 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
715 let greater_than_end info1 info2
=
716 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
717 let good_start info = info.Ast0.attachable_start
718 let good_end info = info.Ast0.attachable_end
720 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
721 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
722 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
726 (List.for_all
(function Ast.Code
_ | Ast.Pragma
_ -> true | _ -> false))
730 (List.for_all
(function Ast.StorageTag
_ -> true | _ -> false))
732 (* The following is probably not correct. The idea is to detect what
733 should be placed completely before the declaration. So type/storage
734 related things do not fall into this category, and complete statements do
735 fall into this category. But perhaps other things should be in this
736 category as well, such as { or ;? *)
738 let tester = function
739 (* the following should definitely be true *)
745 | Ast.Pragma
_ -> true
746 (* the following should definitely be false *)
747 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
749 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
750 (* not sure about the rest *)
752 List.for_all
(List.for_all
tester)
754 let pr = Printf.sprintf
756 let insert thing thinginfo into intoinfo
=
757 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
758 let get_first l = (List.hd
l,List.tl
l) in
759 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
760 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
761 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
762 let into_start = intoinfo
.Ast0.tline_start
in
763 let into_end = intoinfo
.Ast0.tline_end
in
764 let into_left_offset = intoinfo
.Ast0.left_offset
in
765 let into_right_offset = intoinfo
.Ast0.right_offset
in
766 if thing_end < into_start && thing_start < into_start
768 {{intoinfo
with Ast0.tline_start
= thing_start}
769 with Ast0.left_offset
= thing_offset})
770 else if thing_end = into_start && thing_offset < into_left_offset
772 let (prev
,last
) = get_last thing
in
773 let (first
,rest
) = get_first into
in
774 (prev
@[last
@first
]@rest
,
775 {{intoinfo
with Ast0.tline_start
= thing_start}
776 with Ast0.left_offset
= thing_offset})
777 else if thing_start > into_end && thing_end > into_end
779 {{intoinfo
with Ast0.tline_end
= thing_end}
780 with Ast0.right_offset
= thing_offset})
781 else if thing_start = into_end && thing_offset > into_right_offset
783 let (first
,rest
) = get_first thing
in
784 let (prev
,last
) = get_last into
in
785 (prev
@[last
@first
]@rest
,
786 {{intoinfo
with Ast0.tline_end
= thing_end}
787 with Ast0.right_offset
= thing_offset})
790 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
791 thing_start thing_end into_start into_end;
792 Printf.printf
"thing offset %d left offset %d right offset %d\n"
793 thing_offset into_left_offset into_right_offset;
794 Pretty_print_cocci.print_anything
"" thing
;
795 Pretty_print_cocci.print_anything
"" into
;
796 failwith
"can't figure out where to put the + code"
799 let init thing
info =
801 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
802 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
803 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
804 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
806 let it2c = function Ast.ONE
-> "one" | Ast.MANY
-> "many"
808 let attachbefore (infop
,c
,p
) = function
809 Ast0.MINUS
(replacements
) ->
810 let (repl
,ti
) = !replacements
in
813 let (bef,ti
) = init p infop
in
814 replacements
:= (Ast.REPLACEMENT
(bef,c
),ti
)
815 | Ast.REPLACEMENT
(repl
,it
) ->
816 let it = Ast.lub_count
it c
in
817 let (bef,ti
) = insert p infop repl ti
in
818 replacements
:= (Ast.REPLACEMENT
(bef,it),ti
))
819 | Ast0.CONTEXT
(neighbors
) ->
820 let (repl
,ti1
,ti2
) = !neighbors
in
822 Ast.BEFORE
(bef,it) ->
823 let (bef,ti1
) = insert p infop
bef ti1
in
824 let it = Ast.lub_count
it c
in
825 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
826 | Ast.AFTER
(aft,it) ->
827 let (bef,ti1
) = init p infop
in
828 let it = Ast.lub_count
it c
in
829 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
830 | Ast.BEFOREAFTER
(bef,aft,it) ->
831 let (bef,ti1
) = insert p infop
bef ti1
in
832 let it = Ast.lub_count
it c
in
833 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
835 let (bef,ti1
) = init p infop
in
836 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
837 | _ -> failwith
"not possible for attachbefore"
839 let attachafter (infop
,c
,p
) = function
840 Ast0.MINUS
(replacements
) ->
841 let (repl
,ti
) = !replacements
in
844 let (aft,ti
) = init p infop
in
845 replacements
:= (Ast.REPLACEMENT
(aft,c
),ti
)
846 | Ast.REPLACEMENT
(repl
,it) ->
847 let it = Ast.lub_count
it c
in
848 let (aft,ti
) = insert p infop repl ti
in
849 replacements
:= (Ast.REPLACEMENT
(aft,it),ti
))
850 | Ast0.CONTEXT
(neighbors
) ->
851 let (repl
,ti1
,ti2
) = !neighbors
in
853 Ast.BEFORE
(bef,it) ->
854 let (aft,ti2
) = init p infop
in
855 let it = Ast.lub_count
it c
in
856 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
857 | Ast.AFTER
(aft,it) ->
858 let (aft,ti2
) = insert p infop
aft ti2
in
859 let it = Ast.lub_count
it c
in
860 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
861 | Ast.BEFOREAFTER
(bef,aft,it) ->
862 let (aft,ti2
) = insert p infop
aft ti2
in
863 let it = Ast.lub_count
it c
in
864 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
866 let (aft,ti2
) = init p infop
in
867 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
868 | _ -> failwith
"not possible for attachbefore"
870 let attach_all_before ps m
=
871 List.iter
(function x
-> attachbefore x m
) ps
873 let attach_all_after ps m
=
874 List.iter
(function x
-> attachafter x m
) ps
876 let split_at_end info ps
=
877 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
879 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
882 let allminus = function
883 Ast0.MINUS
(_) -> true
886 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
888 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
889 if less_than_start infop infom1
or
890 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
894 if storage_code pcode
895 then before_m2 x2 rest all
(* skip fake token for storage *)
896 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
899 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
902 (pr "%d: no available token to attach to"
903 infop
.Ast0.pos_info
.Ast0.line_start
)
904 else after_m1 x1 x2 rest all
906 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
908 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
909 (* if the following is false, then some + code is stuck in the middle
910 of some context code (m1). could drop down to the token level.
911 this might require adjustments in ast0toast as well, when + code on
912 expressions is dropped down to + code on expressions. it might
913 also break some invariants on which iso depends, particularly on
914 what it can infer from something being CONTEXT with no top-level
915 modifications. for the moment, we thus give an error, asking the
916 user to rewrite the semantic patch. *)
917 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
919 if less_than_start infop infom2
921 if predecl_code pcode
&& good_end infom1
&& decl f1
922 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
923 else if predecl_code pcode
&& good_start infom2
&& decl f2
924 then before_m2 x2 rest all
925 else if top_code pcode
&& good_end infom1
&& toplevel f1
926 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
927 else if top_code pcode
&& good_start infom2
&& toplevel f2
928 then before_m2 x2 rest all
929 else if good_end infom1
&& favored f1
930 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
931 else if good_start infom2
&& favored f2
932 then before_m2 x2 rest all
933 else if good_end infom1
934 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
935 else if good_start infom2
936 then before_m2 x2 rest all
939 (pr "%d: no available token to attach to"
940 infop
.Ast0.pos_info
.Ast0.line_start
)
941 else after_m2 x2 rest all
944 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
945 infop
.Ast0.pos_info
.Ast0.line_start
946 infop
.Ast0.pos_info
.Ast0.line_end
947 infom1
.Ast0.pos_info
.Ast0.line_start
948 infom1
.Ast0.pos_info
.Ast0.line_end
949 infom2
.Ast0.pos_info
.Ast0.line_start
950 infom2
.Ast0.pos_info
.Ast0.line_end
;
951 Pretty_print_cocci.print_anything
"" pcode
;
953 "The semantic patch is structured in a way that may give bad results with isomorphisms. Please try to rewrite it by moving + code out from -/context terms."
956 (* not sure this is safe. if have iso problems, consider changing this
957 to always return false *)
958 and is_minus
= function
962 and before_m2
((f2
,infom2
,m2
) as x2
) rest
963 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
966 | ([],((infop
,_,_)::_)) ->
967 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
969 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
972 (pr "%d: no available token to attach to"
973 infop
.Ast0.pos_info
.Ast0.line_start
)
974 | (m
::ms
,_) -> before_m1 x2 m ms p
976 and after_m2
((f2
,infom2
,m2
) as x2
) rest
977 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
980 | ([],((infop
,_,_)::_)) ->
982 then attach_all_after p m2
985 (pr "%d: no available token to attach to"
986 infop
.Ast0.pos_info
.Ast0.line_start
)
987 | (m
::ms
,_) -> after_m1 x2 m ms p
989 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
990 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
993 Printf.printf "minus code\n";
995 (function (_,info,_) ->
997 "start %d end %d real_start %d real_end %d attachable start %b attachable end %b\n"
998 info.Ast0.pos_info.Ast0.logical_start
999 info.Ast0.pos_info.Ast0.logical_end
1000 info.Ast0.pos_info.Ast0.line_start
1001 info.Ast0.pos_info.Ast0.line_end
1002 info.Ast0.attachable_start
1003 info.Ast0.attachable_end)
1005 Printf.printf "plus code\n";
1007 (function (info,_,p) ->
1008 Printf.printf "start %d end %d real_start %d real_end %d\n"
1009 info.Ast0.pos_info.Ast0.logical_start
1010 info.Ast0.pos_info.Ast0.logical_end
1011 info.Ast0.pos_info.Ast0.line_end
1012 info.Ast0.pos_info.Ast0.line_end;
1013 Pretty_print_cocci.print_anything "" p;
1014 Format.print_newline())
1019 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
1020 | ([m
],p
) -> before_m2 m
[] p
1021 | ([],_) -> failwith
"minus tree ran out before the plus tree"
1023 let merge minus_list plus_list
=
1025 Printf.printf "minus list %s\n"
1027 (List.map (function (x,_) -> string_of_int x) minus_list));
1028 Printf.printf "plus list %s\n"
1030 (List.map (function (x,_) -> string_of_int x) plus_list));
1033 (function (index,minus_info
) ->
1034 let plus_info = List.assoc
index plus_list
in
1035 merge_one (minus_info
,plus_info))
1038 (* --------------------------------------------------------------------- *)
1039 (* --------------------------------------------------------------------- *)
1040 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1041 If they do, they become MIXED *)
1043 let reevaluate_contextness =
1045 let option_default = [] in
1047 let mcode (_,_,_,mc
,_,_) =
1049 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1054 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1057 let donothing r k e
=
1058 match Ast0.get_mcodekind e
with
1060 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1061 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1063 | _ -> let _ = k e
in [] in
1065 (* a case for everything with bef or aft *)
1067 match Ast0.unwrap e
with
1068 Ast0.Decl
(bef,decl) ->
1069 (info bef) @ (donothing r k e
)
1070 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1071 (info bef) @ (donothing r k e
)
1072 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1073 (donothing r k e
) @ (info aft)
1074 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1075 (donothing r k e
) @ (info aft)
1076 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1077 (donothing r k e
) @ (info aft)
1078 | Ast0.For
(fr
,lp
,first
,e2
,sem2
,e3
,rp
,body
,aft) ->
1079 (donothing r k e
) @ (info aft)
1080 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1081 (donothing r k e
) @ (info aft)
1082 | _ -> donothing r k e
in
1085 V0.flat_combiner
bind option_default
1086 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1087 donothing donothing donothing donothing donothing donothing donothing
1089 donothing donothing donothing stmt donothing donothing donothing in
1090 res.VT0.combiner_rec_top_level
1092 (* --------------------------------------------------------------------- *)
1093 (* --------------------------------------------------------------------- *)
1095 let insert_plus minus plus ei
=
1097 let minus_stream = process_minus minus
in
1098 let plus_stream = process_plus plus
in
1099 merge minus_stream plus_stream;
1100 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus