2 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
3 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
4 * This file is part of Coccinelle.
6 * Coccinelle is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU General Public License as published by
8 * the Free Software Foundation, according to version 2 of the License.
10 * Coccinelle is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
18 * The authors reserve the right to distribute this or future versions of
19 * Coccinelle under other licenses.
24 * Copyright 2005-2010, Ecole des Mines de Nantes, University of Copenhagen
25 * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller, Nicolas Palix
26 * This file is part of Coccinelle.
28 * Coccinelle is free software: you can redistribute it and/or modify
29 * it under the terms of the GNU General Public License as published by
30 * the Free Software Foundation, according to version 2 of the License.
32 * Coccinelle is distributed in the hope that it will be useful,
33 * but WITHOUT ANY WARRANTY; without even the implied warranty of
34 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
35 * GNU General Public License for more details.
37 * You should have received a copy of the GNU General Public License
38 * along with Coccinelle. If not, see <http://www.gnu.org/licenses/>.
40 * The authors reserve the right to distribute this or future versions of
41 * Coccinelle under other licenses.
45 (* The error message "no available token to attach to" often comes in an
46 argument list of unbounded length. In this case, one should move a comma so
47 that there is a comma after the + code. *)
49 (* Start at all of the corresponding BindContext nodes in the minus and
50 plus trees, and traverse their children. We take the same strategy as
51 before: collect the list of minus/context nodes/tokens and the list of plus
52 tokens, and then merge them. *)
54 module Ast
= Ast_cocci
55 module Ast0
= Ast0_cocci
56 module V0
= Visitor_ast0
57 module VT0
= Visitor_ast0_types
58 module CN
= Context_neg
60 let empty_isos = ref false
62 let get_option f
= function
66 (* --------------------------------------------------------------------- *)
67 (* Collect root and all context nodes in a tree *)
69 let collect_context e
=
70 let bind x y
= x
@ y
in
71 let option_default = [] in
75 let donothing builder r k e
=
76 match Ast0.get_mcodekind e
with
77 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
80 (* special case for everything that contains whencode, so that we skip over
82 let expression r k e
=
83 donothing Ast0.expr r k
85 (match Ast0.unwrap e
with
86 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
87 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
88 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
89 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
90 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
93 let initialiser r k i
=
94 donothing Ast0.ini r k
96 (match Ast0.unwrap i
with
97 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
100 let statement r k s
=
101 donothing Ast0.stmt r k
103 (match Ast0.unwrap s
with
104 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
105 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
106 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
107 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
108 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
111 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
114 V0.flat_combiner
bind option_default
115 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
116 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
117 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
118 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
119 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
120 (donothing Ast0.param
) (donothing Ast0.decl
) statement
121 (donothing Ast0.case_line
) topfn in
122 res.VT0.combiner_rec_top_level e
124 (* --------------------------------------------------------------------- *)
125 (* --------------------------------------------------------------------- *)
126 (* collect the possible join points, in order, among the children of a
127 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
128 because their delimiters take up a line by themselves *)
130 (* An Unfavored token is one that is in a BindContext node; using this causes
131 the node to become Neither, meaning that isomorphisms can't be applied *)
132 (* Toplevel is for the bef token of a function declaration and is for
133 attaching top-level definitions that should come before the complete
135 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
137 (* Maps the index of a node to the indices of the mcodes it contains *)
138 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
140 let create_root_token_table minus
=
146 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
147 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
148 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
149 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
150 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
151 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
152 | Ast0.IdentTag
(d
) -> Ast0.get_index d
153 | Ast0.ExprTag
(d
) -> Ast0.get_index d
154 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
155 failwith
"not possible - iso only"
156 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
157 | Ast0.ParamTag
(d
) -> Ast0.get_index d
158 | Ast0.InitTag
(d
) -> Ast0.get_index d
159 | Ast0.DeclTag
(d
) -> Ast0.get_index d
160 | Ast0.StmtTag
(d
) -> Ast0.get_index d
161 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
162 | Ast0.TopTag
(d
) -> Ast0.get_index d
163 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
164 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
165 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
166 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
168 Hashtbl.add
root_token_table key tokens
)
172 let index = Ast0.get_index r
in
173 try let _ = Hashtbl.find
root_token_table index in ()
174 with Not_found
-> Hashtbl.add
root_token_table index [])
177 let collect_minus_join_points root
=
178 let root_index = Ast0.get_index root
in
179 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
180 let bind x y
= x
@ y
in
181 let option_default = [] in
183 let mcode (x
,_,info
,mcodekind
,_,_) =
184 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
185 then [(Unfavored
,info
,mcodekind
)]
186 else [(Favored
,info
,mcodekind
)] in
188 let do_nothing r k e
=
189 let info = Ast0.get_info e
in
190 let index = Ast0.get_index e
in
191 match Ast0.get_mcodekind e
with
192 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
193 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
194 (* This was unfavored at one point, but I don't remember why *)
198 (* don't want to attach to the outside of DOTS, because metavariables can't
199 bind to that; not good for isomorphisms *)
203 let rec loop = function
206 | x
::xs
-> bind x
(loop xs
) in
209 match Ast0.unwrap d
with
210 Ast0.DOTS
(l
) -> multibind (List.map f l
)
211 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
212 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
214 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
215 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
216 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
217 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
218 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
219 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
221 (* a case for everything that has a Opt *)
223 let statement r k s
=
225 let redo_branched res (ifinfo,aftmc) =
226 let redo fv info mc rest =
227 let new_info = {info with Ast0.attachable_end = false} in
228 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
229 match List.rev res with
232 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
233 (* even for -, better for isos not to integrate code after an
235 but the problem is that this can extend the region in
236 which a variable is bound, because a variable bound in the
237 aft node would seem to have to be live in the whole if,
238 whereas we might like it to be live in only one branch.
239 ie ideally, if we can keep the minus code in the right
240 order, we would like to drop it as close to the bindings
241 of its free variables. This could be anywhere in the minus
242 code. Perhaps we would like to do this after the
243 application of isomorphisms, though.
247 | (fv
,info,mc
)::rest
->
249 Ast0.CONTEXT
(_) -> redo fv
info mc rest
251 | _ -> failwith
"unexpected empty code" in *)
252 match Ast0.unwrap s
with
253 (* Ast0.IfThen(_,_,_,_,_,aft)
254 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
255 | Ast0.While(_,_,_,_,_,aft)
256 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
257 | Ast0.Iterator(_,_,_,_,_,aft) ->
258 redo_branched (do_nothing r k s) aft*)
259 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
260 (Toplevel
,info,bef
)::(k s
)
261 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
262 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
263 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
265 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
266 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
267 | Ast0.OptStm s
| Ast0.UniqueStm s
->
268 (* put the + code on the thing, not on the opt *)
269 r
.VT0.combiner_rec_statement s
270 | _ -> do_nothing r k s
in
272 let expression r k e
=
273 match Ast0.unwrap e
with
274 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
276 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
277 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
278 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
279 | Ast0.OptExp e
| Ast0.UniqueExp e
->
280 (* put the + code on the thing, not on the opt *)
281 r
.VT0.combiner_rec_expression e
282 | _ -> do_nothing r k e
in
285 match Ast0.unwrap e
with
286 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
287 (* put the + code on the thing, not on the opt *)
288 r
.VT0.combiner_rec_ident i
289 | _ -> do_nothing r k e
in
292 match Ast0.unwrap e
with
293 Ast0.OptType t
| Ast0.UniqueType t
->
294 (* put the + code on the thing, not on the opt *)
295 r
.VT0.combiner_rec_typeC t
296 | _ -> do_nothing r k e
in
299 match Ast0.unwrap e
with
300 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
301 (* put the + code on the thing, not on the opt *)
302 r
.VT0.combiner_rec_declaration d
303 | _ -> do_nothing r k e
in
305 let initialiser r k e
=
306 match Ast0.unwrap e
with
307 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
308 | Ast0.OptIni i
| Ast0.UniqueIni i
->
309 (* put the + code on the thing, not on the opt *)
310 r
.VT0.combiner_rec_initialiser i
311 | _ -> do_nothing r k e
in
314 match Ast0.unwrap e
with
315 Ast0.OptParam p
| Ast0.UniqueParam p
->
316 (* put the + code on the thing, not on the opt *)
317 r
.VT0.combiner_rec_parameter p
318 | _ -> do_nothing r k e
in
320 let case_line r k e
=
321 match Ast0.unwrap e
with
323 (* put the + code on the thing, not on the opt *)
324 r
.VT0.combiner_rec_case_line c
325 | _ -> do_nothing r k e
in
327 let do_top r k
(e
: Ast0.top_level
) = k e
in
329 V0.flat_combiner
bind option_default
330 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
331 edots idots pdots sdots ddots cdots
332 ident expression typeC initialiser param decl statement case_line do_top
335 let call_collect_minus context_nodes
:
336 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
340 Ast0.DotsExprTag
(e
) ->
342 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
343 | Ast0.DotsInitTag
(e
) ->
345 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
346 | Ast0.DotsParamTag
(e
) ->
348 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
349 | Ast0.DotsStmtTag
(e
) ->
351 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
352 | Ast0.DotsDeclTag
(e
) ->
354 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
355 | Ast0.DotsCaseTag
(e
) ->
357 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
358 | Ast0.IdentTag
(e
) ->
360 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
363 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
364 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
365 failwith
"not possible - iso only"
366 | Ast0.TypeCTag
(e
) ->
368 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
369 | Ast0.ParamTag
(e
) ->
371 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
374 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
377 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
380 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
381 | Ast0.CaseLineTag
(e
) ->
383 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
386 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
387 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
388 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
389 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
390 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
393 (* result of collecting the join points should be sorted in nondecreasing
396 let get_info = function
397 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
398 | (Decl
,info,_) -> info in
399 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
400 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
401 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
402 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
405 (index,((_::_) as l1
)) ->
408 (function (prev
,real_prev
) ->
410 let ln = token_start_line cur
in
415 "error in collection of - tokens: line %d less than line %d"
416 (token_real_start_line cur
) real_prev
);
417 (token_end_line cur
,token_real_end_line cur
))
418 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
421 | _ -> ()) (* dots, in eg f() has no join points *)
424 let process_minus minus
=
425 create_root_token_table minus
;
429 let res = call_collect_minus (collect_context x
) in
434 (* --------------------------------------------------------------------- *)
435 (* --------------------------------------------------------------------- *)
436 (* collect the plus tokens *)
438 let mk_structUnion x
= Ast.StructUnionTag x
439 let mk_sign x
= Ast.SignTag x
440 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
441 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
442 let mk_constant x
= Ast.ConstantTag x
443 let mk_unaryOp x
= Ast.UnaryOpTag x
444 let mk_assignOp x
= Ast.AssignOpTag x
445 let mk_fixOp x
= Ast.FixOpTag x
446 let mk_binaryOp x
= Ast.BinaryOpTag x
447 let mk_arithOp x
= Ast.ArithOpTag x
448 let mk_logicalOp x
= Ast.LogicalOpTag x
449 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
450 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
451 let mk_storage x
= Ast.StorageTag x
452 let mk_inc_file x
= Ast.IncFileTag x
453 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
454 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
455 let mk_const_vol x
= Ast.ConstVolTag x
456 let mk_token x
info = Ast.Token
(x
,Some
info)
457 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
458 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
460 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
461 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
462 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
463 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
464 let mk_casedots x
= failwith
"+ case lines not supported"
465 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
466 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
467 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
469 let collect_plus_nodes root
=
470 let root_index = Ast0.get_index root
in
472 let bind x y
= x
@ y
in
473 let option_default = [] in
475 let extract_strings info =
477 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
478 let extract = function
481 let (_,first
) = List.hd strings_before
in
482 let (_,last
) = List.hd
(List.rev strings_before
) in
484 {Ast0.line_start
= first
.Ast0.line_start
;
485 Ast0.line_end
= last
.Ast0.line_start
;
486 Ast0.logical_start
= first
.Ast0.logical_start
;
487 Ast0.logical_end
= last
.Ast0.logical_start
;
488 Ast0.column
= first
.Ast0.column
;
489 Ast0.offset
= first
.Ast0.offset
} in
490 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
491 let string = List.map
(function (s
,_) -> s
) strings_before
in
492 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
493 let bef = extract info.Ast0.strings_before
in
494 let aft = extract info.Ast0.strings_after
in
497 let mcode fn
(term
,_,info,mcodekind
,_,_) =
499 Ast0.PLUS c
-> [(info,c
,fn term
)]
500 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
503 let imcode fn
(term
,_,info,mcodekind
,_,_) =
505 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
506 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
509 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
511 let do_nothing fn r k e
=
512 match Ast0.get_mcodekind e
with
513 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
514 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
517 (* case for everything that is just a wrapper for a simpler thing *)
518 (* case for things with bef aft *)
520 match Ast0.unwrap e
with
521 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
522 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
523 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
524 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
525 | Ast0.Decl
(bef,decl) ->
526 (info bef) @ (do_nothing mk_statement r k e
)
527 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
528 (info bef) @ (do_nothing mk_statement r k e
)
529 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
530 (do_nothing mk_statement r k e
) @ (info aft)
531 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
532 (do_nothing mk_statement r k e
) @ (info aft)
533 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
534 (do_nothing mk_statement r k e
) @ (info aft)
535 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
536 (do_nothing mk_statement r k e
) @ (info aft)
537 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
538 (do_nothing mk_statement r k e
) @ (info aft)
539 | _ -> do_nothing mk_statement r k e
in
541 (* statementTag is preferred, because it indicates that one statement is
542 replaced by one statement, in single_statement *)
543 let stmt_dots r k e
=
544 match Ast0.unwrap e
with
545 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
546 r
.VT0.combiner_rec_statement s
547 | _ -> do_nothing mk_stmtdots r k e
in
550 match Ast0.unwrap e
with
551 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
552 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
553 | _ -> do_nothing mk_code r k e
in
555 let initdots r k e
= k e
in
557 V0.flat_combiner
bind option_default
558 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
560 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
561 (mcode mk_sign) (mcode mk_structUnion)
562 (mcode mk_storage) (mcode mk_inc_file)
563 (do_nothing mk_exprdots) initdots
564 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
565 (do_nothing mk_casedots)
566 (do_nothing mk_ident) (do_nothing mk_expression)
567 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
568 (do_nothing mk_declaration)
569 stmt (do_nothing mk_case_line) toplevel
571 let call_collect_plus context_nodes
:
572 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
576 Ast0.DotsExprTag
(e
) ->
578 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
579 | Ast0.DotsInitTag
(e
) ->
581 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
582 | Ast0.DotsParamTag
(e
) ->
584 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
585 | Ast0.DotsStmtTag
(e
) ->
587 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
588 | Ast0.DotsDeclTag
(e
) ->
590 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
591 | Ast0.DotsCaseTag
(e
) ->
593 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
594 | Ast0.IdentTag
(e
) ->
596 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
599 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
600 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
601 failwith
"not possible - iso only"
602 | Ast0.TypeCTag
(e
) ->
604 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
607 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
608 | Ast0.ParamTag
(e
) ->
610 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
613 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
616 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
617 | Ast0.CaseLineTag
(e
) ->
619 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
622 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
623 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
624 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
625 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
626 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
629 (* The plus fragments are converted to a list of lists of lists.
630 Innermost list: Elements have type anything. For any pair of successive
631 elements, n and n+1, the ending line of n is the same as the starting line
633 Middle lists: For any pair of successive elements, n and n+1, the ending
634 line of n is one less than the starting line of n+1.
635 Outer list: For any pair of successive elements, n and n+1, the ending
636 line of n is more than one less than the starting line of n+1. *)
638 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
639 let logend info = info.Ast0.pos_info
.Ast0.logical_end
641 let redo info start finish
=
643 {info.Ast0.pos_info
with
644 Ast0.logical_start
= start
;
645 Ast0.logical_end
= finish
} in
646 {info with Ast0.pos_info
= new_pos_info}
648 let rec find_neighbors (index,l
) :
649 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
650 let rec loop = function
653 (match loop rest
with
654 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
655 let finish1 = logend i
in
656 let start2 = logstart i1
in
659 ((if not
(c
= c1
) then failwith
"inconsistent + code");
660 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
663 else if finish1 + 1 = start2
664 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
666 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
667 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
671 let (start_info
,start_count
,_) = List.hd l
in
672 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
673 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
674 (redo start_info
(logstart start_info
) (logend end_info
),
676 List.map
(function (_,_,x
) -> x
) l
))
680 let process_plus plus
:
681 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
685 List.map
find_neighbors (call_collect_plus (collect_context x
)))
688 (* --------------------------------------------------------------------- *)
689 (* --------------------------------------------------------------------- *)
692 let merge_one = function
693 (m1::m2::minus_info,p::plus_info) ->
695 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
696 if p > m1 && p < m2, then consider the following possibilities, in order
697 m1 is Good and favored: attach to the beginning of m1.aft
698 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
699 m1 is Good and unfavored: attach to the beginning of m1.aft
700 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
701 also flip m1.bef if the first where > m1
702 if we drop m1, then flip m1.aft first
704 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
707 (* end of first argument < start/end of second argument *)
708 let less_than_start info1 info2
=
709 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
710 let less_than_end info1 info2
=
711 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
712 let greater_than_end info1 info2
=
713 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
714 let good_start info = info.Ast0.attachable_start
715 let good_end info = info.Ast0.attachable_end
717 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
718 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
719 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
722 List.for_all
(List.for_all
(function Ast.Code
_ -> true | _ -> false))
724 (* The following is probably not correct. The idea is to detect what
725 should be placed completely before the declaration. So type/storage
726 related things do not fall into this category, and complete statements do
727 fall into this category. But perhaps other things should be in this
728 category as well, such as { or ;? *)
730 let tester = function
731 (* the following should definitely be true *)
737 | Ast.Pragma
_ -> true
738 (* the following should definitely be false *)
739 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
741 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
742 (* not sure about the rest *)
744 List.for_all
(List.for_all
tester)
746 let pr = Printf.sprintf
748 let insert thing thinginfo into intoinfo
=
749 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
750 let get_first l = (List.hd
l,List.tl
l) in
751 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
752 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
753 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
754 let into_start = intoinfo
.Ast0.tline_start
in
755 let into_end = intoinfo
.Ast0.tline_end
in
756 let into_left_offset = intoinfo
.Ast0.left_offset
in
757 let into_right_offset = intoinfo
.Ast0.right_offset
in
758 if thing_end < into_start && thing_start < into_start
760 {{intoinfo
with Ast0.tline_start
= thing_start}
761 with Ast0.left_offset
= thing_offset})
762 else if thing_end = into_start && thing_offset < into_left_offset
764 let (prev
,last
) = get_last thing
in
765 let (first
,rest
) = get_first into
in
766 (prev
@[last
@first
]@rest
,
767 {{intoinfo
with Ast0.tline_start
= thing_start}
768 with Ast0.left_offset
= thing_offset})
769 else if thing_start > into_end && thing_end > into_end
771 {{intoinfo
with Ast0.tline_end
= thing_end}
772 with Ast0.right_offset
= thing_offset})
773 else if thing_start = into_end && thing_offset > into_right_offset
775 let (first
,rest
) = get_first thing
in
776 let (prev
,last
) = get_last into
in
777 (prev
@[last
@first
]@rest
,
778 {{intoinfo
with Ast0.tline_end
= thing_end}
779 with Ast0.right_offset
= thing_offset})
782 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
783 thing_start thing_end into_start into_end;
784 Printf.printf
"thing offset %d left offset %d right offset %d\n"
785 thing_offset into_left_offset into_right_offset;
786 Pretty_print_cocci.print_anything
"" thing
;
787 Pretty_print_cocci.print_anything
"" into
;
788 failwith
"can't figure out where to put the + code"
791 let init thing
info =
793 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
794 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
795 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
796 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
798 let attachbefore (infop
,c
,p
) = function
799 Ast0.MINUS
(replacements
) ->
800 let (repl
,ti
) = !replacements
in
804 | repl
-> insert p infop repl ti
in
805 replacements
:= (bef,ti
)
806 | Ast0.CONTEXT
(neighbors
) ->
807 let (repl
,ti1
,ti2
) = !neighbors
in
809 Ast.BEFORE
(bef,it
) ->
810 let (bef,ti1
) = insert p infop
bef ti1
in
811 let it = Ast.lub_count
it c
in
812 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
813 | Ast.AFTER
(aft,it) ->
814 let (bef,ti1
) = init p infop
in
815 let it = Ast.lub_count
it c
in
816 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
817 | Ast.BEFOREAFTER
(bef,aft,it) ->
818 let (bef,ti1
) = insert p infop
bef ti1
in
819 let it = Ast.lub_count
it c
in
820 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
822 let (bef,ti1
) = init p infop
in
823 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
824 | _ -> failwith
"not possible for attachbefore"
826 let attachafter (infop
,c
,p
) = function
827 Ast0.MINUS
(replacements
) ->
828 let (repl
,ti
) = !replacements
in
832 | repl
-> insert p infop repl ti
in
833 replacements
:= (aft,ti
)
834 | Ast0.CONTEXT
(neighbors
) ->
835 let (repl
,ti1
,ti2
) = !neighbors
in
837 Ast.BEFORE
(bef,it) ->
838 let (aft,ti2
) = init p infop
in
839 let it = Ast.lub_count
it c
in
840 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
841 | Ast.AFTER
(aft,it) ->
842 let (aft,ti2
) = insert p infop
aft ti2
in
843 let it = Ast.lub_count
it c
in
844 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
845 | Ast.BEFOREAFTER
(bef,aft,it) ->
846 let (aft,ti2
) = insert p infop
aft ti2
in
847 let it = Ast.lub_count
it c
in
848 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
850 let (aft,ti2
) = init p infop
in
851 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
852 | _ -> failwith
"not possible for attachbefore"
854 let attach_all_before ps m
=
855 List.iter
(function x
-> attachbefore x m
) ps
857 let attach_all_after ps m
=
858 List.iter
(function x
-> attachafter x m
) ps
860 let split_at_end info ps
=
861 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
863 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
866 let allminus = function
867 Ast0.MINUS
(_) -> true
870 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
872 | (((infop
,_,_) as p
) :: ps
) as all
->
873 if less_than_start infop infom1
or
874 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
877 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
880 (pr "%d: no available token to attach to"
881 infop
.Ast0.pos_info
.Ast0.line_start
)
882 else after_m1 x1 x2 rest all
884 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
886 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
887 (* if the following is false, then some + code is stuck in the middle
888 of some context code (m1). could drop down to the token level.
889 this might require adjustments in ast0toast as well, when + code on
890 expressions is dropped down to + code on expressions. it might
891 also break some invariants on which iso depends, particularly on
892 what it can infer from something being CONTEXT with no top-level
893 modifications. for the moment, we thus give an error, asking the
894 user to rewrite the semantic patch. *)
895 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
897 if less_than_start infop infom2
899 if predecl_code pcode
&& good_end infom1
&& decl f1
900 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
901 else if predecl_code pcode
&& good_start infom2
&& decl f2
902 then before_m2 x2 rest all
903 else if top_code pcode
&& good_end infom1
&& toplevel f1
904 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
905 else if top_code pcode
&& good_start infom2
&& toplevel f2
906 then before_m2 x2 rest all
907 else if good_end infom1
&& favored f1
908 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
909 else if good_start infom2
&& favored f2
910 then before_m2 x2 rest all
911 else if good_end infom1
912 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
913 else if good_start infom2
914 then before_m2 x2 rest all
917 (pr "%d: no available token to attach to"
918 infop
.Ast0.pos_info
.Ast0.line_start
)
919 else after_m2 x2 rest all
922 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
923 infop
.Ast0.pos_info
.Ast0.line_start
924 infop
.Ast0.pos_info
.Ast0.line_end
925 infom1
.Ast0.pos_info
.Ast0.line_start
926 infom1
.Ast0.pos_info
.Ast0.line_end
927 infom2
.Ast0.pos_info
.Ast0.line_start
928 infom2
.Ast0.pos_info
.Ast0.line_end
;
929 Pretty_print_cocci.print_anything
"" pcode
;
931 "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."
934 (* not sure this is safe. if have iso problems, consider changing this
935 to always return false *)
936 and is_minus
= function
940 and before_m2
((f2
,infom2
,m2
) as x2
) rest
941 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
944 | ([],((infop
,_,_)::_)) ->
945 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
947 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
950 (pr "%d: no available token to attach to"
951 infop
.Ast0.pos_info
.Ast0.line_start
)
952 | (m
::ms
,_) -> before_m1 x2 m ms p
954 and after_m2
((f2
,infom2
,m2
) as x2
) rest
955 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
958 | ([],((infop
,_,_)::_)) ->
960 then attach_all_after p m2
963 (pr "%d: no available token to attach to"
964 infop
.Ast0.pos_info
.Ast0.line_start
)
965 | (m
::ms
,_) -> after_m1 x2 m ms p
967 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
968 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
971 Printf.printf "minus code\n";
973 (function (_,info,_) ->
974 Printf.printf "start %d end %d real_start %d real_end %d\n"
975 info.Ast0.pos_info.Ast0.logical_start
976 info.Ast0.pos_info.Ast0.logical_end
977 info.Ast0.pos_info.Ast0.line_start
978 info.Ast0.pos_info.Ast0.line_end)
980 Printf.printf "plus code\n";
982 (function (info,_,p) ->
983 Printf.printf "start %d end %d real_start %d real_end %d\n"
984 info.Ast0.pos_info.Ast0.logical_start
985 info.Ast0.pos_info.Ast0.logical_end
986 info.Ast0.pos_info.Ast0.line_end
987 info.Ast0.pos_info.Ast0.line_end;
988 Pretty_print_cocci.print_anything "" p;
989 Format.print_newline())
994 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
995 | ([m
],p
) -> before_m2 m
[] p
996 | ([],_) -> failwith
"minus tree ran out before the plus tree"
998 let merge minus_list plus_list
=
1000 Printf.printf "minus list %s\n"
1002 (List.map (function (x,_) -> string_of_int x) minus_list));
1003 Printf.printf "plus list %s\n"
1005 (List.map (function (x,_) -> string_of_int x) plus_list));
1008 (function (index,minus_info
) ->
1009 let plus_info = List.assoc
index plus_list
in
1010 merge_one (minus_info
,plus_info))
1013 (* --------------------------------------------------------------------- *)
1014 (* --------------------------------------------------------------------- *)
1015 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
1016 If they do, they become MIXED *)
1018 let reevaluate_contextness =
1020 let option_default = [] in
1022 let mcode (_,_,_,mc
,_,_) =
1024 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1029 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
1032 let donothing r k e
=
1033 match Ast0.get_mcodekind e
with
1035 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
1036 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
1038 | _ -> let _ = k e
in [] in
1040 (* a case for everything with bef or aft *)
1042 match Ast0.unwrap e
with
1043 Ast0.Decl
(bef,decl) ->
1044 (info bef) @ (donothing r k e
)
1045 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1046 (info bef) @ (donothing r k e
)
1047 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1048 (donothing r k e
) @ (info aft)
1049 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1050 (donothing r k e
) @ (info aft)
1051 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1052 (donothing r k e
) @ (info aft)
1053 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1054 (donothing r k e
) @ (info aft)
1055 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1056 (donothing r k e
) @ (info aft)
1057 | _ -> donothing r k e
in
1060 V0.flat_combiner
bind option_default
1061 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1062 donothing donothing donothing donothing donothing donothing donothing
1064 donothing donothing donothing donothing stmt donothing donothing in
1065 res.VT0.combiner_rec_top_level
1067 (* --------------------------------------------------------------------- *)
1068 (* --------------------------------------------------------------------- *)
1070 let insert_plus minus plus ei
=
1072 let minus_stream = process_minus minus
in
1073 let plus_stream = process_plus plus
in
1074 merge minus_stream plus_stream;
1075 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus