2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* The error message "no available token to attach to" often comes in an
24 argument list of unbounded length. In this case, one should move a comma so
25 that there is a comma after the + code. *)
27 (* Start at all of the corresponding BindContext nodes in the minus and
28 plus trees, and traverse their children. We take the same strategy as
29 before: collect the list of minus/context nodes/tokens and the list of plus
30 tokens, and then merge them. *)
32 module Ast
= Ast_cocci
33 module Ast0
= Ast0_cocci
34 module V0
= Visitor_ast0
35 module VT0
= Visitor_ast0_types
36 module CN
= Context_neg
38 let empty_isos = ref false
40 let get_option f
= function
44 (* --------------------------------------------------------------------- *)
45 (* Collect root and all context nodes in a tree *)
47 let collect_context e
=
48 let bind x y
= x
@ y
in
49 let option_default = [] in
53 let donothing builder r k e
=
54 match Ast0.get_mcodekind e
with
55 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
58 (* special case for everything that contains whencode, so that we skip over
60 let expression r k e
=
61 donothing Ast0.expr r k
63 (match Ast0.unwrap e
with
64 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
65 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
66 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
67 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
68 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
71 let initialiser r k i
=
72 donothing Ast0.ini r k
74 (match Ast0.unwrap i
with
75 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
79 donothing Ast0.stmt r k
81 (match Ast0.unwrap s
with
82 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
83 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
84 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
85 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
86 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
89 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
92 V0.flat_combiner
bind option_default
93 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
94 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
95 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
96 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
97 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
98 (donothing Ast0.param
) (donothing Ast0.decl
) statement
99 (donothing Ast0.case_line
) topfn in
100 res.VT0.combiner_rec_top_level e
102 (* --------------------------------------------------------------------- *)
103 (* --------------------------------------------------------------------- *)
104 (* collect the possible join points, in order, among the children of a
105 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
106 because their delimiters take up a line by themselves *)
108 (* An Unfavored token is one that is in a BindContext node; using this causes
109 the node to become Neither, meaning that isomorphisms can't be applied *)
110 (* Toplevel is for the bef token of a function declaration and is for
111 attaching top-level definitions that should come before the complete
113 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
115 (* Maps the index of a node to the indices of the mcodes it contains *)
116 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
118 let create_root_token_table minus
=
124 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
125 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
126 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
127 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
128 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
129 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
130 | Ast0.IdentTag
(d
) -> Ast0.get_index d
131 | Ast0.ExprTag
(d
) -> Ast0.get_index d
132 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
133 failwith
"not possible - iso only"
134 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
135 | Ast0.ParamTag
(d
) -> Ast0.get_index d
136 | Ast0.InitTag
(d
) -> Ast0.get_index d
137 | Ast0.DeclTag
(d
) -> Ast0.get_index d
138 | Ast0.StmtTag
(d
) -> Ast0.get_index d
139 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
140 | Ast0.TopTag
(d
) -> Ast0.get_index d
141 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
142 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
143 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
144 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
146 Hashtbl.add
root_token_table key tokens
)
150 let index = Ast0.get_index r
in
151 try let _ = Hashtbl.find
root_token_table index in ()
152 with Not_found
-> Hashtbl.add
root_token_table index [])
155 let collect_minus_join_points root
=
156 let root_index = Ast0.get_index root
in
157 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
158 let bind x y
= x
@ y
in
159 let option_default = [] in
161 let mcode (x
,_,info
,mcodekind
,_,_) =
162 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
163 then [(Unfavored
,info
,mcodekind
)]
164 else [(Favored
,info
,mcodekind
)] in
166 let do_nothing r k e
=
167 let info = Ast0.get_info e
in
168 let index = Ast0.get_index e
in
169 match Ast0.get_mcodekind e
with
170 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
171 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
172 (* This was unfavored at one point, but I don't remember why *)
176 (* don't want to attach to the outside of DOTS, because metavariables can't
177 bind to that; not good for isomorphisms *)
181 let rec loop = function
184 | x
::xs
-> bind x
(loop xs
) in
187 match Ast0.unwrap d
with
188 Ast0.DOTS
(l
) -> multibind (List.map f l
)
189 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
190 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
192 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
193 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
194 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
195 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
196 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
197 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
199 (* a case for everything that has a Opt *)
201 let statement r k s
=
203 let redo_branched res (ifinfo,aftmc) =
204 let redo fv info mc rest =
205 let new_info = {info with Ast0.attachable_end = false} in
206 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
207 match List.rev res with
210 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
211 (* even for -, better for isos not to integrate code after an
213 but the problem is that this can extend the region in
214 which a variable is bound, because a variable bound in the
215 aft node would seem to have to be live in the whole if,
216 whereas we might like it to be live in only one branch.
217 ie ideally, if we can keep the minus code in the right
218 order, we would like to drop it as close to the bindings
219 of its free variables. This could be anywhere in the minus
220 code. Perhaps we would like to do this after the
221 application of isomorphisms, though.
225 | (fv
,info,mc
)::rest
->
227 Ast0.CONTEXT
(_) -> redo fv
info mc rest
229 | _ -> failwith
"unexpected empty code" in *)
230 match Ast0.unwrap s
with
231 (* Ast0.IfThen(_,_,_,_,_,aft)
232 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
233 | Ast0.While(_,_,_,_,_,aft)
234 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
235 | Ast0.Iterator(_,_,_,_,_,aft) ->
236 redo_branched (do_nothing r k s) aft*)
237 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
238 (Toplevel
,info,bef
)::(k s
)
239 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
240 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
241 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
243 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
244 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
245 | Ast0.OptStm s
| Ast0.UniqueStm s
->
246 (* put the + code on the thing, not on the opt *)
247 r
.VT0.combiner_rec_statement s
248 | _ -> do_nothing r k s
in
250 let expression r k e
=
251 match Ast0.unwrap e
with
252 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
254 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
255 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
256 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
257 | Ast0.OptExp e
| Ast0.UniqueExp e
->
258 (* put the + code on the thing, not on the opt *)
259 r
.VT0.combiner_rec_expression e
260 | _ -> do_nothing r k e
in
263 match Ast0.unwrap e
with
264 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
265 (* put the + code on the thing, not on the opt *)
266 r
.VT0.combiner_rec_ident i
267 | _ -> do_nothing r k e
in
270 match Ast0.unwrap e
with
271 Ast0.OptType t
| Ast0.UniqueType t
->
272 (* put the + code on the thing, not on the opt *)
273 r
.VT0.combiner_rec_typeC t
274 | _ -> do_nothing r k e
in
277 match Ast0.unwrap e
with
278 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
279 (* put the + code on the thing, not on the opt *)
280 r
.VT0.combiner_rec_declaration d
281 | _ -> do_nothing r k e
in
283 let initialiser r k e
=
284 match Ast0.unwrap e
with
285 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
286 | Ast0.OptIni i
| Ast0.UniqueIni i
->
287 (* put the + code on the thing, not on the opt *)
288 r
.VT0.combiner_rec_initialiser i
289 | _ -> do_nothing r k e
in
292 match Ast0.unwrap e
with
293 Ast0.OptParam p
| Ast0.UniqueParam p
->
294 (* put the + code on the thing, not on the opt *)
295 r
.VT0.combiner_rec_parameter p
296 | _ -> do_nothing r k e
in
298 let case_line r k e
=
299 match Ast0.unwrap e
with
301 (* put the + code on the thing, not on the opt *)
302 r
.VT0.combiner_rec_case_line c
303 | _ -> do_nothing r k e
in
305 let do_top r k
(e
: Ast0.top_level
) = k e
in
307 V0.flat_combiner
bind option_default
308 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
309 edots idots pdots sdots ddots cdots
310 ident expression typeC initialiser param decl statement case_line do_top
313 let call_collect_minus context_nodes
:
314 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
318 Ast0.DotsExprTag
(e
) ->
320 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
321 | Ast0.DotsInitTag
(e
) ->
323 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
324 | Ast0.DotsParamTag
(e
) ->
326 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
327 | Ast0.DotsStmtTag
(e
) ->
329 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
330 | Ast0.DotsDeclTag
(e
) ->
332 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
333 | Ast0.DotsCaseTag
(e
) ->
335 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
336 | Ast0.IdentTag
(e
) ->
338 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
341 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
342 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
343 failwith
"not possible - iso only"
344 | Ast0.TypeCTag
(e
) ->
346 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
347 | Ast0.ParamTag
(e
) ->
349 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
352 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
355 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
358 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
359 | Ast0.CaseLineTag
(e
) ->
361 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
364 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
365 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
366 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
367 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
368 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
371 (* result of collecting the join points should be sorted in nondecreasing
374 let get_info = function
375 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
376 | (Decl
,info,_) -> info in
377 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
378 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
379 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
380 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
383 (index,((_::_) as l1
)) ->
386 (function (prev
,real_prev
) ->
388 let ln = token_start_line cur
in
393 "error in collection of - tokens: line %d less than line %d"
394 (token_real_start_line cur
) real_prev
);
395 (token_end_line cur
,token_real_end_line cur
))
396 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
399 | _ -> ()) (* dots, in eg f() has no join points *)
402 let process_minus minus
=
403 create_root_token_table minus
;
407 let res = call_collect_minus (collect_context x
) in
412 (* --------------------------------------------------------------------- *)
413 (* --------------------------------------------------------------------- *)
414 (* collect the plus tokens *)
416 let mk_structUnion x
= Ast.StructUnionTag x
417 let mk_sign x
= Ast.SignTag x
418 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
419 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
420 let mk_constant x
= Ast.ConstantTag x
421 let mk_unaryOp x
= Ast.UnaryOpTag x
422 let mk_assignOp x
= Ast.AssignOpTag x
423 let mk_fixOp x
= Ast.FixOpTag x
424 let mk_binaryOp x
= Ast.BinaryOpTag x
425 let mk_arithOp x
= Ast.ArithOpTag x
426 let mk_logicalOp x
= Ast.LogicalOpTag x
427 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
428 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
429 let mk_storage x
= Ast.StorageTag x
430 let mk_inc_file x
= Ast.IncFileTag x
431 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
432 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
433 let mk_const_vol x
= Ast.ConstVolTag x
434 let mk_token x
info = Ast.Token
(x
,Some
info)
435 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
436 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
438 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
439 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
440 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
441 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
442 let mk_casedots x
= failwith
"+ case lines not supported"
443 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
444 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
445 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
447 let collect_plus_nodes root
=
448 let root_index = Ast0.get_index root
in
450 let bind x y
= x
@ y
in
451 let option_default = [] in
453 let extract_strings info =
455 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
456 let extract = function
459 let (_,first
) = List.hd strings_before
in
460 let (_,last
) = List.hd
(List.rev strings_before
) in
462 {Ast0.line_start
= first
.Ast0.line_start
;
463 Ast0.line_end
= last
.Ast0.line_start
;
464 Ast0.logical_start
= first
.Ast0.logical_start
;
465 Ast0.logical_end
= last
.Ast0.logical_start
;
466 Ast0.column
= first
.Ast0.column
;
467 Ast0.offset
= first
.Ast0.offset
} in
468 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
469 let string = List.map
(function (s
,_) -> s
) strings_before
in
470 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
471 let bef = extract info.Ast0.strings_before
in
472 let aft = extract info.Ast0.strings_after
in
475 let mcode fn
(term
,_,info,mcodekind
,_,_) =
477 Ast0.PLUS c
-> [(info,c
,fn term
)]
478 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
481 let imcode fn
(term
,_,info,mcodekind
,_,_) =
483 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
484 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
487 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
489 let do_nothing fn r k e
=
490 match Ast0.get_mcodekind e
with
491 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
492 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
495 (* case for everything that is just a wrapper for a simpler thing *)
496 (* case for things with bef aft *)
498 match Ast0.unwrap e
with
499 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
500 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
501 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
502 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
503 | Ast0.Decl
(bef,decl) ->
504 (info bef) @ (do_nothing mk_statement r k e
)
505 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
506 (info bef) @ (do_nothing mk_statement r k e
)
507 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
508 (do_nothing mk_statement r k e
) @ (info aft)
509 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
510 (do_nothing mk_statement r k e
) @ (info aft)
511 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
512 (do_nothing mk_statement r k e
) @ (info aft)
513 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
514 (do_nothing mk_statement r k e
) @ (info aft)
515 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
516 (do_nothing mk_statement r k e
) @ (info aft)
517 | _ -> do_nothing mk_statement r k e
in
519 (* statementTag is preferred, because it indicates that one statement is
520 replaced by one statement, in single_statement *)
521 let stmt_dots r k e
=
522 match Ast0.unwrap e
with
523 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
524 r
.VT0.combiner_rec_statement s
525 | _ -> do_nothing mk_stmtdots r k e
in
528 match Ast0.unwrap e
with
529 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
530 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
531 | _ -> do_nothing mk_code r k e
in
533 let initdots r k e
= k e
in
535 V0.flat_combiner
bind option_default
536 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
538 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
539 (mcode mk_sign) (mcode mk_structUnion)
540 (mcode mk_storage) (mcode mk_inc_file)
541 (do_nothing mk_exprdots) initdots
542 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
543 (do_nothing mk_casedots)
544 (do_nothing mk_ident) (do_nothing mk_expression)
545 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
546 (do_nothing mk_declaration)
547 stmt (do_nothing mk_case_line) toplevel
549 let call_collect_plus context_nodes
:
550 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
554 Ast0.DotsExprTag
(e
) ->
556 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
557 | Ast0.DotsInitTag
(e
) ->
559 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
560 | Ast0.DotsParamTag
(e
) ->
562 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
563 | Ast0.DotsStmtTag
(e
) ->
565 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
566 | Ast0.DotsDeclTag
(e
) ->
568 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
569 | Ast0.DotsCaseTag
(e
) ->
571 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
572 | Ast0.IdentTag
(e
) ->
574 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
577 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
578 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
579 failwith
"not possible - iso only"
580 | Ast0.TypeCTag
(e
) ->
582 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
585 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
586 | Ast0.ParamTag
(e
) ->
588 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
591 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
594 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
595 | Ast0.CaseLineTag
(e
) ->
597 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
600 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
601 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
602 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
603 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
604 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
607 (* The plus fragments are converted to a list of lists of lists.
608 Innermost list: Elements have type anything. For any pair of successive
609 elements, n and n+1, the ending line of n is the same as the starting line
611 Middle lists: For any pair of successive elements, n and n+1, the ending
612 line of n is one less than the starting line of n+1.
613 Outer list: For any pair of successive elements, n and n+1, the ending
614 line of n is more than one less than the starting line of n+1. *)
616 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
617 let logend info = info.Ast0.pos_info
.Ast0.logical_end
619 let redo info start finish
=
621 {info.Ast0.pos_info
with
622 Ast0.logical_start
= start
;
623 Ast0.logical_end
= finish
} in
624 {info with Ast0.pos_info
= new_pos_info}
626 let rec find_neighbors (index,l
) :
627 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
628 let rec loop = function
631 (match loop rest
with
632 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
633 let finish1 = logend i
in
634 let start2 = logstart i1
in
637 ((if not
(c
= c1
) then failwith
"inconsistent + code");
638 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
641 else if finish1 + 1 = start2
642 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
644 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
645 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
649 let (start_info
,start_count
,_) = List.hd l
in
650 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
651 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
652 (redo start_info
(logstart start_info
) (logend end_info
),
654 List.map
(function (_,_,x
) -> x
) l
))
658 let process_plus plus
:
659 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
663 List.map
find_neighbors (call_collect_plus (collect_context x
)))
666 (* --------------------------------------------------------------------- *)
667 (* --------------------------------------------------------------------- *)
670 let merge_one = function
671 (m1::m2::minus_info,p::plus_info) ->
673 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
674 if p > m1 && p < m2, then consider the following possibilities, in order
675 m1 is Good and favored: attach to the beginning of m1.aft
676 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
677 m1 is Good and unfavored: attach to the beginning of m1.aft
678 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
679 also flip m1.bef if the first where > m1
680 if we drop m1, then flip m1.aft first
682 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
685 (* end of first argument < start/end of second argument *)
686 let less_than_start info1 info2
=
687 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
688 let less_than_end info1 info2
=
689 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
690 let greater_than_end info1 info2
=
691 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
692 let good_start info = info.Ast0.attachable_start
693 let good_end info = info.Ast0.attachable_end
695 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
696 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
697 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
700 List.for_all
(List.for_all
(function Ast.Code
_ -> true | _ -> false))
702 (* The following is probably not correct. The idea is to detect what
703 should be placed completely before the declaration. So type/storage
704 related things do not fall into this category, and complete statements do
705 fall into this category. But perhaps other things should be in this
706 category as well, such as { or ;? *)
708 let tester = function
709 (* the following should definitely be true *)
715 | Ast.Pragma
_ -> true
716 (* the following should definitely be false *)
717 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
719 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
720 (* not sure about the rest *)
722 List.for_all
(List.for_all
tester)
724 let pr = Printf.sprintf
726 let insert thing thinginfo into intoinfo
=
727 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
728 let get_first l = (List.hd
l,List.tl
l) in
729 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
730 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
731 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
732 let into_start = intoinfo
.Ast0.tline_start
in
733 let into_end = intoinfo
.Ast0.tline_end
in
734 let into_left_offset = intoinfo
.Ast0.left_offset
in
735 let into_right_offset = intoinfo
.Ast0.right_offset
in
736 if thing_end < into_start && thing_start < into_start
738 {{intoinfo
with Ast0.tline_start
= thing_start}
739 with Ast0.left_offset
= thing_offset})
740 else if thing_end = into_start && thing_offset < into_left_offset
742 let (prev
,last
) = get_last thing
in
743 let (first
,rest
) = get_first into
in
744 (prev
@[last
@first
]@rest
,
745 {{intoinfo
with Ast0.tline_start
= thing_start}
746 with Ast0.left_offset
= thing_offset})
747 else if thing_start > into_end && thing_end > into_end
749 {{intoinfo
with Ast0.tline_end
= thing_end}
750 with Ast0.right_offset
= thing_offset})
751 else if thing_start = into_end && thing_offset > into_right_offset
753 let (first
,rest
) = get_first thing
in
754 let (prev
,last
) = get_last into
in
755 (prev
@[last
@first
]@rest
,
756 {{intoinfo
with Ast0.tline_end
= thing_end}
757 with Ast0.right_offset
= thing_offset})
760 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
761 thing_start thing_end into_start into_end;
762 Printf.printf
"thing offset %d left offset %d right offset %d\n"
763 thing_offset into_left_offset into_right_offset;
764 Pretty_print_cocci.print_anything
"" thing
;
765 Pretty_print_cocci.print_anything
"" into
;
766 failwith
"can't figure out where to put the + code"
769 let init thing
info =
771 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
772 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
773 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
774 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
776 let attachbefore (infop
,c
,p
) = function
777 Ast0.MINUS
(replacements
) ->
778 let (repl
,ti
) = !replacements
in
782 | repl
-> insert p infop repl ti
in
783 replacements
:= (bef,ti
)
784 | Ast0.CONTEXT
(neighbors
) ->
785 let (repl
,ti1
,ti2
) = !neighbors
in
787 Ast.BEFORE
(bef,it
) ->
788 let (bef,ti1
) = insert p infop
bef ti1
in
789 let it = Ast.lub_count
it c
in
790 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
791 | Ast.AFTER
(aft,it) ->
792 let (bef,ti1
) = init p infop
in
793 let it = Ast.lub_count
it c
in
794 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
795 | Ast.BEFOREAFTER
(bef,aft,it) ->
796 let (bef,ti1
) = insert p infop
bef ti1
in
797 let it = Ast.lub_count
it c
in
798 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
800 let (bef,ti1
) = init p infop
in
801 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
802 | _ -> failwith
"not possible for attachbefore"
804 let attachafter (infop
,c
,p
) = function
805 Ast0.MINUS
(replacements
) ->
806 let (repl
,ti
) = !replacements
in
810 | repl
-> insert p infop repl ti
in
811 replacements
:= (aft,ti
)
812 | Ast0.CONTEXT
(neighbors
) ->
813 let (repl
,ti1
,ti2
) = !neighbors
in
815 Ast.BEFORE
(bef,it) ->
816 let (aft,ti2
) = init p infop
in
817 let it = Ast.lub_count
it c
in
818 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
819 | Ast.AFTER
(aft,it) ->
820 let (aft,ti2
) = insert p infop
aft ti2
in
821 let it = Ast.lub_count
it c
in
822 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
823 | Ast.BEFOREAFTER
(bef,aft,it) ->
824 let (aft,ti2
) = insert p infop
aft ti2
in
825 let it = Ast.lub_count
it c
in
826 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
828 let (aft,ti2
) = init p infop
in
829 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
830 | _ -> failwith
"not possible for attachbefore"
832 let attach_all_before ps m
=
833 List.iter
(function x
-> attachbefore x m
) ps
835 let attach_all_after ps m
=
836 List.iter
(function x
-> attachafter x m
) ps
838 let split_at_end info ps
=
839 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
841 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
844 let allminus = function
845 Ast0.MINUS
(_) -> true
848 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
850 | (((infop
,_,_) as p
) :: ps
) as all
->
851 if less_than_start infop infom1
or
852 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
855 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
858 (pr "%d: no available token to attach to"
859 infop
.Ast0.pos_info
.Ast0.line_start
)
860 else after_m1 x1 x2 rest all
862 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
864 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
865 (* if the following is false, then some + code is stuck in the middle
866 of some context code (m1). could drop down to the token level.
867 this might require adjustments in ast0toast as well, when + code on
868 expressions is dropped down to + code on expressions. it might
869 also break some invariants on which iso depends, particularly on
870 what it can infer from something being CONTEXT with no top-level
871 modifications. for the moment, we thus give an error, asking the
872 user to rewrite the semantic patch. *)
873 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
875 if less_than_start infop infom2
877 if predecl_code pcode
&& good_end infom1
&& decl f1
878 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
879 else if predecl_code pcode
&& good_start infom2
&& decl f2
880 then before_m2 x2 rest all
881 else if top_code pcode
&& good_end infom1
&& toplevel f1
882 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
883 else if top_code pcode
&& good_start infom2
&& toplevel f2
884 then before_m2 x2 rest all
885 else if good_end infom1
&& favored f1
886 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
887 else if good_start infom2
&& favored f2
888 then before_m2 x2 rest all
889 else if good_end infom1
890 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
891 else if good_start infom2
892 then before_m2 x2 rest all
895 (pr "%d: no available token to attach to"
896 infop
.Ast0.pos_info
.Ast0.line_start
)
897 else after_m2 x2 rest all
900 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
901 infop
.Ast0.pos_info
.Ast0.line_start
902 infop
.Ast0.pos_info
.Ast0.line_end
903 infom1
.Ast0.pos_info
.Ast0.line_start
904 infom1
.Ast0.pos_info
.Ast0.line_end
905 infom2
.Ast0.pos_info
.Ast0.line_start
906 infom2
.Ast0.pos_info
.Ast0.line_end
;
907 Pretty_print_cocci.print_anything
"" pcode
;
909 "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."
912 (* not sure this is safe. if have iso problems, consider changing this
913 to always return false *)
914 and is_minus
= function
918 and before_m2
((f2
,infom2
,m2
) as x2
) rest
919 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
922 | ([],((infop
,_,_)::_)) ->
923 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
925 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
928 (pr "%d: no available token to attach to"
929 infop
.Ast0.pos_info
.Ast0.line_start
)
930 | (m
::ms
,_) -> before_m1 x2 m ms p
932 and after_m2
((f2
,infom2
,m2
) as x2
) rest
933 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
936 | ([],((infop
,_,_)::_)) ->
938 then attach_all_after p m2
941 (pr "%d: no available token to attach to"
942 infop
.Ast0.pos_info
.Ast0.line_start
)
943 | (m
::ms
,_) -> after_m1 x2 m ms p
945 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
946 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
949 Printf.printf "minus code\n";
951 (function (_,info,_) ->
952 Printf.printf "start %d end %d real_start %d real_end %d\n"
953 info.Ast0.pos_info.Ast0.logical_start
954 info.Ast0.pos_info.Ast0.logical_end
955 info.Ast0.pos_info.Ast0.line_start
956 info.Ast0.pos_info.Ast0.line_end)
958 Printf.printf "plus code\n";
960 (function (info,p) ->
961 Printf.printf "start %d end %d real_start %d real_end %d\n"
962 info.Ast0.pos_info.Ast0.logical_start
963 info.Ast0.pos_info.Ast0.logical_end
964 info.Ast0.pos_info.Ast0.line_end
965 info.Ast0.pos_info.Ast0.line_end;
966 Pretty_print_cocci.print_anything "" p;
967 Format.print_newline())
972 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
973 | ([m
],p
) -> before_m2 m
[] p
974 | ([],_) -> failwith
"minus tree ran out before the plus tree"
976 let merge minus_list plus_list
=
978 Printf.printf "minus list %s\n"
980 (List.map (function (x,_) -> string_of_int x) minus_list));
981 Printf.printf "plus list %s\n"
983 (List.map (function (x,_) -> string_of_int x) plus_list));
986 (function (index,minus_info
) ->
987 let plus_info = List.assoc
index plus_list
in
988 merge_one (minus_info
,plus_info))
991 (* --------------------------------------------------------------------- *)
992 (* --------------------------------------------------------------------- *)
993 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
994 If they do, they become MIXED *)
996 let reevaluate_contextness =
998 let option_default = [] in
1000 let mcode (_,_,_,mc
,_,_) =
1002 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1007 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1010 let donothing r k e
=
1011 match Ast0.get_mcodekind e
with
1013 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1014 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1016 | _ -> let _ = k e
in [] in
1018 (* a case for everything with bef or aft *)
1020 match Ast0.unwrap e
with
1021 Ast0.Decl
(bef,decl) ->
1022 (info bef) @ (donothing r k e
)
1023 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1024 (info bef) @ (donothing r k e
)
1025 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1026 (donothing r k e
) @ (info aft)
1027 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1028 (donothing r k e
) @ (info aft)
1029 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1030 (donothing r k e
) @ (info aft)
1031 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1032 (donothing r k e
) @ (info aft)
1033 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1034 (donothing r k e
) @ (info aft)
1035 | _ -> donothing r k e
in
1038 V0.flat_combiner
bind option_default
1039 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1040 donothing donothing donothing donothing donothing donothing donothing
1042 donothing donothing donothing donothing stmt donothing donothing in
1043 res.VT0.combiner_rec_top_level
1045 (* --------------------------------------------------------------------- *)
1046 (* --------------------------------------------------------------------- *)
1048 let insert_plus minus plus ei
=
1050 let minus_stream = process_minus minus
in
1051 let plus_stream = process_plus plus
in
1052 merge minus_stream plus_stream;
1053 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus