2 * Copyright 2010, INRIA, University of Copenhagen
3 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
4 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
5 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
6 * This file is part of Coccinelle.
8 * Coccinelle is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, according to version 2 of the License.
12 * Coccinelle is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
20 * The authors reserve the right to distribute this or future versions of
21 * Coccinelle under other licenses.
25 (* The error message "no available token to attach to" often comes in an
26 argument list of unbounded length. In this case, one should move a comma so
27 that there is a comma after the + code. *)
29 (* Start at all of the corresponding BindContext nodes in the minus and
30 plus trees, and traverse their children. We take the same strategy as
31 before: collect the list of minus/context nodes/tokens and the list of plus
32 tokens, and then merge them. *)
34 module Ast
= Ast_cocci
35 module Ast0
= Ast0_cocci
36 module V0
= Visitor_ast0
37 module VT0
= Visitor_ast0_types
38 module CN
= Context_neg
40 let empty_isos = ref false
42 let get_option f
= function
46 (* --------------------------------------------------------------------- *)
47 (* Collect root and all context nodes in a tree *)
49 let collect_context e
=
50 let bind x y
= x
@ y
in
51 let option_default = [] in
55 let donothing builder r k e
=
56 match Ast0.get_mcodekind e
with
57 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
60 (* special case for everything that contains whencode, so that we skip over
62 let expression r k e
=
63 donothing Ast0.expr r k
65 (match Ast0.unwrap e
with
66 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
67 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
68 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
69 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
70 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
73 let initialiser r k i
=
74 donothing Ast0.ini r k
76 (match Ast0.unwrap i
with
77 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
81 donothing Ast0.stmt r k
83 (match Ast0.unwrap s
with
84 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
85 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
86 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
87 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
88 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
91 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
94 V0.flat_combiner
bind option_default
95 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
96 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
97 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
98 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
99 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
100 (donothing Ast0.param
) (donothing Ast0.decl
) statement
101 (donothing Ast0.case_line
) topfn in
102 res.VT0.combiner_rec_top_level e
104 (* --------------------------------------------------------------------- *)
105 (* --------------------------------------------------------------------- *)
106 (* collect the possible join points, in order, among the children of a
107 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
108 because their delimiters take up a line by themselves *)
110 (* An Unfavored token is one that is in a BindContext node; using this causes
111 the node to become Neither, meaning that isomorphisms can't be applied *)
112 (* Toplevel is for the bef token of a function declaration and is for
113 attaching top-level definitions that should come before the complete
115 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
117 (* Maps the index of a node to the indices of the mcodes it contains *)
118 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
120 let create_root_token_table minus
=
126 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
127 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
128 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
129 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
130 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
131 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
132 | Ast0.IdentTag
(d
) -> Ast0.get_index d
133 | Ast0.ExprTag
(d
) -> Ast0.get_index d
134 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
135 failwith
"not possible - iso only"
136 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
137 | Ast0.ParamTag
(d
) -> Ast0.get_index d
138 | Ast0.InitTag
(d
) -> Ast0.get_index d
139 | Ast0.DeclTag
(d
) -> Ast0.get_index d
140 | Ast0.StmtTag
(d
) -> Ast0.get_index d
141 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
142 | Ast0.TopTag
(d
) -> Ast0.get_index d
143 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
144 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
145 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
146 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
148 Hashtbl.add
root_token_table key tokens
)
152 let index = Ast0.get_index r
in
153 try let _ = Hashtbl.find
root_token_table index in ()
154 with Not_found
-> Hashtbl.add
root_token_table index [])
157 let collect_minus_join_points root
=
158 let root_index = Ast0.get_index root
in
159 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
160 let bind x y
= x
@ y
in
161 let option_default = [] in
163 let mcode (x
,_,info
,mcodekind
,_,_) =
164 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
165 then [(Unfavored
,info
,mcodekind
)]
166 else [(Favored
,info
,mcodekind
)] in
168 let do_nothing r k e
=
169 let info = Ast0.get_info e
in
170 let index = Ast0.get_index e
in
171 match Ast0.get_mcodekind e
with
172 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
173 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
174 (* This was unfavored at one point, but I don't remember why *)
178 (* don't want to attach to the outside of DOTS, because metavariables can't
179 bind to that; not good for isomorphisms *)
183 let rec loop = function
186 | x
::xs
-> bind x
(loop xs
) in
189 match Ast0.unwrap d
with
190 Ast0.DOTS
(l
) -> multibind (List.map f l
)
191 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
192 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
194 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
195 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
196 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
197 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
198 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
199 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
201 (* a case for everything that has a Opt *)
203 let statement r k s
=
205 let redo_branched res (ifinfo,aftmc) =
206 let redo fv info mc rest =
207 let new_info = {info with Ast0.attachable_end = false} in
208 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
209 match List.rev res with
212 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
213 (* even for -, better for isos not to integrate code after an
215 but the problem is that this can extend the region in
216 which a variable is bound, because a variable bound in the
217 aft node would seem to have to be live in the whole if,
218 whereas we might like it to be live in only one branch.
219 ie ideally, if we can keep the minus code in the right
220 order, we would like to drop it as close to the bindings
221 of its free variables. This could be anywhere in the minus
222 code. Perhaps we would like to do this after the
223 application of isomorphisms, though.
227 | (fv
,info,mc
)::rest
->
229 Ast0.CONTEXT
(_) -> redo fv
info mc rest
231 | _ -> failwith
"unexpected empty code" in *)
232 match Ast0.unwrap s
with
233 (* Ast0.IfThen(_,_,_,_,_,aft)
234 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
235 | Ast0.While(_,_,_,_,_,aft)
236 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
237 | Ast0.Iterator(_,_,_,_,_,aft) ->
238 redo_branched (do_nothing r k s) aft*)
239 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
240 (Toplevel
,info,bef
)::(k s
)
241 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
242 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
243 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
245 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
246 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
247 | Ast0.OptStm s
| Ast0.UniqueStm s
->
248 (* put the + code on the thing, not on the opt *)
249 r
.VT0.combiner_rec_statement s
250 | _ -> do_nothing r k s
in
252 let expression r k e
=
253 match Ast0.unwrap e
with
254 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
256 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
257 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
258 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
259 | Ast0.OptExp e
| Ast0.UniqueExp e
->
260 (* put the + code on the thing, not on the opt *)
261 r
.VT0.combiner_rec_expression e
262 | _ -> do_nothing r k e
in
265 match Ast0.unwrap e
with
266 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
267 (* put the + code on the thing, not on the opt *)
268 r
.VT0.combiner_rec_ident i
269 | _ -> do_nothing r k e
in
272 match Ast0.unwrap e
with
273 Ast0.OptType t
| Ast0.UniqueType t
->
274 (* put the + code on the thing, not on the opt *)
275 r
.VT0.combiner_rec_typeC t
276 | _ -> do_nothing r k e
in
279 match Ast0.unwrap e
with
280 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
281 (* put the + code on the thing, not on the opt *)
282 r
.VT0.combiner_rec_declaration d
283 | _ -> do_nothing r k e
in
285 let initialiser r k e
=
286 match Ast0.unwrap e
with
287 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
288 | Ast0.OptIni i
| Ast0.UniqueIni i
->
289 (* put the + code on the thing, not on the opt *)
290 r
.VT0.combiner_rec_initialiser i
291 | _ -> do_nothing r k e
in
294 match Ast0.unwrap e
with
295 Ast0.OptParam p
| Ast0.UniqueParam p
->
296 (* put the + code on the thing, not on the opt *)
297 r
.VT0.combiner_rec_parameter p
298 | _ -> do_nothing r k e
in
300 let case_line r k e
=
301 match Ast0.unwrap e
with
303 (* put the + code on the thing, not on the opt *)
304 r
.VT0.combiner_rec_case_line c
305 | _ -> do_nothing r k e
in
307 let do_top r k
(e
: Ast0.top_level
) = k e
in
309 V0.flat_combiner
bind option_default
310 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
311 edots idots pdots sdots ddots cdots
312 ident expression typeC initialiser param decl statement case_line do_top
315 let call_collect_minus context_nodes
:
316 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
320 Ast0.DotsExprTag
(e
) ->
322 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
323 | Ast0.DotsInitTag
(e
) ->
325 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
326 | Ast0.DotsParamTag
(e
) ->
328 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
329 | Ast0.DotsStmtTag
(e
) ->
331 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
332 | Ast0.DotsDeclTag
(e
) ->
334 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
335 | Ast0.DotsCaseTag
(e
) ->
337 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
338 | Ast0.IdentTag
(e
) ->
340 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
343 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
344 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
345 failwith
"not possible - iso only"
346 | Ast0.TypeCTag
(e
) ->
348 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
349 | Ast0.ParamTag
(e
) ->
351 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
354 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
357 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
360 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
361 | Ast0.CaseLineTag
(e
) ->
363 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
366 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
367 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
368 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
369 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
370 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
373 (* result of collecting the join points should be sorted in nondecreasing
376 let get_info = function
377 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
378 | (Decl
,info,_) -> info in
379 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
380 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
381 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
382 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
385 (index,((_::_) as l1
)) ->
388 (function (prev
,real_prev
) ->
390 let ln = token_start_line cur
in
395 "error in collection of - tokens: line %d less than line %d"
396 (token_real_start_line cur
) real_prev
);
397 (token_end_line cur
,token_real_end_line cur
))
398 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
401 | _ -> ()) (* dots, in eg f() has no join points *)
404 let process_minus minus
=
405 create_root_token_table minus
;
409 let res = call_collect_minus (collect_context x
) in
414 (* --------------------------------------------------------------------- *)
415 (* --------------------------------------------------------------------- *)
416 (* collect the plus tokens *)
418 let mk_structUnion x
= Ast.StructUnionTag x
419 let mk_sign x
= Ast.SignTag x
420 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
421 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
422 let mk_constant x
= Ast.ConstantTag x
423 let mk_unaryOp x
= Ast.UnaryOpTag x
424 let mk_assignOp x
= Ast.AssignOpTag x
425 let mk_fixOp x
= Ast.FixOpTag x
426 let mk_binaryOp x
= Ast.BinaryOpTag x
427 let mk_arithOp x
= Ast.ArithOpTag x
428 let mk_logicalOp x
= Ast.LogicalOpTag x
429 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
430 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
431 let mk_storage x
= Ast.StorageTag x
432 let mk_inc_file x
= Ast.IncFileTag x
433 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
434 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
435 let mk_const_vol x
= Ast.ConstVolTag x
436 let mk_token x
info = Ast.Token
(x
,Some
info)
437 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
438 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
440 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
441 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
442 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
443 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
444 let mk_casedots x
= failwith
"+ case lines not supported"
445 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
446 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
447 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
449 let collect_plus_nodes root
=
450 let root_index = Ast0.get_index root
in
452 let bind x y
= x
@ y
in
453 let option_default = [] in
455 let extract_strings info =
457 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
458 let extract = function
461 let (_,first
) = List.hd strings_before
in
462 let (_,last
) = List.hd
(List.rev strings_before
) in
464 {Ast0.line_start
= first
.Ast0.line_start
;
465 Ast0.line_end
= last
.Ast0.line_start
;
466 Ast0.logical_start
= first
.Ast0.logical_start
;
467 Ast0.logical_end
= last
.Ast0.logical_start
;
468 Ast0.column
= first
.Ast0.column
;
469 Ast0.offset
= first
.Ast0.offset
} in
470 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
471 let string = List.map
(function (s
,_) -> s
) strings_before
in
472 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
473 let bef = extract info.Ast0.strings_before
in
474 let aft = extract info.Ast0.strings_after
in
477 let mcode fn
(term
,_,info,mcodekind
,_,_) =
479 Ast0.PLUS c
-> [(info,c
,fn term
)]
480 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
483 let imcode fn
(term
,_,info,mcodekind
,_,_) =
485 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
486 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
489 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
491 let do_nothing fn r k e
=
492 match Ast0.get_mcodekind e
with
493 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
494 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
497 (* case for everything that is just a wrapper for a simpler thing *)
498 (* case for things with bef aft *)
500 match Ast0.unwrap e
with
501 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
502 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
503 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
504 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
505 | Ast0.Decl
(bef,decl) ->
506 (info bef) @ (do_nothing mk_statement r k e
)
507 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
508 (info bef) @ (do_nothing mk_statement r k e
)
509 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
510 (do_nothing mk_statement r k e
) @ (info aft)
511 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
512 (do_nothing mk_statement r k e
) @ (info aft)
513 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
514 (do_nothing mk_statement r k e
) @ (info aft)
515 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
516 (do_nothing mk_statement r k e
) @ (info aft)
517 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
518 (do_nothing mk_statement r k e
) @ (info aft)
519 | _ -> do_nothing mk_statement r k e
in
521 (* statementTag is preferred, because it indicates that one statement is
522 replaced by one statement, in single_statement *)
523 let stmt_dots r k e
=
524 match Ast0.unwrap e
with
525 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
526 r
.VT0.combiner_rec_statement s
527 | _ -> do_nothing mk_stmtdots r k e
in
530 match Ast0.unwrap e
with
531 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
532 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
533 | _ -> do_nothing mk_code r k e
in
535 let initdots r k e
= k e
in
537 V0.flat_combiner
bind option_default
538 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
540 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
541 (mcode mk_sign) (mcode mk_structUnion)
542 (mcode mk_storage) (mcode mk_inc_file)
543 (do_nothing mk_exprdots) initdots
544 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
545 (do_nothing mk_casedots)
546 (do_nothing mk_ident) (do_nothing mk_expression)
547 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
548 (do_nothing mk_declaration)
549 stmt (do_nothing mk_case_line) toplevel
551 let call_collect_plus context_nodes
:
552 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
556 Ast0.DotsExprTag
(e
) ->
558 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
559 | Ast0.DotsInitTag
(e
) ->
561 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
562 | Ast0.DotsParamTag
(e
) ->
564 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
565 | Ast0.DotsStmtTag
(e
) ->
567 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
568 | Ast0.DotsDeclTag
(e
) ->
570 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
571 | Ast0.DotsCaseTag
(e
) ->
573 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
574 | Ast0.IdentTag
(e
) ->
576 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
579 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
580 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
581 failwith
"not possible - iso only"
582 | Ast0.TypeCTag
(e
) ->
584 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
587 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
588 | Ast0.ParamTag
(e
) ->
590 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
593 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
596 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
597 | Ast0.CaseLineTag
(e
) ->
599 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
602 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
603 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
604 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
605 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
606 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
609 (* The plus fragments are converted to a list of lists of lists.
610 Innermost list: Elements have type anything. For any pair of successive
611 elements, n and n+1, the ending line of n is the same as the starting line
613 Middle lists: For any pair of successive elements, n and n+1, the ending
614 line of n is one less than the starting line of n+1.
615 Outer list: For any pair of successive elements, n and n+1, the ending
616 line of n is more than one less than the starting line of n+1. *)
618 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
619 let logend info = info.Ast0.pos_info
.Ast0.logical_end
621 let redo info start finish
=
623 {info.Ast0.pos_info
with
624 Ast0.logical_start
= start
;
625 Ast0.logical_end
= finish
} in
626 {info with Ast0.pos_info
= new_pos_info}
628 let rec find_neighbors (index,l
) :
629 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
630 let rec loop = function
633 (match loop rest
with
634 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
635 let finish1 = logend i
in
636 let start2 = logstart i1
in
639 ((if not
(c
= c1
) then failwith
"inconsistent + code");
640 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
643 else if finish1 + 1 = start2
644 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
646 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
647 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
651 let (start_info
,start_count
,_) = List.hd l
in
652 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
653 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
654 (redo start_info
(logstart start_info
) (logend end_info
),
656 List.map
(function (_,_,x
) -> x
) l
))
660 let process_plus plus
:
661 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
665 List.map
find_neighbors (call_collect_plus (collect_context x
)))
668 (* --------------------------------------------------------------------- *)
669 (* --------------------------------------------------------------------- *)
672 let merge_one = function
673 (m1::m2::minus_info,p::plus_info) ->
675 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
676 if p > m1 && p < m2, then consider the following possibilities, in order
677 m1 is Good and favored: attach to the beginning of m1.aft
678 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
679 m1 is Good and unfavored: attach to the beginning of m1.aft
680 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
681 also flip m1.bef if the first where > m1
682 if we drop m1, then flip m1.aft first
684 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
687 (* end of first argument < start/end of second argument *)
688 let less_than_start info1 info2
=
689 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
690 let less_than_end info1 info2
=
691 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
692 let greater_than_end info1 info2
=
693 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
694 let good_start info = info.Ast0.attachable_start
695 let good_end info = info.Ast0.attachable_end
697 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
698 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
699 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
703 (List.for_all
(function Ast.Code
_ | Ast.Pragma
_ -> true | _ -> false))
707 (List.for_all
(function Ast.StorageTag
_ -> true | _ -> false))
709 (* The following is probably not correct. The idea is to detect what
710 should be placed completely before the declaration. So type/storage
711 related things do not fall into this category, and complete statements do
712 fall into this category. But perhaps other things should be in this
713 category as well, such as { or ;? *)
715 let tester = function
716 (* the following should definitely be true *)
722 | Ast.Pragma
_ -> true
723 (* the following should definitely be false *)
724 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
726 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
727 (* not sure about the rest *)
729 List.for_all
(List.for_all
tester)
731 let pr = Printf.sprintf
733 let insert thing thinginfo into intoinfo
=
734 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
735 let get_first l = (List.hd
l,List.tl
l) in
736 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
737 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
738 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
739 let into_start = intoinfo
.Ast0.tline_start
in
740 let into_end = intoinfo
.Ast0.tline_end
in
741 let into_left_offset = intoinfo
.Ast0.left_offset
in
742 let into_right_offset = intoinfo
.Ast0.right_offset
in
743 if thing_end < into_start && thing_start < into_start
745 {{intoinfo
with Ast0.tline_start
= thing_start}
746 with Ast0.left_offset
= thing_offset})
747 else if thing_end = into_start && thing_offset < into_left_offset
749 let (prev
,last
) = get_last thing
in
750 let (first
,rest
) = get_first into
in
751 (prev
@[last
@first
]@rest
,
752 {{intoinfo
with Ast0.tline_start
= thing_start}
753 with Ast0.left_offset
= thing_offset})
754 else if thing_start > into_end && thing_end > into_end
756 {{intoinfo
with Ast0.tline_end
= thing_end}
757 with Ast0.right_offset
= thing_offset})
758 else if thing_start = into_end && thing_offset > into_right_offset
760 let (first
,rest
) = get_first thing
in
761 let (prev
,last
) = get_last into
in
762 (prev
@[last
@first
]@rest
,
763 {{intoinfo
with Ast0.tline_end
= thing_end}
764 with Ast0.right_offset
= thing_offset})
767 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
768 thing_start thing_end into_start into_end;
769 Printf.printf
"thing offset %d left offset %d right offset %d\n"
770 thing_offset into_left_offset into_right_offset;
771 Pretty_print_cocci.print_anything
"" thing
;
772 Pretty_print_cocci.print_anything
"" into
;
773 failwith
"can't figure out where to put the + code"
776 let init thing
info =
778 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
779 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
780 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
781 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
783 let attachbefore (infop
,c
,p
) = function
784 Ast0.MINUS
(replacements
) ->
785 let (repl
,ti
) = !replacements
in
789 | repl
-> insert p infop repl ti
in
790 replacements
:= (bef,ti
)
791 | Ast0.CONTEXT
(neighbors
) ->
792 let (repl
,ti1
,ti2
) = !neighbors
in
794 Ast.BEFORE
(bef,it
) ->
795 let (bef,ti1
) = insert p infop
bef ti1
in
796 let it = Ast.lub_count
it c
in
797 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
798 | Ast.AFTER
(aft,it) ->
799 let (bef,ti1
) = init p infop
in
800 let it = Ast.lub_count
it c
in
801 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
802 | Ast.BEFOREAFTER
(bef,aft,it) ->
803 let (bef,ti1
) = insert p infop
bef ti1
in
804 let it = Ast.lub_count
it c
in
805 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
807 let (bef,ti1
) = init p infop
in
808 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
809 | _ -> failwith
"not possible for attachbefore"
811 let attachafter (infop
,c
,p
) = function
812 Ast0.MINUS
(replacements
) ->
813 let (repl
,ti
) = !replacements
in
817 | repl
-> insert p infop repl ti
in
818 replacements
:= (aft,ti
)
819 | Ast0.CONTEXT
(neighbors
) ->
820 let (repl
,ti1
,ti2
) = !neighbors
in
822 Ast.BEFORE
(bef,it) ->
823 let (aft,ti2
) = init p infop
in
824 let it = Ast.lub_count
it c
in
825 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
826 | Ast.AFTER
(aft,it) ->
827 let (aft,ti2
) = insert p infop
aft ti2
in
828 let it = Ast.lub_count
it c
in
829 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
830 | Ast.BEFOREAFTER
(bef,aft,it) ->
831 let (aft,ti2
) = insert p infop
aft ti2
in
832 let it = Ast.lub_count
it c
in
833 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
835 let (aft,ti2
) = init p infop
in
836 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
837 | _ -> failwith
"not possible for attachbefore"
839 let attach_all_before ps m
=
840 List.iter
(function x
-> attachbefore x m
) ps
842 let attach_all_after ps m
=
843 List.iter
(function x
-> attachafter x m
) ps
845 let split_at_end info ps
=
846 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
848 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
851 let allminus = function
852 Ast0.MINUS
(_) -> true
855 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
857 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
858 if less_than_start infop infom1
or
859 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
863 if storage_code pcode
864 then before_m2 x2 rest all
(* skip fake token for storage *)
865 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
868 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
871 (pr "%d: no available token to attach to"
872 infop
.Ast0.pos_info
.Ast0.line_start
)
873 else after_m1 x1 x2 rest all
875 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
877 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
878 (* if the following is false, then some + code is stuck in the middle
879 of some context code (m1). could drop down to the token level.
880 this might require adjustments in ast0toast as well, when + code on
881 expressions is dropped down to + code on expressions. it might
882 also break some invariants on which iso depends, particularly on
883 what it can infer from something being CONTEXT with no top-level
884 modifications. for the moment, we thus give an error, asking the
885 user to rewrite the semantic patch. *)
886 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
888 if less_than_start infop infom2
890 if predecl_code pcode
&& good_end infom1
&& decl f1
891 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
892 else if predecl_code pcode
&& good_start infom2
&& decl f2
893 then before_m2 x2 rest all
894 else if top_code pcode
&& good_end infom1
&& toplevel f1
895 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
896 else if top_code pcode
&& good_start infom2
&& toplevel f2
897 then before_m2 x2 rest all
898 else if good_end infom1
&& favored f1
899 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
900 else if good_start infom2
&& favored f2
901 then before_m2 x2 rest all
902 else if good_end infom1
903 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
904 else if good_start infom2
905 then before_m2 x2 rest all
908 (pr "%d: no available token to attach to"
909 infop
.Ast0.pos_info
.Ast0.line_start
)
910 else after_m2 x2 rest all
913 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
914 infop
.Ast0.pos_info
.Ast0.line_start
915 infop
.Ast0.pos_info
.Ast0.line_end
916 infom1
.Ast0.pos_info
.Ast0.line_start
917 infom1
.Ast0.pos_info
.Ast0.line_end
918 infom2
.Ast0.pos_info
.Ast0.line_start
919 infom2
.Ast0.pos_info
.Ast0.line_end
;
920 Pretty_print_cocci.print_anything
"" pcode
;
922 "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."
925 (* not sure this is safe. if have iso problems, consider changing this
926 to always return false *)
927 and is_minus
= function
931 and before_m2
((f2
,infom2
,m2
) as x2
) rest
932 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
935 | ([],((infop
,_,_)::_)) ->
936 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
938 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
941 (pr "%d: no available token to attach to"
942 infop
.Ast0.pos_info
.Ast0.line_start
)
943 | (m
::ms
,_) -> before_m1 x2 m ms p
945 and after_m2
((f2
,infom2
,m2
) as x2
) rest
946 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
949 | ([],((infop
,_,_)::_)) ->
951 then attach_all_after p m2
954 (pr "%d: no available token to attach to"
955 infop
.Ast0.pos_info
.Ast0.line_start
)
956 | (m
::ms
,_) -> after_m1 x2 m ms p
958 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
959 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
962 Printf.printf "minus code\n";
964 (function (_,info,_) ->
965 Printf.printf "start %d end %d real_start %d real_end %d\n"
966 info.Ast0.pos_info.Ast0.logical_start
967 info.Ast0.pos_info.Ast0.logical_end
968 info.Ast0.pos_info.Ast0.line_start
969 info.Ast0.pos_info.Ast0.line_end)
971 Printf.printf "plus code\n";
973 (function (info,_,p) ->
974 Printf.printf "start %d end %d real_start %d real_end %d\n"
975 info.Ast0.pos_info.Ast0.logical_start
976 info.Ast0.pos_info.Ast0.logical_end
977 info.Ast0.pos_info.Ast0.line_end
978 info.Ast0.pos_info.Ast0.line_end;
979 Pretty_print_cocci.print_anything "" p;
980 Format.print_newline())
985 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
986 | ([m
],p
) -> before_m2 m
[] p
987 | ([],_) -> failwith
"minus tree ran out before the plus tree"
989 let merge minus_list plus_list
=
991 Printf.printf "minus list %s\n"
993 (List.map (function (x,_) -> string_of_int x) minus_list));
994 Printf.printf "plus list %s\n"
996 (List.map (function (x,_) -> string_of_int x) plus_list));
999 (function (index,minus_info
) ->
1000 let plus_info = List.assoc
index plus_list
in
1001 merge_one (minus_info
,plus_info))
1004 (* --------------------------------------------------------------------- *)
1005 (* --------------------------------------------------------------------- *)
1006 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1007 If they do, they become MIXED *)
1009 let reevaluate_contextness =
1011 let option_default = [] in
1013 let mcode (_,_,_,mc
,_,_) =
1015 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1020 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1023 let donothing r k e
=
1024 match Ast0.get_mcodekind e
with
1026 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1027 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1029 | _ -> let _ = k e
in [] in
1031 (* a case for everything with bef or aft *)
1033 match Ast0.unwrap e
with
1034 Ast0.Decl
(bef,decl) ->
1035 (info bef) @ (donothing r k e
)
1036 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1037 (info bef) @ (donothing r k e
)
1038 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1039 (donothing r k e
) @ (info aft)
1040 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1041 (donothing r k e
) @ (info aft)
1042 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1043 (donothing r k e
) @ (info aft)
1044 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1045 (donothing r k e
) @ (info aft)
1046 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1047 (donothing r k e
) @ (info aft)
1048 | _ -> donothing r k e
in
1051 V0.flat_combiner
bind option_default
1052 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1053 donothing donothing donothing donothing donothing donothing donothing
1055 donothing donothing donothing donothing stmt donothing donothing in
1056 res.VT0.combiner_rec_top_level
1058 (* --------------------------------------------------------------------- *)
1059 (* --------------------------------------------------------------------- *)
1061 let insert_plus minus plus ei
=
1063 let minus_stream = process_minus minus
in
1064 let plus_stream = process_plus plus
in
1065 merge minus_stream plus_stream;
1066 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus