2 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
23 (* 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 (_,_,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 %d less than %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.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
-> [(info,fn term
)]
478 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
481 let imcode fn
(term
,_,info,mcodekind
,_,_) =
483 Ast0.PLUS
-> [(info,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
-> [(Ast0.get_info e
,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.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.anything list list
)) list
=
628 let rec loop = function
631 (match loop rest
with
632 ((i1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
633 let finish1 = logend i
in
634 let start2 = logstart i1
in
637 ((redo i
(logstart i
) (logend i1
),(x
::x1
::rest_inner
))
640 else if finish1 + 1 = start2
641 then ((i
,[x
])::(i1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
642 else [(i
,[x
])]::((i1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
643 | _ -> [[(i
,[x
])]]) (* rest must be [] *) in
647 let (start_info
,_) = List.hd l
in
648 let (end_info
,_) = List.hd
(List.rev l
) in
649 (redo start_info
(logstart start_info
) (logend end_info
),
650 List.map
(function (_,x
) -> x
) l
))
654 let process_plus plus
:
655 (int * (Ast0.info * Ast.anything list list
) list
) list
=
659 List.map
find_neighbors (call_collect_plus (collect_context x
)))
662 (* --------------------------------------------------------------------- *)
663 (* --------------------------------------------------------------------- *)
666 let merge_one = function
667 (m1::m2::minus_info,p::plus_info) ->
669 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
670 if p > m1 && p < m2, then consider the following possibilities, in order
671 m1 is Good and favored: attach to the beginning of m1.aft
672 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
673 m1 is Good and unfavored: attach to the beginning of m1.aft
674 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
675 also flip m1.bef if the first where > m1
676 if we drop m1, then flip m1.aft first
678 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
681 (* end of first argument < start/end of second argument *)
682 let less_than_start info1 info2
=
683 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
684 let less_than_end info1 info2
=
685 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
686 let greater_than_end info1 info2
=
687 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
688 let good_start info = info.Ast0.attachable_start
689 let good_end info = info.Ast0.attachable_end
691 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
692 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
693 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
696 List.for_all
(List.for_all
(function Ast.Code
_ -> true | _ -> false))
698 (* The following is probably not correct. The idea is to detect what
699 should be placed completely before the declaration. So type/storage
700 related things do not fall into this category, and complete statements do
701 fall into this category. But perhaps other things should be in this
702 category as well, such as { or ;? *)
704 let tester = function
705 (* the following should definitely be true *)
711 | Ast.Pragma
_ -> true
712 (* the following should definitely be false *)
713 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
715 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
716 (* not sure about the rest *)
718 List.for_all
(List.for_all
tester)
720 let pr = Printf.sprintf
722 let insert thing thinginfo into intoinfo
=
723 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
724 let get_first l = (List.hd
l,List.tl
l) in
725 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
726 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
727 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
728 let into_start = intoinfo
.Ast0.tline_start
in
729 let into_end = intoinfo
.Ast0.tline_end
in
730 let into_left_offset = intoinfo
.Ast0.left_offset
in
731 let into_right_offset = intoinfo
.Ast0.right_offset
in
732 if thing_end < into_start && thing_start < into_start
734 {{intoinfo
with Ast0.tline_start
= thing_start}
735 with Ast0.left_offset
= thing_offset})
736 else if thing_end = into_start && thing_offset < into_left_offset
738 let (prev
,last
) = get_last thing
in
739 let (first
,rest
) = get_first into
in
740 (prev
@[last
@first
]@rest
,
741 {{intoinfo
with Ast0.tline_start
= thing_start}
742 with Ast0.left_offset
= thing_offset})
743 else if thing_start > into_end && thing_end > into_end
745 {{intoinfo
with Ast0.tline_end
= thing_end}
746 with Ast0.right_offset
= thing_offset})
747 else if thing_start = into_end && thing_offset > into_right_offset
749 let (first
,rest
) = get_first thing
in
750 let (prev
,last
) = get_last into
in
751 (prev
@[last
@first
]@rest
,
752 {{intoinfo
with Ast0.tline_end
= thing_end}
753 with Ast0.right_offset
= thing_offset})
756 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
757 thing_start thing_end into_start into_end;
758 Printf.printf
"thing offset %d left offset %d right offset %d\n"
759 thing_offset into_left_offset into_right_offset;
760 Pretty_print_cocci.print_anything
"" thing
;
761 Pretty_print_cocci.print_anything
"" into
;
762 failwith
"can't figure out where to put the + code"
765 let init thing
info =
767 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
768 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
769 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
770 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
772 let attachbefore (infop
,p
) = function
773 Ast0.MINUS
(replacements
) ->
774 (match !replacements
with
775 ([],ti
) -> replacements
:= init p infop
776 | (repl
,ti
) -> replacements
:= insert p infop repl ti
)
777 | Ast0.CONTEXT
(neighbors
) ->
778 let (repl
,ti1
,ti2
) = !neighbors
in
781 let (bef,ti1
) = insert p infop
bef ti1
in
782 neighbors
:= (Ast.BEFORE
(bef),ti1
,ti2
)
784 let (bef,ti1
) = init p infop
in
785 neighbors
:= (Ast.BEFOREAFTER
(bef,aft),ti1
,ti2
)
786 | Ast.BEFOREAFTER
(bef,aft) ->
787 let (bef,ti1
) = insert p infop
bef ti1
in
788 neighbors
:= (Ast.BEFOREAFTER
(bef,aft),ti1
,ti2
)
790 let (bef,ti1
) = init p infop
in
791 neighbors
:= (Ast.BEFORE
(bef),ti1
,ti2
))
792 | _ -> failwith
"not possible for attachbefore"
794 let attachafter (infop
,p
) = function
795 Ast0.MINUS
(replacements
) ->
796 (match !replacements
with
797 ([],ti
) -> replacements
:= init p infop
798 | (repl
,ti
) -> replacements
:= insert p infop repl ti
)
799 | Ast0.CONTEXT
(neighbors
) ->
800 let (repl
,ti1
,ti2
) = !neighbors
in
803 let (aft,ti2
) = init p infop
in
804 neighbors
:= (Ast.BEFOREAFTER
(bef,aft),ti1
,ti2
)
806 let (aft,ti2
) = insert p infop
aft ti2
in
807 neighbors
:= (Ast.AFTER
(aft),ti1
,ti2
)
808 | Ast.BEFOREAFTER
(bef,aft) ->
809 let (aft,ti2
) = insert p infop
aft ti2
in
810 neighbors
:= (Ast.BEFOREAFTER
(bef,aft),ti1
,ti2
)
812 let (aft,ti2
) = init p infop
in
813 neighbors
:= (Ast.AFTER
(aft),ti1
,ti2
))
814 | _ -> failwith
"not possible for attachbefore"
816 let attach_all_before ps m
=
817 List.iter
(function x
-> attachbefore x m
) ps
819 let attach_all_after ps m
=
820 List.iter
(function x
-> attachafter x m
) ps
822 let split_at_end info ps
=
823 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
825 (function (info,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
828 let allminus = function
829 Ast0.MINUS
(_) -> true
832 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
834 | (((infop
,_) as p
) :: ps
) as all
->
835 if less_than_start infop infom1
or
836 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
839 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
842 (pr "%d: no available token to attach to"
843 infop
.Ast0.pos_info
.Ast0.line_start
)
844 else after_m1 x1 x2 rest all
846 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
848 | (((infop
,pcode
) as p
) :: ps
) as all
->
849 (* if the following is false, then some + code is stuck in the middle
850 of some context code (m1). could drop down to the token level.
851 this might require adjustments in ast0toast as well, when + code on
852 expressions is dropped down to + code on expressions. it might
853 also break some invariants on which iso depends, particularly on
854 what it can infer from something being CONTEXT with no top-level
855 modifications. for the moment, we thus give an error, asking the
856 user to rewrite the semantic patch. *)
857 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
859 if less_than_start infop infom2
861 if predecl_code pcode
&& good_end infom1
&& decl f1
862 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
863 else if predecl_code pcode
&& good_start infom2
&& decl f2
864 then before_m2 x2 rest all
865 else if top_code pcode
&& good_end infom1
&& toplevel f1
866 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
867 else if top_code pcode
&& good_start infom2
&& toplevel f2
868 then before_m2 x2 rest all
869 else if good_end infom1
&& favored f1
870 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
871 else if good_start infom2
&& favored f2
872 then before_m2 x2 rest all
873 else if good_end infom1
874 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
875 else if good_start infom2
876 then before_m2 x2 rest all
879 (pr "%d: no available token to attach to"
880 infop
.Ast0.pos_info
.Ast0.line_start
)
881 else after_m2 x2 rest all
884 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
885 infop
.Ast0.pos_info
.Ast0.line_start
886 infop
.Ast0.pos_info
.Ast0.line_end
887 infom1
.Ast0.pos_info
.Ast0.line_start
888 infom1
.Ast0.pos_info
.Ast0.line_end
889 infom2
.Ast0.pos_info
.Ast0.line_start
890 infom2
.Ast0.pos_info
.Ast0.line_end
;
891 Pretty_print_cocci.print_anything
"" pcode
;
893 "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."
896 (* not sure this is safe. if have iso problems, consider changing this
897 to always return false *)
898 and is_minus
= function
902 and before_m2
((f2
,infom2
,m2
) as x2
) rest
903 (p
: (Ast0.info * Ast.anything list list
) list
) =
906 | ([],((infop
,_)::_)) ->
907 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
909 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
912 (pr "%d: no available token to attach to"
913 infop
.Ast0.pos_info
.Ast0.line_start
)
914 | (m
::ms
,_) -> before_m1 x2 m ms p
916 and after_m2
((f2
,infom2
,m2
) as x2
) rest
917 (p
: (Ast0.info * Ast.anything list list
) list
) =
920 | ([],((infop
,_)::_)) ->
922 then attach_all_after p m2
925 (pr "%d: no available token to attach to"
926 infop
.Ast0.pos_info
.Ast0.line_start
)
927 | (m
::ms
,_) -> after_m1 x2 m ms p
929 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
930 (Ast0.info * Ast.anything list list
) list
-> unit = function (m
,p
) ->
932 Printf.printf "minus code\n";
934 (function (_,info,_) ->
935 Printf.printf "start %d end %d real_start %d real_end %d\n"
936 info.Ast0.pos_info.Ast0.logical_start
937 info.Ast0.pos_info.Ast0.logical_end
938 info.Ast0.pos_info.Ast0.line_start
939 info.Ast0.pos_info.Ast0.line_end)
941 Printf.printf "plus code\n";
943 (function (info,p) ->
944 Printf.printf "start %d end %d real_start %d real_end %d\n"
945 info.Ast0.pos_info.Ast0.logical_start
946 info.Ast0.pos_info.Ast0.logical_end
947 info.Ast0.pos_info.Ast0.line_end
948 info.Ast0.pos_info.Ast0.line_end;
949 Pretty_print_cocci.print_anything "" p;
950 Format.print_newline())
955 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
956 | ([m
],p
) -> before_m2 m
[] p
957 | ([],_) -> failwith
"minus tree ran out before the plus tree"
959 let merge minus_list plus_list
=
961 Printf.printf "minus list %s\n"
963 (List.map (function (x,_) -> string_of_int x) minus_list));
964 Printf.printf "plus list %s\n"
966 (List.map (function (x,_) -> string_of_int x) plus_list));
969 (function (index,minus_info
) ->
970 let plus_info = List.assoc
index plus_list
in
971 merge_one (minus_info
,plus_info))
974 (* --------------------------------------------------------------------- *)
975 (* --------------------------------------------------------------------- *)
976 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
977 If they do, they become MIXED *)
979 let reevaluate_contextness =
981 let option_default = [] in
983 let mcode (_,_,_,mc
,_,_) =
985 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
990 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
993 let donothing r k e
=
994 match Ast0.get_mcodekind e
with
996 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
997 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
999 | _ -> let _ = k e
in [] in
1001 (* a case for everything with bef or aft *)
1003 match Ast0.unwrap e
with
1004 Ast0.Decl
(bef,decl) ->
1005 (info bef) @ (donothing r k e
)
1006 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1007 (info bef) @ (donothing r k e
)
1008 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1009 (donothing r k e
) @ (info aft)
1010 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1011 (donothing r k e
) @ (info aft)
1012 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1013 (donothing r k e
) @ (info aft)
1014 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1015 (donothing r k e
) @ (info aft)
1016 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1017 (donothing r k e
) @ (info aft)
1018 | _ -> donothing r k e
in
1021 V0.flat_combiner
bind option_default
1022 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1023 donothing donothing donothing donothing donothing donothing donothing
1025 donothing donothing donothing donothing stmt donothing donothing in
1026 res.VT0.combiner_rec_top_level
1028 (* --------------------------------------------------------------------- *)
1029 (* --------------------------------------------------------------------- *)
1031 let insert_plus minus plus ei
=
1033 let minus_stream = process_minus minus
in
1034 let plus_stream = process_plus plus
in
1035 merge minus_stream plus_stream;
1036 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus