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 Hashtbl.clear
root_token_table;
406 create_root_token_table minus
;
410 let res = call_collect_minus (collect_context x
) in
415 (* --------------------------------------------------------------------- *)
416 (* --------------------------------------------------------------------- *)
417 (* collect the plus tokens *)
419 let mk_structUnion x
= Ast.StructUnionTag x
420 let mk_sign x
= Ast.SignTag x
421 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
422 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
423 let mk_constant x
= Ast.ConstantTag x
424 let mk_unaryOp x
= Ast.UnaryOpTag x
425 let mk_assignOp x
= Ast.AssignOpTag x
426 let mk_fixOp x
= Ast.FixOpTag x
427 let mk_binaryOp x
= Ast.BinaryOpTag x
428 let mk_arithOp x
= Ast.ArithOpTag x
429 let mk_logicalOp x
= Ast.LogicalOpTag x
430 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
431 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
432 let mk_storage x
= Ast.StorageTag x
433 let mk_inc_file x
= Ast.IncFileTag x
434 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
435 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
436 let mk_const_vol x
= Ast.ConstVolTag x
437 let mk_token x
info = Ast.Token
(x
,Some
info)
438 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
439 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
441 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
442 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
443 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
444 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
445 let mk_casedots x
= failwith
"+ case lines not supported"
446 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
447 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
448 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
450 let collect_plus_nodes root
=
451 let root_index = Ast0.get_index root
in
453 let bind x y
= x
@ y
in
454 let option_default = [] in
456 let extract_strings info =
458 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
459 let extract = function
462 let (_,first
) = List.hd strings_before
in
463 let (_,last
) = List.hd
(List.rev strings_before
) in
465 {Ast0.line_start
= first
.Ast0.line_start
;
466 Ast0.line_end
= last
.Ast0.line_start
;
467 Ast0.logical_start
= first
.Ast0.logical_start
;
468 Ast0.logical_end
= last
.Ast0.logical_start
;
469 Ast0.column
= first
.Ast0.column
;
470 Ast0.offset
= first
.Ast0.offset
} in
471 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
472 let string = List.map
(function (s
,_) -> s
) strings_before
in
473 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
474 let bef = extract info.Ast0.strings_before
in
475 let aft = extract info.Ast0.strings_after
in
478 let mcode fn
(term
,_,info,mcodekind
,_,_) =
480 Ast0.PLUS c
-> [(info,c
,fn term
)]
481 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
484 let imcode fn
(term
,_,info,mcodekind
,_,_) =
486 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
487 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
490 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
492 let do_nothing fn r k e
=
493 match Ast0.get_mcodekind e
with
494 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
495 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
498 (* case for everything that is just a wrapper for a simpler thing *)
499 (* case for things with bef aft *)
501 match Ast0.unwrap e
with
502 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
503 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
504 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
505 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
506 | Ast0.Decl
(bef,decl) ->
507 (info bef) @ (do_nothing mk_statement r k e
)
508 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
509 (info bef) @ (do_nothing mk_statement r k e
)
510 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
511 (do_nothing mk_statement r k e
) @ (info aft)
512 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
513 (do_nothing mk_statement r k e
) @ (info aft)
514 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
515 (do_nothing mk_statement r k e
) @ (info aft)
516 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
517 (do_nothing mk_statement r k e
) @ (info aft)
518 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
519 (do_nothing mk_statement r k e
) @ (info aft)
520 | _ -> do_nothing mk_statement r k e
in
522 (* statementTag is preferred, because it indicates that one statement is
523 replaced by one statement, in single_statement *)
524 let stmt_dots r k e
=
525 match Ast0.unwrap e
with
526 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
527 r
.VT0.combiner_rec_statement s
528 | _ -> do_nothing mk_stmtdots r k e
in
531 match Ast0.unwrap e
with
532 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
533 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
534 | _ -> do_nothing mk_code r k e
in
536 let initdots r k e
= k e
in
538 V0.flat_combiner
bind option_default
539 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
541 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
542 (mcode mk_sign) (mcode mk_structUnion)
543 (mcode mk_storage) (mcode mk_inc_file)
544 (do_nothing mk_exprdots) initdots
545 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
546 (do_nothing mk_casedots)
547 (do_nothing mk_ident) (do_nothing mk_expression)
548 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
549 (do_nothing mk_declaration)
550 stmt (do_nothing mk_case_line) toplevel
552 let call_collect_plus context_nodes
:
553 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
557 Ast0.DotsExprTag
(e
) ->
559 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
560 | Ast0.DotsInitTag
(e
) ->
562 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
563 | Ast0.DotsParamTag
(e
) ->
565 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
566 | Ast0.DotsStmtTag
(e
) ->
568 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
569 | Ast0.DotsDeclTag
(e
) ->
571 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
572 | Ast0.DotsCaseTag
(e
) ->
574 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
575 | Ast0.IdentTag
(e
) ->
577 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
580 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
581 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
582 failwith
"not possible - iso only"
583 | Ast0.TypeCTag
(e
) ->
585 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
588 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
589 | Ast0.ParamTag
(e
) ->
591 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
594 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
597 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
598 | Ast0.CaseLineTag
(e
) ->
600 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
603 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
604 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
605 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
606 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
607 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
610 (* The plus fragments are converted to a list of lists of lists.
611 Innermost list: Elements have type anything. For any pair of successive
612 elements, n and n+1, the ending line of n is the same as the starting line
614 Middle lists: For any pair of successive elements, n and n+1, the ending
615 line of n is one less than the starting line of n+1.
616 Outer list: For any pair of successive elements, n and n+1, the ending
617 line of n is more than one less than the starting line of n+1. *)
619 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
620 let logend info = info.Ast0.pos_info
.Ast0.logical_end
622 let redo info start finish
=
624 {info.Ast0.pos_info
with
625 Ast0.logical_start
= start
;
626 Ast0.logical_end
= finish
} in
627 {info with Ast0.pos_info
= new_pos_info}
629 let rec find_neighbors (index,l
) :
630 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
631 let rec loop = function
634 (match loop rest
with
635 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
636 let finish1 = logend i
in
637 let start2 = logstart i1
in
640 ((if not
(c
= c1
) then failwith
"inconsistent + code");
641 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
644 else if finish1 + 1 = start2
645 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
647 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
648 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
652 let (start_info
,start_count
,_) = List.hd l
in
653 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
654 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
655 (redo start_info
(logstart start_info
) (logend end_info
),
657 List.map
(function (_,_,x
) -> x
) l
))
661 let process_plus plus
:
662 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
666 List.map
find_neighbors (call_collect_plus (collect_context x
)))
669 (* --------------------------------------------------------------------- *)
670 (* --------------------------------------------------------------------- *)
673 let merge_one = function
674 (m1::m2::minus_info,p::plus_info) ->
676 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
677 if p > m1 && p < m2, then consider the following possibilities, in order
678 m1 is Good and favored: attach to the beginning of m1.aft
679 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
680 m1 is Good and unfavored: attach to the beginning of m1.aft
681 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
682 also flip m1.bef if the first where > m1
683 if we drop m1, then flip m1.aft first
685 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
688 (* end of first argument < start/end of second argument *)
689 let less_than_start info1 info2
=
690 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
691 let less_than_end info1 info2
=
692 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
693 let greater_than_end info1 info2
=
694 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
695 let good_start info = info.Ast0.attachable_start
696 let good_end info = info.Ast0.attachable_end
698 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
699 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
700 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
704 (List.for_all
(function Ast.Code
_ | Ast.Pragma
_ -> true | _ -> false))
708 (List.for_all
(function Ast.StorageTag
_ -> true | _ -> false))
710 (* The following is probably not correct. The idea is to detect what
711 should be placed completely before the declaration. So type/storage
712 related things do not fall into this category, and complete statements do
713 fall into this category. But perhaps other things should be in this
714 category as well, such as { or ;? *)
716 let tester = function
717 (* the following should definitely be true *)
723 | Ast.Pragma
_ -> true
724 (* the following should definitely be false *)
725 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
727 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
728 (* not sure about the rest *)
730 List.for_all
(List.for_all
tester)
732 let pr = Printf.sprintf
734 let insert thing thinginfo into intoinfo
=
735 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
736 let get_first l = (List.hd
l,List.tl
l) in
737 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
738 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
739 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
740 let into_start = intoinfo
.Ast0.tline_start
in
741 let into_end = intoinfo
.Ast0.tline_end
in
742 let into_left_offset = intoinfo
.Ast0.left_offset
in
743 let into_right_offset = intoinfo
.Ast0.right_offset
in
744 if thing_end < into_start && thing_start < into_start
746 {{intoinfo
with Ast0.tline_start
= thing_start}
747 with Ast0.left_offset
= thing_offset})
748 else if thing_end = into_start && thing_offset < into_left_offset
750 let (prev
,last
) = get_last thing
in
751 let (first
,rest
) = get_first into
in
752 (prev
@[last
@first
]@rest
,
753 {{intoinfo
with Ast0.tline_start
= thing_start}
754 with Ast0.left_offset
= thing_offset})
755 else if thing_start > into_end && thing_end > into_end
757 {{intoinfo
with Ast0.tline_end
= thing_end}
758 with Ast0.right_offset
= thing_offset})
759 else if thing_start = into_end && thing_offset > into_right_offset
761 let (first
,rest
) = get_first thing
in
762 let (prev
,last
) = get_last into
in
763 (prev
@[last
@first
]@rest
,
764 {{intoinfo
with Ast0.tline_end
= thing_end}
765 with Ast0.right_offset
= thing_offset})
768 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
769 thing_start thing_end into_start into_end;
770 Printf.printf
"thing offset %d left offset %d right offset %d\n"
771 thing_offset into_left_offset into_right_offset;
772 Pretty_print_cocci.print_anything
"" thing
;
773 Pretty_print_cocci.print_anything
"" into
;
774 failwith
"can't figure out where to put the + code"
777 let init thing
info =
779 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
780 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
781 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
782 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
784 let it2c = function Ast.ONE
-> "one" | Ast.MANY
-> "many"
786 let attachbefore (infop
,c
,p
) = function
787 Ast0.MINUS
(replacements
) ->
788 let (repl
,ti
) = !replacements
in
791 let (bef,ti
) = init p infop
in
792 Printf.printf
"attachbefore 1 %s\n" (it2c c
);
793 replacements
:= (Ast.REPLACEMENT
(bef,c
),ti
)
794 | Ast.REPLACEMENT
(repl
,it
) ->
795 Printf.printf
"attachbefore 2 %s %s\n" (it2c c
) (it2c it
);
796 let it = Ast.lub_count
it c
in
797 let (bef,ti
) = insert p infop repl ti
in
798 replacements
:= (Ast.REPLACEMENT
(bef,it),ti
))
799 | Ast0.CONTEXT
(neighbors
) ->
800 let (repl
,ti1
,ti2
) = !neighbors
in
802 Ast.BEFORE
(bef,it) ->
803 let (bef,ti1
) = insert p infop
bef ti1
in
804 let it = Ast.lub_count
it c
in
805 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
806 | Ast.AFTER
(aft,it) ->
807 let (bef,ti1
) = init p infop
in
808 let it = Ast.lub_count
it c
in
809 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
810 | Ast.BEFOREAFTER
(bef,aft,it) ->
811 let (bef,ti1
) = insert p infop
bef ti1
in
812 let it = Ast.lub_count
it c
in
813 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
815 let (bef,ti1
) = init p infop
in
816 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
817 | _ -> failwith
"not possible for attachbefore"
819 let attachafter (infop
,c
,p
) = function
820 Ast0.MINUS
(replacements
) ->
821 let (repl
,ti
) = !replacements
in
824 let (aft,ti
) = init p infop
in
825 replacements
:= (Ast.REPLACEMENT
(aft,c
),ti
)
826 | Ast.REPLACEMENT
(repl
,it) ->
827 let it = Ast.lub_count
it c
in
828 let (aft,ti
) = insert p infop repl ti
in
829 replacements
:= (Ast.REPLACEMENT
(aft,it),ti
))
830 | Ast0.CONTEXT
(neighbors
) ->
831 let (repl
,ti1
,ti2
) = !neighbors
in
833 Ast.BEFORE
(bef,it) ->
834 let (aft,ti2
) = init p infop
in
835 let it = Ast.lub_count
it c
in
836 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
837 | Ast.AFTER
(aft,it) ->
838 let (aft,ti2
) = insert p infop
aft ti2
in
839 let it = Ast.lub_count
it c
in
840 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
841 | Ast.BEFOREAFTER
(bef,aft,it) ->
842 let (aft,ti2
) = insert p infop
aft ti2
in
843 let it = Ast.lub_count
it c
in
844 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
846 let (aft,ti2
) = init p infop
in
847 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
848 | _ -> failwith
"not possible for attachbefore"
850 let attach_all_before ps m
=
851 List.iter
(function x
-> attachbefore x m
) ps
853 let attach_all_after ps m
=
854 List.iter
(function x
-> attachafter x m
) ps
856 let split_at_end info ps
=
857 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
859 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
862 let allminus = function
863 Ast0.MINUS
(_) -> true
866 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
868 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
869 if less_than_start infop infom1
or
870 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
874 if storage_code pcode
875 then before_m2 x2 rest all
(* skip fake token for storage *)
876 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
879 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
882 (pr "%d: no available token to attach to"
883 infop
.Ast0.pos_info
.Ast0.line_start
)
884 else after_m1 x1 x2 rest all
886 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
888 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
889 (* if the following is false, then some + code is stuck in the middle
890 of some context code (m1). could drop down to the token level.
891 this might require adjustments in ast0toast as well, when + code on
892 expressions is dropped down to + code on expressions. it might
893 also break some invariants on which iso depends, particularly on
894 what it can infer from something being CONTEXT with no top-level
895 modifications. for the moment, we thus give an error, asking the
896 user to rewrite the semantic patch. *)
897 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
899 if less_than_start infop infom2
901 if predecl_code pcode
&& good_end infom1
&& decl f1
902 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
903 else if predecl_code pcode
&& good_start infom2
&& decl f2
904 then before_m2 x2 rest all
905 else if top_code pcode
&& good_end infom1
&& toplevel f1
906 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
907 else if top_code pcode
&& good_start infom2
&& toplevel f2
908 then before_m2 x2 rest all
909 else if good_end infom1
&& favored f1
910 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
911 else if good_start infom2
&& favored f2
912 then before_m2 x2 rest all
913 else if good_end infom1
914 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
915 else if good_start infom2
916 then before_m2 x2 rest all
919 (pr "%d: no available token to attach to"
920 infop
.Ast0.pos_info
.Ast0.line_start
)
921 else after_m2 x2 rest all
924 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
925 infop
.Ast0.pos_info
.Ast0.line_start
926 infop
.Ast0.pos_info
.Ast0.line_end
927 infom1
.Ast0.pos_info
.Ast0.line_start
928 infom1
.Ast0.pos_info
.Ast0.line_end
929 infom2
.Ast0.pos_info
.Ast0.line_start
930 infom2
.Ast0.pos_info
.Ast0.line_end
;
931 Pretty_print_cocci.print_anything
"" pcode
;
933 "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."
936 (* not sure this is safe. if have iso problems, consider changing this
937 to always return false *)
938 and is_minus
= function
942 and before_m2
((f2
,infom2
,m2
) as x2
) rest
943 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
946 | ([],((infop
,_,_)::_)) ->
947 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
949 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
952 (pr "%d: no available token to attach to"
953 infop
.Ast0.pos_info
.Ast0.line_start
)
954 | (m
::ms
,_) -> before_m1 x2 m ms p
956 and after_m2
((f2
,infom2
,m2
) as x2
) rest
957 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
960 | ([],((infop
,_,_)::_)) ->
962 then attach_all_after p m2
965 (pr "%d: no available token to attach to"
966 infop
.Ast0.pos_info
.Ast0.line_start
)
967 | (m
::ms
,_) -> after_m1 x2 m ms p
969 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
970 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
973 Printf.printf "minus code\n";
975 (function (_,info,_) ->
977 "start %d end %d real_start %d real_end %d attachable start %b attachable end %b\n"
978 info.Ast0.pos_info.Ast0.logical_start
979 info.Ast0.pos_info.Ast0.logical_end
980 info.Ast0.pos_info.Ast0.line_start
981 info.Ast0.pos_info.Ast0.line_end
982 info.Ast0.attachable_start
983 info.Ast0.attachable_end)
985 Printf.printf "plus code\n";
987 (function (info,_,p) ->
988 Printf.printf "start %d end %d real_start %d real_end %d\n"
989 info.Ast0.pos_info.Ast0.logical_start
990 info.Ast0.pos_info.Ast0.logical_end
991 info.Ast0.pos_info.Ast0.line_end
992 info.Ast0.pos_info.Ast0.line_end;
993 Pretty_print_cocci.print_anything "" p;
994 Format.print_newline())
999 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
1000 | ([m
],p
) -> before_m2 m
[] p
1001 | ([],_) -> failwith
"minus tree ran out before the plus tree"
1003 let merge minus_list plus_list
=
1005 Printf.printf "minus list %s\n"
1007 (List.map (function (x,_) -> string_of_int x) minus_list));
1008 Printf.printf "plus list %s\n"
1010 (List.map (function (x,_) -> string_of_int x) plus_list));
1013 (function (index,minus_info
) ->
1014 let plus_info = List.assoc
index plus_list
in
1015 merge_one (minus_info
,plus_info))
1018 (* --------------------------------------------------------------------- *)
1019 (* --------------------------------------------------------------------- *)
1020 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1021 If they do, they become MIXED *)
1023 let reevaluate_contextness =
1025 let option_default = [] in
1027 let mcode (_,_,_,mc
,_,_) =
1029 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1034 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1037 let donothing r k e
=
1038 match Ast0.get_mcodekind e
with
1040 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1041 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1043 | _ -> let _ = k e
in [] in
1045 (* a case for everything with bef or aft *)
1047 match Ast0.unwrap e
with
1048 Ast0.Decl
(bef,decl) ->
1049 (info bef) @ (donothing r k e
)
1050 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1051 (info bef) @ (donothing r k e
)
1052 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1053 (donothing r k e
) @ (info aft)
1054 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1055 (donothing r k e
) @ (info aft)
1056 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1057 (donothing r k e
) @ (info aft)
1058 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1059 (donothing r k e
) @ (info aft)
1060 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1061 (donothing r k e
) @ (info aft)
1062 | _ -> donothing r k e
in
1065 V0.flat_combiner
bind option_default
1066 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1067 donothing donothing donothing donothing donothing donothing donothing
1069 donothing donothing donothing donothing stmt donothing donothing in
1070 res.VT0.combiner_rec_top_level
1072 (* --------------------------------------------------------------------- *)
1073 (* --------------------------------------------------------------------- *)
1075 let insert_plus minus plus ei
=
1077 let minus_stream = process_minus minus
in
1078 let plus_stream = process_plus plus
in
1079 merge minus_stream plus_stream;
1080 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus