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.
26 * Copyright 2010, INRIA, University of Copenhagen
27 * Julia Lawall, Rene Rydhof Hansen, Gilles Muller, Nicolas Palix
28 * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen
29 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
30 * This file is part of Coccinelle.
32 * Coccinelle is free software: you can redistribute it and/or modify
33 * it under the terms of the GNU General Public License as published by
34 * the Free Software Foundation, according to version 2 of the License.
36 * Coccinelle is distributed in the hope that it will be useful,
37 * but WITHOUT ANY WARRANTY; without even the implied warranty of
38 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
39 * GNU General Public License for more details.
41 * You should have received a copy of the GNU General Public License
42 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
44 * The authors reserve the right to distribute this or future versions of
45 * Coccinelle under other licenses.
49 (* The error message "no available token to attach to" often comes in an
50 argument list of unbounded length. In this case, one should move a comma so
51 that there is a comma after the + code. *)
53 (* Start at all of the corresponding BindContext nodes in the minus and
54 plus trees, and traverse their children. We take the same strategy as
55 before: collect the list of minus/context nodes/tokens and the list of plus
56 tokens, and then merge them. *)
58 module Ast
= Ast_cocci
59 module Ast0
= Ast0_cocci
60 module V0
= Visitor_ast0
61 module VT0
= Visitor_ast0_types
62 module CN
= Context_neg
64 let empty_isos = ref false
66 let get_option f
= function
70 (* --------------------------------------------------------------------- *)
71 (* Collect root and all context nodes in a tree *)
73 let collect_context e
=
74 let bind x y
= x
@ y
in
75 let option_default = [] in
79 let donothing builder r k e
=
80 match Ast0.get_mcodekind e
with
81 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
84 (* special case for everything that contains whencode, so that we skip over
86 let expression r k e
=
87 donothing Ast0.expr r k
89 (match Ast0.unwrap e
with
90 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
91 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
92 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
93 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
94 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
97 let initialiser r k i
=
98 donothing Ast0.ini r k
100 (match Ast0.unwrap i
with
101 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
104 let statement r k s
=
105 donothing Ast0.stmt r k
107 (match Ast0.unwrap s
with
108 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
109 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
110 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
111 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
112 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
115 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
118 V0.flat_combiner
bind option_default
119 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
120 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
121 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
122 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
123 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
124 (donothing Ast0.param
) (donothing Ast0.decl
) statement
125 (donothing Ast0.case_line
) topfn in
126 res.VT0.combiner_rec_top_level e
128 (* --------------------------------------------------------------------- *)
129 (* --------------------------------------------------------------------- *)
130 (* collect the possible join points, in order, among the children of a
131 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
132 because their delimiters take up a line by themselves *)
134 (* An Unfavored token is one that is in a BindContext node; using this causes
135 the node to become Neither, meaning that isomorphisms can't be applied *)
136 (* Toplevel is for the bef token of a function declaration and is for
137 attaching top-level definitions that should come before the complete
139 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
141 (* Maps the index of a node to the indices of the mcodes it contains *)
142 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
144 let create_root_token_table minus
=
150 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
151 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
152 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
153 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
154 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
155 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
156 | Ast0.IdentTag
(d
) -> Ast0.get_index d
157 | Ast0.ExprTag
(d
) -> Ast0.get_index d
158 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
159 failwith
"not possible - iso only"
160 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
161 | Ast0.ParamTag
(d
) -> Ast0.get_index d
162 | Ast0.InitTag
(d
) -> Ast0.get_index d
163 | Ast0.DeclTag
(d
) -> Ast0.get_index d
164 | Ast0.StmtTag
(d
) -> Ast0.get_index d
165 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
166 | Ast0.TopTag
(d
) -> Ast0.get_index d
167 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
168 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
169 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
170 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
172 Hashtbl.add
root_token_table key tokens
)
176 let index = Ast0.get_index r
in
177 try let _ = Hashtbl.find
root_token_table index in ()
178 with Not_found
-> Hashtbl.add
root_token_table index [])
181 let collect_minus_join_points root
=
182 let root_index = Ast0.get_index root
in
183 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
184 let bind x y
= x
@ y
in
185 let option_default = [] in
187 let mcode (x
,_,info
,mcodekind
,_,_) =
188 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
189 then [(Unfavored
,info
,mcodekind
)]
190 else [(Favored
,info
,mcodekind
)] in
192 let do_nothing r k e
=
193 let info = Ast0.get_info e
in
194 let index = Ast0.get_index e
in
195 match Ast0.get_mcodekind e
with
196 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
197 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
198 (* This was unfavored at one point, but I don't remember why *)
202 (* don't want to attach to the outside of DOTS, because metavariables can't
203 bind to that; not good for isomorphisms *)
207 let rec loop = function
210 | x
::xs
-> bind x
(loop xs
) in
213 match Ast0.unwrap d
with
214 Ast0.DOTS
(l
) -> multibind (List.map f l
)
215 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
216 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
218 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
219 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
220 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
221 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
222 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
223 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
225 (* a case for everything that has a Opt *)
227 let statement r k s
=
229 let redo_branched res (ifinfo,aftmc) =
230 let redo fv info mc rest =
231 let new_info = {info with Ast0.attachable_end = false} in
232 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
233 match List.rev res with
236 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
237 (* even for -, better for isos not to integrate code after an
239 but the problem is that this can extend the region in
240 which a variable is bound, because a variable bound in the
241 aft node would seem to have to be live in the whole if,
242 whereas we might like it to be live in only one branch.
243 ie ideally, if we can keep the minus code in the right
244 order, we would like to drop it as close to the bindings
245 of its free variables. This could be anywhere in the minus
246 code. Perhaps we would like to do this after the
247 application of isomorphisms, though.
251 | (fv
,info,mc
)::rest
->
253 Ast0.CONTEXT
(_) -> redo fv
info mc rest
255 | _ -> failwith
"unexpected empty code" in *)
256 match Ast0.unwrap s
with
257 (* Ast0.IfThen(_,_,_,_,_,aft)
258 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
259 | Ast0.While(_,_,_,_,_,aft)
260 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
261 | Ast0.Iterator(_,_,_,_,_,aft) ->
262 redo_branched (do_nothing r k s) aft*)
263 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
264 (Toplevel
,info,bef
)::(k s
)
265 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
266 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
267 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
269 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
270 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
271 | Ast0.OptStm s
| Ast0.UniqueStm s
->
272 (* put the + code on the thing, not on the opt *)
273 r
.VT0.combiner_rec_statement s
274 | _ -> do_nothing r k s
in
276 let expression r k e
=
277 match Ast0.unwrap e
with
278 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
280 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
281 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
282 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
283 | Ast0.OptExp e
| Ast0.UniqueExp e
->
284 (* put the + code on the thing, not on the opt *)
285 r
.VT0.combiner_rec_expression e
286 | _ -> do_nothing r k e
in
289 match Ast0.unwrap e
with
290 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
291 (* put the + code on the thing, not on the opt *)
292 r
.VT0.combiner_rec_ident i
293 | _ -> do_nothing r k e
in
296 match Ast0.unwrap e
with
297 Ast0.OptType t
| Ast0.UniqueType t
->
298 (* put the + code on the thing, not on the opt *)
299 r
.VT0.combiner_rec_typeC t
300 | _ -> do_nothing r k e
in
303 match Ast0.unwrap e
with
304 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
305 (* put the + code on the thing, not on the opt *)
306 r
.VT0.combiner_rec_declaration d
307 | _ -> do_nothing r k e
in
309 let initialiser r k e
=
310 match Ast0.unwrap e
with
311 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
312 | Ast0.OptIni i
| Ast0.UniqueIni i
->
313 (* put the + code on the thing, not on the opt *)
314 r
.VT0.combiner_rec_initialiser i
315 | _ -> do_nothing r k e
in
318 match Ast0.unwrap e
with
319 Ast0.OptParam p
| Ast0.UniqueParam p
->
320 (* put the + code on the thing, not on the opt *)
321 r
.VT0.combiner_rec_parameter p
322 | _ -> do_nothing r k e
in
324 let case_line r k e
=
325 match Ast0.unwrap e
with
327 (* put the + code on the thing, not on the opt *)
328 r
.VT0.combiner_rec_case_line c
329 | _ -> do_nothing r k e
in
331 let do_top r k
(e
: Ast0.top_level
) = k e
in
333 V0.flat_combiner
bind option_default
334 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
335 edots idots pdots sdots ddots cdots
336 ident expression typeC initialiser param decl statement case_line do_top
339 let call_collect_minus context_nodes
:
340 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
344 Ast0.DotsExprTag
(e
) ->
346 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
347 | Ast0.DotsInitTag
(e
) ->
349 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
350 | Ast0.DotsParamTag
(e
) ->
352 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
353 | Ast0.DotsStmtTag
(e
) ->
355 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
356 | Ast0.DotsDeclTag
(e
) ->
358 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
359 | Ast0.DotsCaseTag
(e
) ->
361 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
362 | Ast0.IdentTag
(e
) ->
364 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
367 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
368 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
369 failwith
"not possible - iso only"
370 | Ast0.TypeCTag
(e
) ->
372 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
373 | Ast0.ParamTag
(e
) ->
375 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
378 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
381 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
384 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
385 | Ast0.CaseLineTag
(e
) ->
387 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
390 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
391 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
392 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
393 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
394 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
397 (* result of collecting the join points should be sorted in nondecreasing
400 let get_info = function
401 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
402 | (Decl
,info,_) -> info in
403 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
404 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
405 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
406 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
409 (index,((_::_) as l1
)) ->
412 (function (prev
,real_prev
) ->
414 let ln = token_start_line cur
in
419 "error in collection of - tokens: line %d less than line %d"
420 (token_real_start_line cur
) real_prev
);
421 (token_end_line cur
,token_real_end_line cur
))
422 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
425 | _ -> ()) (* dots, in eg f() has no join points *)
428 let process_minus minus
=
429 create_root_token_table minus
;
433 let res = call_collect_minus (collect_context x
) in
438 (* --------------------------------------------------------------------- *)
439 (* --------------------------------------------------------------------- *)
440 (* collect the plus tokens *)
442 let mk_structUnion x
= Ast.StructUnionTag x
443 let mk_sign x
= Ast.SignTag x
444 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
445 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
446 let mk_constant x
= Ast.ConstantTag x
447 let mk_unaryOp x
= Ast.UnaryOpTag x
448 let mk_assignOp x
= Ast.AssignOpTag x
449 let mk_fixOp x
= Ast.FixOpTag x
450 let mk_binaryOp x
= Ast.BinaryOpTag x
451 let mk_arithOp x
= Ast.ArithOpTag x
452 let mk_logicalOp x
= Ast.LogicalOpTag x
453 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
454 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
455 let mk_storage x
= Ast.StorageTag x
456 let mk_inc_file x
= Ast.IncFileTag x
457 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
458 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
459 let mk_const_vol x
= Ast.ConstVolTag x
460 let mk_token x
info = Ast.Token
(x
,Some
info)
461 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
462 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
464 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
465 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
466 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
467 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
468 let mk_casedots x
= failwith
"+ case lines not supported"
469 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
470 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
471 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
473 let collect_plus_nodes root
=
474 let root_index = Ast0.get_index root
in
476 let bind x y
= x
@ y
in
477 let option_default = [] in
479 let extract_strings info =
481 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
482 let extract = function
485 let (_,first
) = List.hd strings_before
in
486 let (_,last
) = List.hd
(List.rev strings_before
) in
488 {Ast0.line_start
= first
.Ast0.line_start
;
489 Ast0.line_end
= last
.Ast0.line_start
;
490 Ast0.logical_start
= first
.Ast0.logical_start
;
491 Ast0.logical_end
= last
.Ast0.logical_start
;
492 Ast0.column
= first
.Ast0.column
;
493 Ast0.offset
= first
.Ast0.offset
} in
494 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
495 let string = List.map
(function (s
,_) -> s
) strings_before
in
496 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
497 let bef = extract info.Ast0.strings_before
in
498 let aft = extract info.Ast0.strings_after
in
501 let mcode fn
(term
,_,info,mcodekind
,_,_) =
503 Ast0.PLUS c
-> [(info,c
,fn term
)]
504 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
507 let imcode fn
(term
,_,info,mcodekind
,_,_) =
509 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
510 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
513 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
515 let do_nothing fn r k e
=
516 match Ast0.get_mcodekind e
with
517 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
518 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
521 (* case for everything that is just a wrapper for a simpler thing *)
522 (* case for things with bef aft *)
524 match Ast0.unwrap e
with
525 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
526 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
527 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
528 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
529 | Ast0.Decl
(bef,decl) ->
530 (info bef) @ (do_nothing mk_statement r k e
)
531 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
532 (info bef) @ (do_nothing mk_statement r k e
)
533 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
534 (do_nothing mk_statement r k e
) @ (info aft)
535 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
536 (do_nothing mk_statement r k e
) @ (info aft)
537 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
538 (do_nothing mk_statement r k e
) @ (info aft)
539 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
540 (do_nothing mk_statement r k e
) @ (info aft)
541 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
542 (do_nothing mk_statement r k e
) @ (info aft)
543 | _ -> do_nothing mk_statement r k e
in
545 (* statementTag is preferred, because it indicates that one statement is
546 replaced by one statement, in single_statement *)
547 let stmt_dots r k e
=
548 match Ast0.unwrap e
with
549 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
550 r
.VT0.combiner_rec_statement s
551 | _ -> do_nothing mk_stmtdots r k e
in
554 match Ast0.unwrap e
with
555 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
556 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
557 | _ -> do_nothing mk_code r k e
in
559 let initdots r k e
= k e
in
561 V0.flat_combiner
bind option_default
562 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
564 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
565 (mcode mk_sign) (mcode mk_structUnion)
566 (mcode mk_storage) (mcode mk_inc_file)
567 (do_nothing mk_exprdots) initdots
568 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
569 (do_nothing mk_casedots)
570 (do_nothing mk_ident) (do_nothing mk_expression)
571 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
572 (do_nothing mk_declaration)
573 stmt (do_nothing mk_case_line) toplevel
575 let call_collect_plus context_nodes
:
576 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
580 Ast0.DotsExprTag
(e
) ->
582 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
583 | Ast0.DotsInitTag
(e
) ->
585 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
586 | Ast0.DotsParamTag
(e
) ->
588 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
589 | Ast0.DotsStmtTag
(e
) ->
591 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
592 | Ast0.DotsDeclTag
(e
) ->
594 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
595 | Ast0.DotsCaseTag
(e
) ->
597 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
598 | Ast0.IdentTag
(e
) ->
600 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
603 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
604 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
605 failwith
"not possible - iso only"
606 | Ast0.TypeCTag
(e
) ->
608 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
611 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
612 | Ast0.ParamTag
(e
) ->
614 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
617 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
620 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
621 | Ast0.CaseLineTag
(e
) ->
623 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
626 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
627 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
628 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
629 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
630 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
633 (* The plus fragments are converted to a list of lists of lists.
634 Innermost list: Elements have type anything. For any pair of successive
635 elements, n and n+1, the ending line of n is the same as the starting line
637 Middle lists: For any pair of successive elements, n and n+1, the ending
638 line of n is one less than the starting line of n+1.
639 Outer list: For any pair of successive elements, n and n+1, the ending
640 line of n is more than one less than the starting line of n+1. *)
642 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
643 let logend info = info.Ast0.pos_info
.Ast0.logical_end
645 let redo info start finish
=
647 {info.Ast0.pos_info
with
648 Ast0.logical_start
= start
;
649 Ast0.logical_end
= finish
} in
650 {info with Ast0.pos_info
= new_pos_info}
652 let rec find_neighbors (index,l
) :
653 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
654 let rec loop = function
657 (match loop rest
with
658 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
659 let finish1 = logend i
in
660 let start2 = logstart i1
in
663 ((if not
(c
= c1
) then failwith
"inconsistent + code");
664 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
667 else if finish1 + 1 = start2
668 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
670 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
671 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
675 let (start_info
,start_count
,_) = List.hd l
in
676 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
677 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
678 (redo start_info
(logstart start_info
) (logend end_info
),
680 List.map
(function (_,_,x
) -> x
) l
))
684 let process_plus plus
:
685 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
689 List.map
find_neighbors (call_collect_plus (collect_context x
)))
692 (* --------------------------------------------------------------------- *)
693 (* --------------------------------------------------------------------- *)
696 let merge_one = function
697 (m1::m2::minus_info,p::plus_info) ->
699 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
700 if p > m1 && p < m2, then consider the following possibilities, in order
701 m1 is Good and favored: attach to the beginning of m1.aft
702 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
703 m1 is Good and unfavored: attach to the beginning of m1.aft
704 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
705 also flip m1.bef if the first where > m1
706 if we drop m1, then flip m1.aft first
708 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
711 (* end of first argument < start/end of second argument *)
712 let less_than_start info1 info2
=
713 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
714 let less_than_end info1 info2
=
715 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
716 let greater_than_end info1 info2
=
717 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
718 let good_start info = info.Ast0.attachable_start
719 let good_end info = info.Ast0.attachable_end
721 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
722 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
723 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
727 (List.for_all
(function Ast.Code
_ | Ast.Pragma
_ -> true | _ -> false))
731 (List.for_all
(function Ast.StorageTag
_ -> true | _ -> false))
733 (* The following is probably not correct. The idea is to detect what
734 should be placed completely before the declaration. So type/storage
735 related things do not fall into this category, and complete statements do
736 fall into this category. But perhaps other things should be in this
737 category as well, such as { or ;? *)
739 let tester = function
740 (* the following should definitely be true *)
746 | Ast.Pragma
_ -> true
747 (* the following should definitely be false *)
748 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
750 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
751 (* not sure about the rest *)
753 List.for_all
(List.for_all
tester)
755 let pr = Printf.sprintf
757 let insert thing thinginfo into intoinfo
=
758 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
759 let get_first l = (List.hd
l,List.tl
l) in
760 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
761 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
762 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
763 let into_start = intoinfo
.Ast0.tline_start
in
764 let into_end = intoinfo
.Ast0.tline_end
in
765 let into_left_offset = intoinfo
.Ast0.left_offset
in
766 let into_right_offset = intoinfo
.Ast0.right_offset
in
767 if thing_end < into_start && thing_start < into_start
769 {{intoinfo
with Ast0.tline_start
= thing_start}
770 with Ast0.left_offset
= thing_offset})
771 else if thing_end = into_start && thing_offset < into_left_offset
773 let (prev
,last
) = get_last thing
in
774 let (first
,rest
) = get_first into
in
775 (prev
@[last
@first
]@rest
,
776 {{intoinfo
with Ast0.tline_start
= thing_start}
777 with Ast0.left_offset
= thing_offset})
778 else if thing_start > into_end && thing_end > into_end
780 {{intoinfo
with Ast0.tline_end
= thing_end}
781 with Ast0.right_offset
= thing_offset})
782 else if thing_start = into_end && thing_offset > into_right_offset
784 let (first
,rest
) = get_first thing
in
785 let (prev
,last
) = get_last into
in
786 (prev
@[last
@first
]@rest
,
787 {{intoinfo
with Ast0.tline_end
= thing_end}
788 with Ast0.right_offset
= thing_offset})
791 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
792 thing_start thing_end into_start into_end;
793 Printf.printf
"thing offset %d left offset %d right offset %d\n"
794 thing_offset into_left_offset into_right_offset;
795 Pretty_print_cocci.print_anything
"" thing
;
796 Pretty_print_cocci.print_anything
"" into
;
797 failwith
"can't figure out where to put the + code"
800 let init thing
info =
802 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
803 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
804 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
805 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
807 let attachbefore (infop
,c
,p
) = function
808 Ast0.MINUS
(replacements
) ->
809 let (repl
,ti
) = !replacements
in
813 | repl
-> insert p infop repl ti
in
814 replacements
:= (bef,ti
)
815 | Ast0.CONTEXT
(neighbors
) ->
816 let (repl
,ti1
,ti2
) = !neighbors
in
818 Ast.BEFORE
(bef,it
) ->
819 let (bef,ti1
) = insert p infop
bef ti1
in
820 let it = Ast.lub_count
it c
in
821 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
822 | Ast.AFTER
(aft,it) ->
823 let (bef,ti1
) = init p infop
in
824 let it = Ast.lub_count
it c
in
825 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
826 | Ast.BEFOREAFTER
(bef,aft,it) ->
827 let (bef,ti1
) = insert p infop
bef ti1
in
828 let it = Ast.lub_count
it c
in
829 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
831 let (bef,ti1
) = init p infop
in
832 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
833 | _ -> failwith
"not possible for attachbefore"
835 let attachafter (infop
,c
,p
) = function
836 Ast0.MINUS
(replacements
) ->
837 let (repl
,ti
) = !replacements
in
841 | repl
-> insert p infop repl ti
in
842 replacements
:= (aft,ti
)
843 | Ast0.CONTEXT
(neighbors
) ->
844 let (repl
,ti1
,ti2
) = !neighbors
in
846 Ast.BEFORE
(bef,it) ->
847 let (aft,ti2
) = init p infop
in
848 let it = Ast.lub_count
it c
in
849 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
850 | Ast.AFTER
(aft,it) ->
851 let (aft,ti2
) = insert p infop
aft ti2
in
852 let it = Ast.lub_count
it c
in
853 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
854 | Ast.BEFOREAFTER
(bef,aft,it) ->
855 let (aft,ti2
) = insert p infop
aft ti2
in
856 let it = Ast.lub_count
it c
in
857 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
859 let (aft,ti2
) = init p infop
in
860 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
861 | _ -> failwith
"not possible for attachbefore"
863 let attach_all_before ps m
=
864 List.iter
(function x
-> attachbefore x m
) ps
866 let attach_all_after ps m
=
867 List.iter
(function x
-> attachafter x m
) ps
869 let split_at_end info ps
=
870 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
872 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
875 let allminus = function
876 Ast0.MINUS
(_) -> true
879 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
881 | (((infop
,_,pcode
) as p
) :: ps
) as all
->
882 if less_than_start infop infom1
or
883 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
887 if storage_code pcode
888 then before_m2 x2 rest all
(* skip fake token for storage *)
889 else (attachbefore p m1
; before_m1 x1 x2 rest ps
)
892 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
895 (pr "%d: no available token to attach to"
896 infop
.Ast0.pos_info
.Ast0.line_start
)
897 else after_m1 x1 x2 rest all
899 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
901 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
902 (* if the following is false, then some + code is stuck in the middle
903 of some context code (m1). could drop down to the token level.
904 this might require adjustments in ast0toast as well, when + code on
905 expressions is dropped down to + code on expressions. it might
906 also break some invariants on which iso depends, particularly on
907 what it can infer from something being CONTEXT with no top-level
908 modifications. for the moment, we thus give an error, asking the
909 user to rewrite the semantic patch. *)
910 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
912 if less_than_start infop infom2
914 if predecl_code pcode
&& good_end infom1
&& decl f1
915 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
916 else if predecl_code pcode
&& good_start infom2
&& decl f2
917 then before_m2 x2 rest all
918 else if top_code pcode
&& good_end infom1
&& toplevel f1
919 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
920 else if top_code pcode
&& good_start infom2
&& toplevel f2
921 then before_m2 x2 rest all
922 else if good_end infom1
&& favored f1
923 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
924 else if good_start infom2
&& favored f2
925 then before_m2 x2 rest all
926 else if good_end infom1
927 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
928 else if good_start infom2
929 then before_m2 x2 rest all
932 (pr "%d: no available token to attach to"
933 infop
.Ast0.pos_info
.Ast0.line_start
)
934 else after_m2 x2 rest all
937 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
938 infop
.Ast0.pos_info
.Ast0.line_start
939 infop
.Ast0.pos_info
.Ast0.line_end
940 infom1
.Ast0.pos_info
.Ast0.line_start
941 infom1
.Ast0.pos_info
.Ast0.line_end
942 infom2
.Ast0.pos_info
.Ast0.line_start
943 infom2
.Ast0.pos_info
.Ast0.line_end
;
944 Pretty_print_cocci.print_anything
"" pcode
;
946 "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."
949 (* not sure this is safe. if have iso problems, consider changing this
950 to always return false *)
951 and is_minus
= function
955 and before_m2
((f2
,infom2
,m2
) as x2
) rest
956 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
959 | ([],((infop
,_,_)::_)) ->
960 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
962 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
965 (pr "%d: no available token to attach to"
966 infop
.Ast0.pos_info
.Ast0.line_start
)
967 | (m
::ms
,_) -> before_m1 x2 m ms p
969 and after_m2
((f2
,infom2
,m2
) as x2
) rest
970 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
973 | ([],((infop
,_,_)::_)) ->
975 then attach_all_after p m2
978 (pr "%d: no available token to attach to"
979 infop
.Ast0.pos_info
.Ast0.line_start
)
980 | (m
::ms
,_) -> after_m1 x2 m ms p
982 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
983 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
986 Printf.printf "minus code\n";
988 (function (_,info,_) ->
989 Printf.printf "start %d end %d real_start %d real_end %d\n"
990 info.Ast0.pos_info.Ast0.logical_start
991 info.Ast0.pos_info.Ast0.logical_end
992 info.Ast0.pos_info.Ast0.line_start
993 info.Ast0.pos_info.Ast0.line_end)
995 Printf.printf "plus code\n";
997 (function (info,_,p) ->
998 Printf.printf "start %d end %d real_start %d real_end %d\n"
999 info.Ast0.pos_info.Ast0.logical_start
1000 info.Ast0.pos_info.Ast0.logical_end
1001 info.Ast0.pos_info.Ast0.line_end
1002 info.Ast0.pos_info.Ast0.line_end;
1003 Pretty_print_cocci.print_anything "" p;
1004 Format.print_newline())
1009 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
1010 | ([m
],p
) -> before_m2 m
[] p
1011 | ([],_) -> failwith
"minus tree ran out before the plus tree"
1013 let merge minus_list plus_list
=
1015 Printf.printf "minus list %s\n"
1017 (List.map (function (x,_) -> string_of_int x) minus_list));
1018 Printf.printf "plus list %s\n"
1020 (List.map (function (x,_) -> string_of_int x) plus_list));
1023 (function (index,minus_info
) ->
1024 let plus_info = List.assoc
index plus_list
in
1025 merge_one (minus_info
,plus_info))
1028 (* --------------------------------------------------------------------- *)
1029 (* --------------------------------------------------------------------- *)
1030 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1031 If they do, they become MIXED *)
1033 let reevaluate_contextness =
1035 let option_default = [] in
1037 let mcode (_,_,_,mc
,_,_) =
1039 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1044 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1047 let donothing r k e
=
1048 match Ast0.get_mcodekind e
with
1050 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1051 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1053 | _ -> let _ = k e
in [] in
1055 (* a case for everything with bef or aft *)
1057 match Ast0.unwrap e
with
1058 Ast0.Decl
(bef,decl) ->
1059 (info bef) @ (donothing r k e
)
1060 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1061 (info bef) @ (donothing r k e
)
1062 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1063 (donothing r k e
) @ (info aft)
1064 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1065 (donothing r k e
) @ (info aft)
1066 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1067 (donothing r k e
) @ (info aft)
1068 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1069 (donothing r k e
) @ (info aft)
1070 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1071 (donothing r k e
) @ (info aft)
1072 | _ -> donothing r k e
in
1075 V0.flat_combiner
bind option_default
1076 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1077 donothing donothing donothing donothing donothing donothing donothing
1079 donothing donothing donothing donothing stmt donothing donothing in
1080 res.VT0.combiner_rec_top_level
1082 (* --------------------------------------------------------------------- *)
1083 (* --------------------------------------------------------------------- *)
1085 let insert_plus minus plus ei
=
1087 let minus_stream = process_minus minus
in
1088 let plus_stream = process_plus plus
in
1089 merge minus_stream plus_stream;
1090 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus