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 (* The error message "no available token to attach to" often comes in an
28 argument list of unbounded length. In this case, one should move a comma so
29 that there is a comma after the + code. *)
31 (* Start at all of the corresponding BindContext nodes in the minus and
32 plus trees, and traverse their children. We take the same strategy as
33 before: collect the list of minus/context nodes/tokens and the list of plus
34 tokens, and then merge them. *)
36 module Ast
= Ast_cocci
37 module Ast0
= Ast0_cocci
38 module V0
= Visitor_ast0
39 module VT0
= Visitor_ast0_types
40 module CN
= Context_neg
42 let empty_isos = ref false
44 let get_option f
= function
48 (* --------------------------------------------------------------------- *)
49 (* Collect root and all context nodes in a tree *)
51 let collect_context e
=
52 let bind x y
= x
@ y
in
53 let option_default = [] in
57 let donothing builder r k e
=
58 match Ast0.get_mcodekind e
with
59 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
62 (* special case for everything that contains whencode, so that we skip over
64 let expression r k e
=
65 donothing Ast0.expr r k
67 (match Ast0.unwrap e
with
68 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
69 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
70 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
71 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
72 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
75 let initialiser r k i
=
76 donothing Ast0.ini r k
78 (match Ast0.unwrap i
with
79 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
83 donothing Ast0.stmt r k
85 (match Ast0.unwrap s
with
86 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
87 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
88 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
89 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
90 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
93 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
96 V0.flat_combiner
bind option_default
97 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
98 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
99 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
100 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
101 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
102 (donothing Ast0.param
) (donothing Ast0.decl
) statement
103 (donothing Ast0.case_line
) topfn in
104 res.VT0.combiner_rec_top_level e
106 (* --------------------------------------------------------------------- *)
107 (* --------------------------------------------------------------------- *)
108 (* collect the possible join points, in order, among the children of a
109 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
110 because their delimiters take up a line by themselves *)
112 (* An Unfavored token is one that is in a BindContext node; using this causes
113 the node to become Neither, meaning that isomorphisms can't be applied *)
114 (* Toplevel is for the bef token of a function declaration and is for
115 attaching top-level definitions that should come before the complete
117 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
119 (* Maps the index of a node to the indices of the mcodes it contains *)
120 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
122 let create_root_token_table minus
=
128 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
129 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
130 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
131 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
132 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
133 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
134 | Ast0.IdentTag
(d
) -> Ast0.get_index d
135 | Ast0.ExprTag
(d
) -> Ast0.get_index d
136 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
137 failwith
"not possible - iso only"
138 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
139 | Ast0.ParamTag
(d
) -> Ast0.get_index d
140 | Ast0.InitTag
(d
) -> Ast0.get_index d
141 | Ast0.DeclTag
(d
) -> Ast0.get_index d
142 | Ast0.StmtTag
(d
) -> Ast0.get_index d
143 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
144 | Ast0.TopTag
(d
) -> Ast0.get_index d
145 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
146 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
147 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
148 | Ast0.MetaPosTag
(p
) -> failwith
"not in plus code"
149 | Ast0.HiddenVarTag
(p
) -> failwith
"only within iso phase"
151 Hashtbl.add
root_token_table key tokens
)
155 let index = Ast0.get_index r
in
156 try let _ = Hashtbl.find
root_token_table index in ()
157 with Not_found
-> Hashtbl.add
root_token_table index [])
160 let collect_minus_join_points root
=
161 let root_index = Ast0.get_index root
in
162 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
163 let bind x y
= x
@ y
in
164 let option_default = [] in
166 let mcode (x
,_,info
,mcodekind
,_,_) =
167 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
168 then [(Unfavored
,info
,mcodekind
)]
169 else [(Favored
,info
,mcodekind
)] in
171 let do_nothing r k e
=
172 let info = Ast0.get_info e
in
173 let index = Ast0.get_index e
in
174 match Ast0.get_mcodekind e
with
175 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
176 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
177 (* This was unfavored at one point, but I don't remember why *)
181 (* don't want to attach to the outside of DOTS, because metavariables can't
182 bind to that; not good for isomorphisms *)
186 let rec loop = function
189 | x
::xs
-> bind x
(loop xs
) in
192 match Ast0.unwrap d
with
193 Ast0.DOTS
(l
) -> multibind (List.map f l
)
194 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
195 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
197 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
198 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
199 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
200 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
201 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
202 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
204 (* a case for everything that has a Opt *)
206 let statement r k s
=
208 let redo_branched res (ifinfo,aftmc) =
209 let redo fv info mc rest =
210 let new_info = {info with Ast0.attachable_end = false} in
211 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
212 match List.rev res with
215 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
216 (* even for -, better for isos not to integrate code after an
218 but the problem is that this can extend the region in
219 which a variable is bound, because a variable bound in the
220 aft node would seem to have to be live in the whole if,
221 whereas we might like it to be live in only one branch.
222 ie ideally, if we can keep the minus code in the right
223 order, we would like to drop it as close to the bindings
224 of its free variables. This could be anywhere in the minus
225 code. Perhaps we would like to do this after the
226 application of isomorphisms, though.
230 | (fv
,info,mc
)::rest
->
232 Ast0.CONTEXT
(_) -> redo fv
info mc rest
234 | _ -> failwith
"unexpected empty code" in *)
235 match Ast0.unwrap s
with
236 (* Ast0.IfThen(_,_,_,_,_,aft)
237 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
238 | Ast0.While(_,_,_,_,_,aft)
239 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
240 | Ast0.Iterator(_,_,_,_,_,aft) ->
241 redo_branched (do_nothing r k s) aft*)
242 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
243 (Toplevel
,info,bef
)::(k s
)
244 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
245 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
246 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
248 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
249 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
250 | Ast0.OptStm s
| Ast0.UniqueStm s
->
251 (* put the + code on the thing, not on the opt *)
252 r
.VT0.combiner_rec_statement s
253 | _ -> do_nothing r k s
in
255 let expression r k e
=
256 match Ast0.unwrap e
with
257 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
259 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
260 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
261 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
262 | Ast0.OptExp e
| Ast0.UniqueExp e
->
263 (* put the + code on the thing, not on the opt *)
264 r
.VT0.combiner_rec_expression e
265 | _ -> do_nothing r k e
in
268 match Ast0.unwrap e
with
269 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
270 (* put the + code on the thing, not on the opt *)
271 r
.VT0.combiner_rec_ident i
272 | _ -> do_nothing r k e
in
275 match Ast0.unwrap e
with
276 Ast0.OptType t
| Ast0.UniqueType t
->
277 (* put the + code on the thing, not on the opt *)
278 r
.VT0.combiner_rec_typeC t
279 | _ -> do_nothing r k e
in
282 match Ast0.unwrap e
with
283 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
284 (* put the + code on the thing, not on the opt *)
285 r
.VT0.combiner_rec_declaration d
286 | _ -> do_nothing r k e
in
288 let initialiser r k e
=
289 match Ast0.unwrap e
with
290 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
291 | Ast0.OptIni i
| Ast0.UniqueIni i
->
292 (* put the + code on the thing, not on the opt *)
293 r
.VT0.combiner_rec_initialiser i
294 | _ -> do_nothing r k e
in
297 match Ast0.unwrap e
with
298 Ast0.OptParam p
| Ast0.UniqueParam p
->
299 (* put the + code on the thing, not on the opt *)
300 r
.VT0.combiner_rec_parameter p
301 | _ -> do_nothing r k e
in
303 let case_line r k e
=
304 match Ast0.unwrap e
with
306 (* put the + code on the thing, not on the opt *)
307 r
.VT0.combiner_rec_case_line c
308 | _ -> do_nothing r k e
in
310 let do_top r k
(e
: Ast0.top_level
) = k e
in
312 V0.flat_combiner
bind option_default
313 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
314 edots idots pdots sdots ddots cdots
315 ident expression typeC initialiser param decl statement case_line do_top
318 let call_collect_minus context_nodes
:
319 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
323 Ast0.DotsExprTag
(e
) ->
325 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
326 | Ast0.DotsInitTag
(e
) ->
328 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
329 | Ast0.DotsParamTag
(e
) ->
331 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
332 | Ast0.DotsStmtTag
(e
) ->
334 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
335 | Ast0.DotsDeclTag
(e
) ->
337 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
338 | Ast0.DotsCaseTag
(e
) ->
340 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
341 | Ast0.IdentTag
(e
) ->
343 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
346 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
347 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
348 failwith
"not possible - iso only"
349 | Ast0.TypeCTag
(e
) ->
351 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
352 | Ast0.ParamTag
(e
) ->
354 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
357 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
360 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
363 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
364 | Ast0.CaseLineTag
(e
) ->
366 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
369 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
370 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
371 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
372 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
373 | Ast0.MetaPosTag
(p
) -> failwith
"not in plus code"
374 | Ast0.HiddenVarTag
(p
) -> failwith
"only within iso phase")
377 (* result of collecting the join points should be sorted in nondecreasing
380 let get_info = function
381 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
382 | (Decl
,info,_) -> info in
383 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
384 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
385 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
386 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
389 (index,((_::_) as l1
)) ->
392 (function (prev
,real_prev
) ->
394 let ln = token_start_line cur
in
399 "error in collection of - tokens: line %d less than line %d"
400 (token_real_start_line cur
) real_prev
);
401 (token_end_line cur
,token_real_end_line cur
))
402 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
405 | _ -> ()) (* dots, in eg f() has no join points *)
408 let process_minus minus
=
409 Hashtbl.clear
root_token_table;
410 create_root_token_table minus
;
414 let res = call_collect_minus (collect_context x
) in
419 (* --------------------------------------------------------------------- *)
420 (* --------------------------------------------------------------------- *)
421 (* collect the plus tokens *)
423 let mk_structUnion x
= Ast.StructUnionTag x
424 let mk_sign x
= Ast.SignTag x
425 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
426 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
427 let mk_constant x
= Ast.ConstantTag x
428 let mk_unaryOp x
= Ast.UnaryOpTag x
429 let mk_assignOp x
= Ast.AssignOpTag x
430 let mk_fixOp x
= Ast.FixOpTag x
431 let mk_binaryOp x
= Ast.BinaryOpTag x
432 let mk_arithOp x
= Ast.ArithOpTag x
433 let mk_logicalOp x
= Ast.LogicalOpTag x
434 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
435 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
436 let mk_storage x
= Ast.StorageTag x
437 let mk_inc_file x
= Ast.IncFileTag x
438 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
439 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
440 let mk_const_vol x
= Ast.ConstVolTag x
441 let mk_token x
info = Ast.Token
(x
,Some
info)
442 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
443 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
445 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
446 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
447 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
448 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
449 let mk_casedots x
= failwith
"+ case lines not supported"
450 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC false x
)
451 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
452 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
454 let collect_plus_nodes root
=
455 let root_index = Ast0.get_index root
in
457 let bind x y
= x
@ y
in
458 let option_default = [] in
460 let extract_strings info =
462 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
463 let extract = function
466 let (_,first
) = List.hd strings_before
in
467 let (_,last
) = List.hd
(List.rev strings_before
) in
469 {Ast0.line_start
= first
.Ast0.line_start
;
470 Ast0.line_end
= last
.Ast0.line_start
;
471 Ast0.logical_start
= first
.Ast0.logical_start
;
472 Ast0.logical_end
= last
.Ast0.logical_start
;
473 Ast0.column
= first
.Ast0.column
;
474 Ast0.offset
= first
.Ast0.offset
} in
475 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
476 let string = List.map
(function (s
,_) -> s
) strings_before
in
477 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
478 let bef = extract info.Ast0.strings_before
in
479 let aft = extract info.Ast0.strings_after
in
482 let mcode fn
(term
,_,info,mcodekind
,_,_) =
484 Ast0.PLUS c
-> [(info,c
,fn term
)]
485 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
488 let imcode fn
(term
,_,info,mcodekind
,_,_) =
490 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
491 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
494 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
496 let do_nothing fn r k e
=
497 match Ast0.get_mcodekind e
with
498 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
499 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
502 (* case for everything that is just a wrapper for a simpler thing *)
503 (* case for things with bef aft *)
505 match Ast0.unwrap e
with
506 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
507 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
508 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
509 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
510 | Ast0.Decl
(bef,decl) ->
511 (info bef) @ (do_nothing mk_statement r k e
)
512 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
513 (info bef) @ (do_nothing mk_statement r k e
)
514 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
515 (do_nothing mk_statement r k e
) @ (info aft)
516 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
517 (do_nothing mk_statement r k e
) @ (info aft)
518 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
519 (do_nothing mk_statement r k e
) @ (info aft)
520 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
521 (do_nothing mk_statement r k e
) @ (info aft)
522 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
523 (do_nothing mk_statement r k e
) @ (info aft)
524 | _ -> do_nothing mk_statement r k e
in
526 (* statementTag is preferred, because it indicates that one statement is
527 replaced by one statement, in single_statement *)
528 let stmt_dots r k e
=
529 match Ast0.unwrap e
with
530 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
531 r
.VT0.combiner_rec_statement s
532 | _ -> do_nothing mk_stmtdots r k e
in
535 match Ast0.unwrap e
with
536 Ast0.NONDECL
(s
) -> r
.VT0.combiner_rec_statement s
537 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
538 | _ -> do_nothing mk_code r k e
in
540 let initdots r k e
= k e
in
542 V0.flat_combiner
bind option_default
543 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
545 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
546 (mcode mk_sign) (mcode mk_structUnion)
547 (mcode mk_storage) (mcode mk_inc_file)
548 (do_nothing mk_exprdots) initdots
549 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
550 (do_nothing mk_casedots)
551 (do_nothing mk_ident) (do_nothing mk_expression)
552 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
553 (do_nothing mk_declaration)
554 stmt (do_nothing mk_case_line) toplevel
556 let call_collect_plus context_nodes
:
557 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
561 Ast0.DotsExprTag
(e
) ->
563 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
564 | Ast0.DotsInitTag
(e
) ->
566 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
567 | Ast0.DotsParamTag
(e
) ->
569 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
570 | Ast0.DotsStmtTag
(e
) ->
572 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
573 | Ast0.DotsDeclTag
(e
) ->
575 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
576 | Ast0.DotsCaseTag
(e
) ->
578 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
579 | Ast0.IdentTag
(e
) ->
581 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
584 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
585 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
586 failwith
"not possible - iso only"
587 | Ast0.TypeCTag
(e
) ->
589 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
592 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
593 | Ast0.ParamTag
(e
) ->
595 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
598 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
601 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
602 | Ast0.CaseLineTag
(e
) ->
604 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
607 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
608 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
609 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
610 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
611 | Ast0.MetaPosTag
(p
) -> failwith
"not visible here"
612 | Ast0.HiddenVarTag
(_) -> failwith
"only within iso phase")
615 (* The plus fragments are converted to a list of lists of lists.
616 Innermost list: Elements have type anything. For any pair of successive
617 elements, n and n+1, the ending line of n is the same as the starting line
619 Middle lists: For any pair of successive elements, n and n+1, the ending
620 line of n is one less than the starting line of n+1.
621 Outer list: For any pair of successive elements, n and n+1, the ending
622 line of n is more than one less than the starting line of n+1. *)
624 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
625 let logend info = info.Ast0.pos_info
.Ast0.logical_end
627 let redo info start finish
=
629 {info.Ast0.pos_info
with
630 Ast0.logical_start
= start
;
631 Ast0.logical_end
= finish
} in
632 {info with Ast0.pos_info
= new_pos_info}
634 let rec find_neighbors (index,l
) :
635 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
636 let rec loop = function
639 (match loop rest
with
640 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
641 let finish1 = logend i
in
642 let start2 = logstart i1
in
645 ((if not
(c
= c1
) then failwith
"inconsistent + code");
646 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
649 else if finish1 + 1 = start2
650 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
652 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
653 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
657 let (start_info
,start_count
,_) = List.hd l
in
658 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
659 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
660 (redo start_info
(logstart start_info
) (logend end_info
),
662 List.map
(function (_,_,x
) -> x
) l
))
666 let process_plus plus
:
667 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
671 List.map
find_neighbors (call_collect_plus (collect_context x
)))
674 (* --------------------------------------------------------------------- *)
675 (* --------------------------------------------------------------------- *)
678 let merge_one = function
679 (m1::m2::minus_info,p::plus_info) ->
681 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
682 if p > m1 && p < m2, then consider the following possibilities, in order
683 m1 is Good and favored: attach to the beginning of m1.aft
684 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
685 m1 is Good and unfavored: attach to the beginning of m1.aft
686 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
687 also flip m1.bef if the first where > m1
688 if we drop m1, then flip m1.aft first
690 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
693 (* end of first argument < start/end of second argument *)
694 let less_than_start info1 info2
=
695 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
696 let less_than_end info1 info2
=
697 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
698 let greater_than_end info1 info2
=
699 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
700 let good_start info = info.Ast0.attachable_start
701 let good_end info = info.Ast0.attachable_end
703 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
704 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
705 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
709 (List.for_all
(function Ast.Code
_ | Ast.Pragma
_ -> true | _ -> false))
713 (List.for_all
(function Ast.StorageTag
_ -> true | _ -> false))
715 (* The following is probably not correct. The idea is to detect what
716 should be placed completely before the declaration. So type/storage
717 related things do not fall into this category, and complete statements do
718 fall into this category. But perhaps other things should be in this
719 category as well, such as { or ;? *)
721 let tester = function
722 (* the following should definitely be true *)
728 | Ast.Pragma
_ -> true
729 (* the following should definitely be false *)
730 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
732 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
733 (* not sure about the rest *)
735 List.for_all
(List.for_all
tester)
737 let pr = Printf.sprintf
739 let insert thing thinginfo into intoinfo
=
740 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
741 let get_first l = (List.hd
l,List.tl
l) in
742 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
743 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
744 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
745 let into_start = intoinfo
.Ast0.tline_start
in
746 let into_end = intoinfo
.Ast0.tline_end
in
747 let into_left_offset = intoinfo
.Ast0.left_offset
in
748 let into_right_offset = intoinfo
.Ast0.right_offset
in
749 if thing_end < into_start && thing_start < into_start
751 {{intoinfo
with Ast0.tline_start
= thing_start}
752 with Ast0.left_offset
= thing_offset})
753 else if thing_end = into_start && thing_offset < into_left_offset
755 let (prev
,last
) = get_last thing
in
756 let (first
,rest
) = get_first into
in
757 (prev
@[last
@first
]@rest
,
758 {{intoinfo
with Ast0.tline_start
= thing_start}
759 with Ast0.left_offset
= thing_offset})
760 else if thing_start > into_end && thing_end > into_end
762 {{intoinfo
with Ast0.tline_end
= thing_end}
763 with Ast0.right_offset
= thing_offset})
764 else if thing_start = into_end && thing_offset > into_right_offset
766 let (first
,rest
) = get_first thing
in
767 let (prev
,last
) = get_last into
in
768 (prev
@[last
@first
]@rest
,
769 {{intoinfo
with Ast0.tline_end
= thing_end}
770 with Ast0.right_offset
= thing_offset})
773 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
774 thing_start thing_end into_start into_end;
775 Printf.printf
"thing offset %d left offset %d right offset %d\n"
776 thing_offset into_left_offset into_right_offset;
777 Pretty_print_cocci.print_anything
"" thing
;
778 Pretty_print_cocci.print_anything
"" into
;
779 failwith
"can't figure out where to put the + code"
782 let init thing
info =
784 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
785 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
786 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
787 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
789 let it2c = function Ast.ONE
-> "one" | Ast.MANY
-> "many"
791 let attachbefore (infop
,c
,p
) = function
792 Ast0.MINUS
(replacements
) ->
793 let (repl
,ti
) = !replacements
in
796 let (bef,ti
) = init p infop
in
797 replacements
:= (Ast.REPLACEMENT
(bef,c
),ti
)
798 | Ast.REPLACEMENT
(repl
,it
) ->
799 let it = Ast.lub_count
it c
in
800 let (bef,ti
) = insert p infop repl ti
in
801 replacements
:= (Ast.REPLACEMENT
(bef,it),ti
))
802 | Ast0.CONTEXT
(neighbors
) ->
803 let (repl
,ti1
,ti2
) = !neighbors
in
805 Ast.BEFORE
(bef,it) ->
806 let (bef,ti1
) = insert p infop
bef ti1
in
807 let it = Ast.lub_count
it c
in
808 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
809 | Ast.AFTER
(aft,it) ->
810 let (bef,ti1
) = init p infop
in
811 let it = Ast.lub_count
it c
in
812 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
813 | Ast.BEFOREAFTER
(bef,aft,it) ->
814 let (bef,ti1
) = insert p infop
bef ti1
in
815 let it = Ast.lub_count
it c
in
816 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
818 let (bef,ti1
) = init p infop
in
819 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
820 | _ -> failwith
"not possible for attachbefore"
822 let attachafter (infop
,c
,p
) = function
823 Ast0.MINUS
(replacements
) ->
824 let (repl
,ti
) = !replacements
in
827 let (aft,ti
) = init p infop
in
828 replacements
:= (Ast.REPLACEMENT
(aft,c
),ti
)
829 | Ast.REPLACEMENT
(repl
,it) ->
830 let it = Ast.lub_count
it c
in
831 let (aft,ti
) = insert p infop repl ti
in
832 replacements
:= (Ast.REPLACEMENT
(aft,it),ti
))
833 | Ast0.CONTEXT
(neighbors
) ->
834 let (repl
,ti1
,ti2
) = !neighbors
in
836 Ast.BEFORE
(bef,it) ->
837 let (aft,ti2
) = init p infop
in
838 let it = Ast.lub_count
it c
in
839 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
840 | Ast.AFTER
(aft,it) ->
841 let (aft,ti2
) = insert p infop
aft ti2
in
842 let it = Ast.lub_count
it c
in
843 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
844 | Ast.BEFOREAFTER
(bef,aft,it) ->
845 let (aft,ti2
) = insert p infop
aft ti2
in
846 let it = Ast.lub_count
it c
in
847 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
849 let (aft,ti2
) = init p infop
in
850 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
851 | _ -> failwith
"not possible for attachbefore"
853 let attach_all_before ps m
=
854 List.iter
(function x
-> attachbefore x m
) ps
856 let attach_all_after ps m
=
857 List.iter
(function x
-> attachafter x m
) ps
859 let split_at_end info ps
=
860 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
862 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
865 let allminus = function
866 Ast0.MINUS
(_) -> true
869 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
871 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
872 if less_than_start infop infom1
or
873 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
877 if storage_code pcode
878 then before_m2 x2 rest all
(* skip fake token for storage *)
879 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
882 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
885 (pr "%d: no available token to attach to"
886 infop
.Ast0.pos_info
.Ast0.line_start
)
887 else after_m1 x1 x2 rest all
889 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
891 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
892 (* if the following is false, then some + code is stuck in the middle
893 of some context code (m1). could drop down to the token level.
894 this might require adjustments in ast0toast as well, when + code on
895 expressions is dropped down to + code on expressions. it might
896 also break some invariants on which iso depends, particularly on
897 what it can infer from something being CONTEXT with no top-level
898 modifications. for the moment, we thus give an error, asking the
899 user to rewrite the semantic patch. *)
900 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
902 if less_than_start infop infom2
904 if predecl_code pcode
&& good_end infom1
&& decl f1
905 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
906 else if predecl_code pcode
&& good_start infom2
&& decl f2
907 then before_m2 x2 rest all
908 else if top_code pcode
&& good_end infom1
&& toplevel f1
909 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
910 else if top_code pcode
&& good_start infom2
&& toplevel f2
911 then before_m2 x2 rest all
912 else if good_end infom1
&& favored f1
913 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
914 else if good_start infom2
&& favored f2
915 then before_m2 x2 rest all
916 else if good_end infom1
917 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
918 else if good_start infom2
919 then before_m2 x2 rest all
922 (pr "%d: no available token to attach to"
923 infop
.Ast0.pos_info
.Ast0.line_start
)
924 else after_m2 x2 rest all
927 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
928 infop
.Ast0.pos_info
.Ast0.line_start
929 infop
.Ast0.pos_info
.Ast0.line_end
930 infom1
.Ast0.pos_info
.Ast0.line_start
931 infom1
.Ast0.pos_info
.Ast0.line_end
932 infom2
.Ast0.pos_info
.Ast0.line_start
933 infom2
.Ast0.pos_info
.Ast0.line_end
;
934 Pretty_print_cocci.print_anything
"" pcode
;
936 "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."
939 (* not sure this is safe. if have iso problems, consider changing this
940 to always return false *)
941 and is_minus
= function
945 and before_m2
((f2
,infom2
,m2
) as x2
) rest
946 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
949 | ([],((infop
,_,_)::_)) ->
950 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
952 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
955 (pr "%d: no available token to attach to"
956 infop
.Ast0.pos_info
.Ast0.line_start
)
957 | (m
::ms
,_) -> before_m1 x2 m ms p
959 and after_m2
((f2
,infom2
,m2
) as x2
) rest
960 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
963 | ([],((infop
,_,_)::_)) ->
965 then attach_all_after p m2
968 (pr "%d: no available token to attach to"
969 infop
.Ast0.pos_info
.Ast0.line_start
)
970 | (m
::ms
,_) -> after_m1 x2 m ms p
972 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
973 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
976 Printf.printf "minus code\n";
978 (function (_,info,_) ->
980 "start %d end %d real_start %d real_end %d attachable start %b attachable end %b\n"
981 info.Ast0.pos_info.Ast0.logical_start
982 info.Ast0.pos_info.Ast0.logical_end
983 info.Ast0.pos_info.Ast0.line_start
984 info.Ast0.pos_info.Ast0.line_end
985 info.Ast0.attachable_start
986 info.Ast0.attachable_end)
988 Printf.printf "plus code\n";
990 (function (info,_,p) ->
991 Printf.printf "start %d end %d real_start %d real_end %d\n"
992 info.Ast0.pos_info.Ast0.logical_start
993 info.Ast0.pos_info.Ast0.logical_end
994 info.Ast0.pos_info.Ast0.line_end
995 info.Ast0.pos_info.Ast0.line_end;
996 Pretty_print_cocci.print_anything "" p;
997 Format.print_newline())
1002 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
1003 | ([m
],p
) -> before_m2 m
[] p
1004 | ([],_) -> failwith
"minus tree ran out before the plus tree"
1006 let merge minus_list plus_list
=
1008 Printf.printf "minus list %s\n"
1010 (List.map (function (x,_) -> string_of_int x) minus_list));
1011 Printf.printf "plus list %s\n"
1013 (List.map (function (x,_) -> string_of_int x) plus_list));
1016 (function (index,minus_info
) ->
1017 let plus_info = List.assoc
index plus_list
in
1018 merge_one (minus_info
,plus_info))
1021 (* --------------------------------------------------------------------- *)
1022 (* --------------------------------------------------------------------- *)
1023 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1024 If they do, they become MIXED *)
1026 let reevaluate_contextness =
1028 let option_default = [] in
1030 let mcode (_,_,_,mc
,_,_) =
1032 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1037 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1040 let donothing r k e
=
1041 match Ast0.get_mcodekind e
with
1043 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1044 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1046 | _ -> let _ = k e
in [] in
1048 (* a case for everything with bef or aft *)
1050 match Ast0.unwrap e
with
1051 Ast0.Decl
(bef,decl) ->
1052 (info bef) @ (donothing r k e
)
1053 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1054 (info bef) @ (donothing r k e
)
1055 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1056 (donothing r k e
) @ (info aft)
1057 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1058 (donothing r k e
) @ (info aft)
1059 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1060 (donothing r k e
) @ (info aft)
1061 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1062 (donothing r k e
) @ (info aft)
1063 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1064 (donothing r k e
) @ (info aft)
1065 | _ -> donothing r k e
in
1068 V0.flat_combiner
bind option_default
1069 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1070 donothing donothing donothing donothing donothing donothing donothing
1072 donothing donothing donothing donothing stmt donothing donothing in
1073 res.VT0.combiner_rec_top_level
1075 (* --------------------------------------------------------------------- *)
1076 (* --------------------------------------------------------------------- *)
1078 let insert_plus minus plus ei
=
1080 let minus_stream = process_minus minus
in
1081 let plus_stream = process_plus plus
in
1082 merge minus_stream plus_stream;
1083 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus