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 attachbefore (infop
,c
,p
) = function
785 Ast0.MINUS
(replacements
) ->
786 let (repl
,ti
) = !replacements
in
790 | repl
-> insert p infop repl ti
in
791 replacements
:= (bef,ti
)
792 | Ast0.CONTEXT
(neighbors
) ->
793 let (repl
,ti1
,ti2
) = !neighbors
in
795 Ast.BEFORE
(bef,it
) ->
796 let (bef,ti1
) = insert p infop
bef ti1
in
797 let it = Ast.lub_count
it c
in
798 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
799 | Ast.AFTER
(aft,it) ->
800 let (bef,ti1
) = init p infop
in
801 let it = Ast.lub_count
it c
in
802 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
803 | Ast.BEFOREAFTER
(bef,aft,it) ->
804 let (bef,ti1
) = insert p infop
bef ti1
in
805 let it = Ast.lub_count
it c
in
806 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
808 let (bef,ti1
) = init p infop
in
809 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
810 | _ -> failwith
"not possible for attachbefore"
812 let attachafter (infop
,c
,p
) = function
813 Ast0.MINUS
(replacements
) ->
814 let (repl
,ti
) = !replacements
in
818 | repl
-> insert p infop repl ti
in
819 replacements
:= (aft,ti
)
820 | Ast0.CONTEXT
(neighbors
) ->
821 let (repl
,ti1
,ti2
) = !neighbors
in
823 Ast.BEFORE
(bef,it) ->
824 let (aft,ti2
) = init p infop
in
825 let it = Ast.lub_count
it c
in
826 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
827 | Ast.AFTER
(aft,it) ->
828 let (aft,ti2
) = insert p infop
aft ti2
in
829 let it = Ast.lub_count
it c
in
830 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
831 | Ast.BEFOREAFTER
(bef,aft,it) ->
832 let (aft,ti2
) = insert p infop
aft ti2
in
833 let it = Ast.lub_count
it c
in
834 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
836 let (aft,ti2
) = init p infop
in
837 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
838 | _ -> failwith
"not possible for attachbefore"
840 let attach_all_before ps m
=
841 List.iter
(function x
-> attachbefore x m
) ps
843 let attach_all_after ps m
=
844 List.iter
(function x
-> attachafter x m
) ps
846 let split_at_end info ps
=
847 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
849 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
852 let allminus = function
853 Ast0.MINUS
(_) -> true
856 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
858 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
859 if less_than_start infop infom1
or
860 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
864 if storage_code pcode
865 then before_m2 x2 rest all
(* skip fake token for storage *)
866 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
869 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
872 (pr "%d: no available token to attach to"
873 infop
.Ast0.pos_info
.Ast0.line_start
)
874 else after_m1 x1 x2 rest all
876 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
878 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
879 (* if the following is false, then some + code is stuck in the middle
880 of some context code (m1). could drop down to the token level.
881 this might require adjustments in ast0toast as well, when + code on
882 expressions is dropped down to + code on expressions. it might
883 also break some invariants on which iso depends, particularly on
884 what it can infer from something being CONTEXT with no top-level
885 modifications. for the moment, we thus give an error, asking the
886 user to rewrite the semantic patch. *)
887 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
889 if less_than_start infop infom2
891 if predecl_code pcode
&& good_end infom1
&& decl f1
892 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
893 else if predecl_code pcode
&& good_start infom2
&& decl f2
894 then before_m2 x2 rest all
895 else if top_code pcode
&& good_end infom1
&& toplevel f1
896 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
897 else if top_code pcode
&& good_start infom2
&& toplevel f2
898 then before_m2 x2 rest all
899 else if good_end infom1
&& favored f1
900 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
901 else if good_start infom2
&& favored f2
902 then before_m2 x2 rest all
903 else if good_end infom1
904 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
905 else if good_start infom2
906 then before_m2 x2 rest all
909 (pr "%d: no available token to attach to"
910 infop
.Ast0.pos_info
.Ast0.line_start
)
911 else after_m2 x2 rest all
914 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
915 infop
.Ast0.pos_info
.Ast0.line_start
916 infop
.Ast0.pos_info
.Ast0.line_end
917 infom1
.Ast0.pos_info
.Ast0.line_start
918 infom1
.Ast0.pos_info
.Ast0.line_end
919 infom2
.Ast0.pos_info
.Ast0.line_start
920 infom2
.Ast0.pos_info
.Ast0.line_end
;
921 Pretty_print_cocci.print_anything
"" pcode
;
923 "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."
926 (* not sure this is safe. if have iso problems, consider changing this
927 to always return false *)
928 and is_minus
= function
932 and before_m2
((f2
,infom2
,m2
) as x2
) rest
933 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
936 | ([],((infop
,_,_)::_)) ->
937 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
939 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
942 (pr "%d: no available token to attach to"
943 infop
.Ast0.pos_info
.Ast0.line_start
)
944 | (m
::ms
,_) -> before_m1 x2 m ms p
946 and after_m2
((f2
,infom2
,m2
) as x2
) rest
947 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
950 | ([],((infop
,_,_)::_)) ->
952 then attach_all_after p m2
955 (pr "%d: no available token to attach to"
956 infop
.Ast0.pos_info
.Ast0.line_start
)
957 | (m
::ms
,_) -> after_m1 x2 m ms p
959 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
960 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
963 Printf.printf "minus code\n";
965 (function (_,info,_) ->
966 Printf.printf "start %d end %d real_start %d real_end %d\n"
967 info.Ast0.pos_info.Ast0.logical_start
968 info.Ast0.pos_info.Ast0.logical_end
969 info.Ast0.pos_info.Ast0.line_start
970 info.Ast0.pos_info.Ast0.line_end)
972 Printf.printf "plus code\n";
974 (function (info,_,p) ->
975 Printf.printf "start %d end %d real_start %d real_end %d\n"
976 info.Ast0.pos_info.Ast0.logical_start
977 info.Ast0.pos_info.Ast0.logical_end
978 info.Ast0.pos_info.Ast0.line_end
979 info.Ast0.pos_info.Ast0.line_end;
980 Pretty_print_cocci.print_anything "" p;
981 Format.print_newline())
986 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
987 | ([m
],p
) -> before_m2 m
[] p
988 | ([],_) -> failwith
"minus tree ran out before the plus tree"
990 let merge minus_list plus_list
=
992 Printf.printf "minus list %s\n"
994 (List.map (function (x,_) -> string_of_int x) minus_list));
995 Printf.printf "plus list %s\n"
997 (List.map (function (x,_) -> string_of_int x) plus_list));
1000 (function (index,minus_info
) ->
1001 let plus_info = List.assoc
index plus_list
in
1002 merge_one (minus_info
,plus_info))
1005 (* --------------------------------------------------------------------- *)
1006 (* --------------------------------------------------------------------- *)
1007 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1008 If they do, they become MIXED *)
1010 let reevaluate_contextness =
1012 let option_default = [] in
1014 let mcode (_,_,_,mc
,_,_) =
1016 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1021 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1024 let donothing r k e
=
1025 match Ast0.get_mcodekind e
with
1027 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1028 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1030 | _ -> let _ = k e
in [] in
1032 (* a case for everything with bef or aft *)
1034 match Ast0.unwrap e
with
1035 Ast0.Decl
(bef,decl) ->
1036 (info bef) @ (donothing r k e
)
1037 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1038 (info bef) @ (donothing r k e
)
1039 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1040 (donothing r k e
) @ (info aft)
1041 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1042 (donothing r k e
) @ (info aft)
1043 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1044 (donothing r k e
) @ (info aft)
1045 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1046 (donothing r k e
) @ (info aft)
1047 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1048 (donothing r k e
) @ (info aft)
1049 | _ -> donothing r k e
in
1052 V0.flat_combiner
bind option_default
1053 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1054 donothing donothing donothing donothing donothing donothing donothing
1056 donothing donothing donothing donothing stmt donothing donothing in
1057 res.VT0.combiner_rec_top_level
1059 (* --------------------------------------------------------------------- *)
1060 (* --------------------------------------------------------------------- *)
1062 let insert_plus minus plus ei
=
1064 let minus_stream = process_minus minus
in
1065 let plus_stream = process_plus plus
in
1066 merge minus_stream plus_stream;
1067 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus