1 (* The error message "no available token to attach to" often comes in an
2 argument list of unbounded length. In this case, one should move a comma so
3 that there is a comma after the + code. *)
5 (* Start at all of the corresponding BindContext nodes in the minus and
6 plus trees, and traverse their children. We take the same strategy as
7 before: collect the list of minus/context nodes/tokens and the list of plus
8 tokens, and then merge them. *)
10 module Ast
= Ast_cocci
11 module Ast0
= Ast0_cocci
12 module V0
= Visitor_ast0
13 module VT0
= Visitor_ast0_types
14 module CN
= Context_neg
16 let empty_isos = ref false
18 let get_option f
= function
22 (* --------------------------------------------------------------------- *)
23 (* Collect root and all context nodes in a tree *)
25 let collect_context e
=
26 let bind x y
= x
@ y
in
27 let option_default = [] in
31 let donothing builder r k e
=
32 match Ast0.get_mcodekind e
with
33 Ast0.CONTEXT
(_
) -> (builder e
) :: (k e
)
36 (* special case for everything that contains whencode, so that we skip over
38 let expression r k e
=
39 donothing Ast0.expr r k
41 (match Ast0.unwrap e
with
42 Ast0.NestExpr
(starter
,exp
,ender
,whencode
,multi
) ->
43 Ast0.NestExpr
(starter
,exp
,ender
,None
,multi
)
44 | Ast0.Edots
(dots
,whencode
) -> Ast0.Edots
(dots
,None
)
45 | Ast0.Ecircles
(dots
,whencode
) -> Ast0.Ecircles
(dots
,None
)
46 | Ast0.Estars
(dots
,whencode
) -> Ast0.Estars
(dots
,None
)
49 let initialiser r k i
=
50 donothing Ast0.ini r k
52 (match Ast0.unwrap i
with
53 Ast0.Idots
(dots
,whencode
) -> Ast0.Idots
(dots
,None
)
57 donothing Ast0.stmt r k
59 (match Ast0.unwrap s
with
60 Ast0.Nest
(started
,stm_dots
,ender
,whencode
,multi
) ->
61 Ast0.Nest
(started
,stm_dots
,ender
,[],multi
)
62 | Ast0.Dots
(dots
,whencode
) -> Ast0.Dots
(dots
,[])
63 | Ast0.Circles
(dots
,whencode
) -> Ast0.Circles
(dots
,[])
64 | Ast0.Stars
(dots
,whencode
) -> Ast0.Stars
(dots
,[])
67 let topfn r k e
= Ast0.TopTag
(e
) :: (k e
) in
70 V0.flat_combiner
bind option_default
71 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
72 (donothing Ast0.dotsExpr
) (donothing Ast0.dotsInit
)
73 (donothing Ast0.dotsParam
) (donothing Ast0.dotsStmt
)
74 (donothing Ast0.dotsDecl
) (donothing Ast0.dotsCase
)
75 (donothing Ast0.ident
) expression (donothing Ast0.typeC
) initialiser
76 (donothing Ast0.param
) (donothing Ast0.decl
) statement
77 (donothing Ast0.case_line
) topfn in
78 res.VT0.combiner_rec_top_level e
80 (* --------------------------------------------------------------------- *)
81 (* --------------------------------------------------------------------- *)
82 (* collect the possible join points, in order, among the children of a
83 BindContext. Dots are not allowed. Nests and disjunctions are no problem,
84 because their delimiters take up a line by themselves *)
86 (* An Unfavored token is one that is in a BindContext node; using this causes
87 the node to become Neither, meaning that isomorphisms can't be applied *)
88 (* Toplevel is for the bef token of a function declaration and is for
89 attaching top-level definitions that should come before the complete
91 type minus_join_point
= Favored
| Unfavored
| Toplevel
| Decl
93 (* Maps the index of a node to the indices of the mcodes it contains *)
94 let root_token_table = (Hashtbl.create
(50) : (int, int list
) Hashtbl.t
)
96 let create_root_token_table minus
=
102 Ast0.DotsExprTag
(d
) -> Ast0.get_index d
103 | Ast0.DotsInitTag
(d
) -> Ast0.get_index d
104 | Ast0.DotsParamTag
(d
) -> Ast0.get_index d
105 | Ast0.DotsStmtTag
(d
) -> Ast0.get_index d
106 | Ast0.DotsDeclTag
(d
) -> Ast0.get_index d
107 | Ast0.DotsCaseTag
(d
) -> Ast0.get_index d
108 | Ast0.IdentTag
(d
) -> Ast0.get_index d
109 | Ast0.ExprTag
(d
) -> Ast0.get_index d
110 | Ast0.ArgExprTag
(d
) | Ast0.TestExprTag
(d
) ->
111 failwith
"not possible - iso only"
112 | Ast0.TypeCTag
(d
) -> Ast0.get_index d
113 | Ast0.ParamTag
(d
) -> Ast0.get_index d
114 | Ast0.InitTag
(d
) -> Ast0.get_index d
115 | Ast0.DeclTag
(d
) -> Ast0.get_index d
116 | Ast0.StmtTag
(d
) -> Ast0.get_index d
117 | Ast0.CaseLineTag
(d
) -> Ast0.get_index d
118 | Ast0.TopTag
(d
) -> Ast0.get_index d
119 | Ast0.IsoWhenTag
(_
) -> failwith
"only within iso phase"
120 | Ast0.IsoWhenTTag
(_
) -> failwith
"only within iso phase"
121 | Ast0.IsoWhenFTag
(_
) -> failwith
"only within iso phase"
122 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase"
124 Hashtbl.add
root_token_table key tokens
)
128 let index = Ast0.get_index r
in
129 try let _ = Hashtbl.find
root_token_table index in ()
130 with Not_found
-> Hashtbl.add
root_token_table index [])
133 let collect_minus_join_points root
=
134 let root_index = Ast0.get_index root
in
135 let unfavored_tokens = Hashtbl.find
root_token_table root_index in
136 let bind x y
= x
@ y
in
137 let option_default = [] in
139 let mcode (x
,_,info
,mcodekind
,_,_) =
140 if List.mem
(info
.Ast0.pos_info
.Ast0.offset
) unfavored_tokens
141 then [(Unfavored
,info
,mcodekind
)]
142 else [(Favored
,info
,mcodekind
)] in
144 let do_nothing r k e
=
145 let info = Ast0.get_info e
in
146 let index = Ast0.get_index e
in
147 match Ast0.get_mcodekind e
with
148 (Ast0.MINUS
(_)) as mc
-> [(Favored
,info,mc
)]
149 | (Ast0.CONTEXT
(_)) as mc
when not
(index = root_index) ->
150 (* This was unfavored at one point, but I don't remember why *)
154 (* don't want to attach to the outside of DOTS, because metavariables can't
155 bind to that; not good for isomorphisms *)
159 let rec loop = function
162 | x
::xs
-> bind x
(loop xs
) in
165 match Ast0.unwrap d
with
166 Ast0.DOTS
(l
) -> multibind (List.map f l
)
167 | Ast0.CIRCLES
(l
) -> multibind (List.map f l
)
168 | Ast0.STARS
(l
) -> multibind (List.map f l
) in
170 let edots r k d
= dots r
.VT0.combiner_rec_expression k d
in
171 let idots r k d
= dots r
.VT0.combiner_rec_initialiser k d
in
172 let pdots r k d
= dots r
.VT0.combiner_rec_parameter k d
in
173 let sdots r k d
= dots r
.VT0.combiner_rec_statement k d
in
174 let ddots r k d
= dots r
.VT0.combiner_rec_declaration k d
in
175 let cdots r k d
= dots r
.VT0.combiner_rec_case_line k d
in
177 (* a case for everything that has a Opt *)
179 let statement r k s
=
181 let redo_branched res (ifinfo,aftmc) =
182 let redo fv info mc rest =
183 let new_info = {info with Ast0.attachable_end = false} in
184 List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in
185 match List.rev res with
188 Ast0.MINUS(_) | Ast0.CONTEXT(_) ->
189 (* even for -, better for isos not to integrate code after an
191 but the problem is that this can extend the region in
192 which a variable is bound, because a variable bound in the
193 aft node would seem to have to be live in the whole if,
194 whereas we might like it to be live in only one branch.
195 ie ideally, if we can keep the minus code in the right
196 order, we would like to drop it as close to the bindings
197 of its free variables. This could be anywhere in the minus
198 code. Perhaps we would like to do this after the
199 application of isomorphisms, though.
203 | (fv
,info,mc
)::rest
->
205 Ast0.CONTEXT
(_) -> redo fv
info mc rest
207 | _ -> failwith
"unexpected empty code" in *)
208 match Ast0.unwrap s
with
209 (* Ast0.IfThen(_,_,_,_,_,aft)
210 | Ast0.IfThenElse(_,_,_,_,_,_,_,aft)
211 | Ast0.While(_,_,_,_,_,aft)
212 | Ast0.For(_,_,_,_,_,_,_,_,_,aft)
213 | Ast0.Iterator(_,_,_,_,_,aft) ->
214 redo_branched (do_nothing r k s) aft*)
215 | Ast0.FunDecl
((info,bef
),fninfo
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
216 (Toplevel
,info,bef
)::(k s
)
217 | Ast0.Decl
((info,bef
),decl
) -> (Decl
,info,bef
)::(k s
)
218 | Ast0.Nest
(starter
,stmt_dots
,ender
,whencode
,multi
) ->
219 mcode starter
@ r
.VT0.combiner_rec_statement_dots stmt_dots
@
221 | Ast0.Dots
(d
,whencode
) | Ast0.Circles
(d
,whencode
)
222 | Ast0.Stars
(d
,whencode
) -> mcode d
(* ignore whencode *)
223 | Ast0.OptStm s
| Ast0.UniqueStm s
->
224 (* put the + code on the thing, not on the opt *)
225 r
.VT0.combiner_rec_statement s
226 | _ -> do_nothing r k s
in
228 let expression r k e
=
229 match Ast0.unwrap e
with
230 Ast0.NestExpr
(starter
,expr_dots
,ender
,whencode
,multi
) ->
232 r
.VT0.combiner_rec_expression_dots expr_dots
@ mcode ender
233 | Ast0.Edots
(d
,whencode
) | Ast0.Ecircles
(d
,whencode
)
234 | Ast0.Estars
(d
,whencode
) -> mcode d
(* ignore whencode *)
235 | Ast0.OptExp e
| Ast0.UniqueExp e
->
236 (* put the + code on the thing, not on the opt *)
237 r
.VT0.combiner_rec_expression e
238 | _ -> do_nothing r k e
in
241 match Ast0.unwrap e
with
242 Ast0.OptIdent i
| Ast0.UniqueIdent i
->
243 (* put the + code on the thing, not on the opt *)
244 r
.VT0.combiner_rec_ident i
245 | _ -> do_nothing r k e
in
248 match Ast0.unwrap e
with
249 Ast0.OptType t
| Ast0.UniqueType t
->
250 (* put the + code on the thing, not on the opt *)
251 r
.VT0.combiner_rec_typeC t
252 | _ -> do_nothing r k e
in
255 match Ast0.unwrap e
with
256 Ast0.OptDecl d
| Ast0.UniqueDecl d
->
257 (* put the + code on the thing, not on the opt *)
258 r
.VT0.combiner_rec_declaration d
259 | _ -> do_nothing r k e
in
261 let initialiser r k e
=
262 match Ast0.unwrap e
with
263 Ast0.Idots
(d
,whencode
) -> mcode d
(* ignore whencode *)
264 | Ast0.OptIni i
| Ast0.UniqueIni i
->
265 (* put the + code on the thing, not on the opt *)
266 r
.VT0.combiner_rec_initialiser i
267 | _ -> do_nothing r k e
in
270 match Ast0.unwrap e
with
271 Ast0.OptParam p
| Ast0.UniqueParam p
->
272 (* put the + code on the thing, not on the opt *)
273 r
.VT0.combiner_rec_parameter p
274 | _ -> do_nothing r k e
in
276 let case_line r k e
=
277 match Ast0.unwrap e
with
279 (* put the + code on the thing, not on the opt *)
280 r
.VT0.combiner_rec_case_line c
281 | _ -> do_nothing r k e
in
283 let do_top r k
(e
: Ast0.top_level
) = k e
in
285 V0.flat_combiner
bind option_default
286 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
287 edots idots pdots sdots ddots cdots
288 ident expression typeC initialiser param decl statement case_line do_top
291 let call_collect_minus context_nodes
:
292 (int * (minus_join_point
* Ast0.info * Ast0.mcodekind
) list
) list
=
296 Ast0.DotsExprTag
(e
) ->
298 (collect_minus_join_points e
).VT0.combiner_rec_expression_dots e
)
299 | Ast0.DotsInitTag
(e
) ->
301 (collect_minus_join_points e
).VT0.combiner_rec_initialiser_list e
)
302 | Ast0.DotsParamTag
(e
) ->
304 (collect_minus_join_points e
).VT0.combiner_rec_parameter_list e
)
305 | Ast0.DotsStmtTag
(e
) ->
307 (collect_minus_join_points e
).VT0.combiner_rec_statement_dots e
)
308 | Ast0.DotsDeclTag
(e
) ->
310 (collect_minus_join_points e
).VT0.combiner_rec_declaration_dots e
)
311 | Ast0.DotsCaseTag
(e
) ->
313 (collect_minus_join_points e
).VT0.combiner_rec_case_line_dots e
)
314 | Ast0.IdentTag
(e
) ->
316 (collect_minus_join_points e
).VT0.combiner_rec_ident e
)
319 (collect_minus_join_points e
).VT0.combiner_rec_expression e
)
320 | Ast0.ArgExprTag
(e
) | Ast0.TestExprTag
(e
) ->
321 failwith
"not possible - iso only"
322 | Ast0.TypeCTag
(e
) ->
324 (collect_minus_join_points e
).VT0.combiner_rec_typeC e
)
325 | Ast0.ParamTag
(e
) ->
327 (collect_minus_join_points e
).VT0.combiner_rec_parameter e
)
330 (collect_minus_join_points e
).VT0.combiner_rec_initialiser e
)
333 (collect_minus_join_points e
).VT0.combiner_rec_declaration e
)
336 (collect_minus_join_points e
).VT0.combiner_rec_statement e
)
337 | Ast0.CaseLineTag
(e
) ->
339 (collect_minus_join_points e
).VT0.combiner_rec_case_line e
)
342 (collect_minus_join_points e
).VT0.combiner_rec_top_level e
)
343 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
344 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
345 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
346 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
349 (* result of collecting the join points should be sorted in nondecreasing
352 let get_info = function
353 (Favored
,info,_) | (Unfavored
,info,_) | (Toplevel
,info,_)
354 | (Decl
,info,_) -> info in
355 let token_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_start
in
356 let token_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.logical_end
in
357 let token_real_start_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_start
in
358 let token_real_end_line x
= (get_info x
).Ast0.pos_info
.Ast0.line_end
in
361 (index,((_::_) as l1
)) ->
364 (function (prev
,real_prev
) ->
366 let ln = token_start_line cur
in
371 "error in collection of - tokens: line %d less than line %d"
372 (token_real_start_line cur
) real_prev
);
373 (token_end_line cur
,token_real_end_line cur
))
374 (token_end_line (List.hd l1
), token_real_end_line (List.hd l1
))
377 | _ -> ()) (* dots, in eg f() has no join points *)
380 let process_minus minus
=
381 create_root_token_table minus
;
385 let res = call_collect_minus (collect_context x
) in
390 (* --------------------------------------------------------------------- *)
391 (* --------------------------------------------------------------------- *)
392 (* collect the plus tokens *)
394 let mk_structUnion x
= Ast.StructUnionTag x
395 let mk_sign x
= Ast.SignTag x
396 let mk_ident x
= Ast.IdentTag
(Ast0toast.ident x
)
397 let mk_expression x
= Ast.ExpressionTag
(Ast0toast.expression x
)
398 let mk_constant x
= Ast.ConstantTag x
399 let mk_unaryOp x
= Ast.UnaryOpTag x
400 let mk_assignOp x
= Ast.AssignOpTag x
401 let mk_fixOp x
= Ast.FixOpTag x
402 let mk_binaryOp x
= Ast.BinaryOpTag x
403 let mk_arithOp x
= Ast.ArithOpTag x
404 let mk_logicalOp x
= Ast.LogicalOpTag x
405 let mk_declaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
406 let mk_topdeclaration x
= Ast.DeclarationTag
(Ast0toast.declaration x
)
407 let mk_storage x
= Ast.StorageTag x
408 let mk_inc_file x
= Ast.IncFileTag x
409 let mk_statement x
= Ast.StatementTag
(Ast0toast.statement x
)
410 let mk_case_line x
= Ast.CaseLineTag
(Ast0toast.case_line x
)
411 let mk_const_vol x
= Ast.ConstVolTag x
412 let mk_token x
info = Ast.Token
(x
,Some
info)
413 let mk_meta (_,x
) info = Ast.Token
(x
,Some
info)
414 let mk_code x
= Ast.Code
(Ast0toast.top_level x
)
416 let mk_exprdots x
= Ast.ExprDotsTag
(Ast0toast.expression_dots x
)
417 let mk_paramdots x
= Ast.ParamDotsTag
(Ast0toast.parameter_list x
)
418 let mk_stmtdots x
= Ast.StmtDotsTag
(Ast0toast.statement_dots x
)
419 let mk_decldots x
= Ast.DeclDotsTag
(Ast0toast.declaration_dots x
)
420 let mk_casedots x
= failwith
"+ case lines not supported"
421 let mk_typeC x
= Ast.FullTypeTag
(Ast0toast.typeC x
)
422 let mk_init x
= Ast.InitTag
(Ast0toast.initialiser x
)
423 let mk_param x
= Ast.ParamTag
(Ast0toast.parameterTypeDef x
)
425 let collect_plus_nodes root
=
426 let root_index = Ast0.get_index root
in
428 let bind x y
= x
@ y
in
429 let option_default = [] in
431 let extract_strings info =
433 {info with Ast0.strings_before
= []; Ast0.strings_after
= []} in
434 let extract = function
437 let (_,first
) = List.hd strings_before
in
438 let (_,last
) = List.hd
(List.rev strings_before
) in
440 {Ast0.line_start
= first
.Ast0.line_start
;
441 Ast0.line_end
= last
.Ast0.line_start
;
442 Ast0.logical_start
= first
.Ast0.logical_start
;
443 Ast0.logical_end
= last
.Ast0.logical_start
;
444 Ast0.column
= first
.Ast0.column
;
445 Ast0.offset
= first
.Ast0.offset
} in
446 let new_info = {adjust_info with Ast0.pos_info
= new_pos_info} in
447 let string = List.map
(function (s
,_) -> s
) strings_before
in
448 [(new_info,Ast.ONE
(*?*),Ast.Pragma
(string))] in
449 let bef = extract info.Ast0.strings_before
in
450 let aft = extract info.Ast0.strings_after
in
453 let mcode fn
(term
,_,info,mcodekind
,_,_) =
455 Ast0.PLUS c
-> [(info,c
,fn term
)]
456 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
459 let imcode fn
(term
,_,info,mcodekind
,_,_) =
461 Ast0.PLUS c
-> [(info,c
,fn term
(Ast0toast.convert_info
info))]
462 | Ast0.CONTEXT
_ -> let (bef,aft) = extract_strings info in bef@aft
465 let info (i
,_) = let (bef,aft) = extract_strings i
in bef@aft in
467 let do_nothing fn r k e
=
468 match Ast0.get_mcodekind e
with
469 (Ast0.CONTEXT
(_)) when not
(Ast0.get_index e
= root_index) -> []
470 | Ast0.PLUS c
-> [(Ast0.get_info e
,c
,fn e
)]
473 (* case for everything that is just a wrapper for a simpler thing *)
474 (* case for things with bef aft *)
476 match Ast0.unwrap e
with
477 Ast0.Exp
(exp
) -> r
.VT0.combiner_rec_expression exp
478 | Ast0.TopExp
(exp
) -> r
.VT0.combiner_rec_expression exp
479 | Ast0.Ty
(ty
) -> r
.VT0.combiner_rec_typeC ty
480 | Ast0.TopInit
(init
) -> r
.VT0.combiner_rec_initialiser init
481 | Ast0.Decl
(bef,decl) ->
482 (info bef) @ (do_nothing mk_statement r k e
)
483 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
484 (info bef) @ (do_nothing mk_statement r k e
)
485 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
486 (do_nothing mk_statement r k e
) @ (info aft)
487 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
488 (do_nothing mk_statement r k e
) @ (info aft)
489 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
490 (do_nothing mk_statement r k e
) @ (info aft)
491 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
492 (do_nothing mk_statement r k e
) @ (info aft)
493 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
494 (do_nothing mk_statement r k e
) @ (info aft)
495 | _ -> do_nothing mk_statement r k e
in
497 (* statementTag is preferred, because it indicates that one statement is
498 replaced by one statement, in single_statement *)
499 let stmt_dots r k e
=
500 match Ast0.unwrap e
with
501 Ast0.DOTS
([s
]) | Ast0.CIRCLES
([s
]) | Ast0.STARS
([s
]) ->
502 r
.VT0.combiner_rec_statement s
503 | _ -> do_nothing mk_stmtdots r k e
in
506 match Ast0.unwrap e
with
507 Ast0.DECL
(s
) -> r
.VT0.combiner_rec_statement s
508 | Ast0.CODE
(sdots) -> r
.VT0.combiner_rec_statement_dots
sdots
509 | _ -> do_nothing mk_code r k e
in
511 let initdots r k e
= k e
in
513 V0.flat_combiner
bind option_default
514 (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp)
516 (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol)
517 (mcode mk_sign) (mcode mk_structUnion)
518 (mcode mk_storage) (mcode mk_inc_file)
519 (do_nothing mk_exprdots) initdots
520 (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots)
521 (do_nothing mk_casedots)
522 (do_nothing mk_ident) (do_nothing mk_expression)
523 (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param)
524 (do_nothing mk_declaration)
525 stmt (do_nothing mk_case_line) toplevel
527 let call_collect_plus context_nodes
:
528 (int * (Ast0.info * Ast.count
* Ast.anything
) list
) list
=
532 Ast0.DotsExprTag
(e
) ->
534 (collect_plus_nodes e
).VT0.combiner_rec_expression_dots e
)
535 | Ast0.DotsInitTag
(e
) ->
537 (collect_plus_nodes e
).VT0.combiner_rec_initialiser_list e
)
538 | Ast0.DotsParamTag
(e
) ->
540 (collect_plus_nodes e
).VT0.combiner_rec_parameter_list e
)
541 | Ast0.DotsStmtTag
(e
) ->
543 (collect_plus_nodes e
).VT0.combiner_rec_statement_dots e
)
544 | Ast0.DotsDeclTag
(e
) ->
546 (collect_plus_nodes e
).VT0.combiner_rec_declaration_dots e
)
547 | Ast0.DotsCaseTag
(e
) ->
549 (collect_plus_nodes e
).VT0.combiner_rec_case_line_dots e
)
550 | Ast0.IdentTag
(e
) ->
552 (collect_plus_nodes e
).VT0.combiner_rec_ident e
)
555 (collect_plus_nodes e
).VT0.combiner_rec_expression e
)
556 | Ast0.ArgExprTag
(_) | Ast0.TestExprTag
(_) ->
557 failwith
"not possible - iso only"
558 | Ast0.TypeCTag
(e
) ->
560 (collect_plus_nodes e
).VT0.combiner_rec_typeC e
)
563 (collect_plus_nodes e
).VT0.combiner_rec_initialiser e
)
564 | Ast0.ParamTag
(e
) ->
566 (collect_plus_nodes e
).VT0.combiner_rec_parameter e
)
569 (collect_plus_nodes e
).VT0.combiner_rec_declaration e
)
572 (collect_plus_nodes e
).VT0.combiner_rec_statement e
)
573 | Ast0.CaseLineTag
(e
) ->
575 (collect_plus_nodes e
).VT0.combiner_rec_case_line e
)
578 (collect_plus_nodes e
).VT0.combiner_rec_top_level e
)
579 | Ast0.IsoWhenTag
(_) -> failwith
"only within iso phase"
580 | Ast0.IsoWhenTTag
(_) -> failwith
"only within iso phase"
581 | Ast0.IsoWhenFTag
(_) -> failwith
"only within iso phase"
582 | Ast0.MetaPosTag
(p
) -> failwith
"metapostag only within iso phase")
585 (* The plus fragments are converted to a list of lists of lists.
586 Innermost list: Elements have type anything. For any pair of successive
587 elements, n and n+1, the ending line of n is the same as the starting line
589 Middle lists: For any pair of successive elements, n and n+1, the ending
590 line of n is one less than the starting line of n+1.
591 Outer list: For any pair of successive elements, n and n+1, the ending
592 line of n is more than one less than the starting line of n+1. *)
594 let logstart info = info.Ast0.pos_info
.Ast0.logical_start
595 let logend info = info.Ast0.pos_info
.Ast0.logical_end
597 let redo info start finish
=
599 {info.Ast0.pos_info
with
600 Ast0.logical_start
= start
;
601 Ast0.logical_end
= finish
} in
602 {info with Ast0.pos_info
= new_pos_info}
604 let rec find_neighbors (index,l
) :
605 int * (Ast0.info * Ast.count
* (Ast.anything list list
)) list
=
606 let rec loop = function
609 (match loop rest
with
610 ((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
->
611 let finish1 = logend i
in
612 let start2 = logstart i1
in
615 ((if not
(c
= c1
) then failwith
"inconsistent + code");
616 ((redo i
(logstart i
) (logend i1
),c
,(x
::x1
::rest_inner
))
619 else if finish1 + 1 = start2
620 then ((i
,c
,[x
])::(i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
622 [(i
,c
,[x
])]::((i1
,c1
,(x1
::rest_inner
))::rest_middle
)::rest_outer
623 | _ -> [[(i
,c
,[x
])]]) (* rest must be [] *) in
627 let (start_info
,start_count
,_) = List.hd l
in
628 let (end_info
,end_count
,_) = List.hd
(List.rev l
) in
629 (if not
(start_count
= end_count
) then failwith
"inconsistent + code");
630 (redo start_info
(logstart start_info
) (logend end_info
),
632 List.map
(function (_,_,x
) -> x
) l
))
636 let process_plus plus
:
637 (int * (Ast0.info * Ast.count
* Ast.anything list list
) list
) list
=
641 List.map
find_neighbors (call_collect_plus (collect_context x
)))
644 (* --------------------------------------------------------------------- *)
645 (* --------------------------------------------------------------------- *)
648 let merge_one = function
649 (m1::m2::minus_info,p::plus_info) ->
651 attach p to the beginning of m1.bef if m1 is Good, fail if it is bad
652 if p > m1 && p < m2, then consider the following possibilities, in order
653 m1 is Good and favored: attach to the beginning of m1.aft
654 m2 is Good and favored: attach to the beginning of m2.bef; drop m1
655 m1 is Good and unfavored: attach to the beginning of m1.aft
656 m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1
657 also flip m1.bef if the first where > m1
658 if we drop m1, then flip m1.aft first
660 m2 is Good and favored: attach to the beginning of m2.aft; drop m1
663 (* end of first argument < start/end of second argument *)
664 let less_than_start info1 info2
=
665 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_start
666 let less_than_end info1 info2
=
667 info1
.Ast0.pos_info
.Ast0.logical_end
< info2
.Ast0.pos_info
.Ast0.logical_end
668 let greater_than_end info1 info2
=
669 info1
.Ast0.pos_info
.Ast0.logical_start
> info2
.Ast0.pos_info
.Ast0.logical_end
670 let good_start info = info.Ast0.attachable_start
671 let good_end info = info.Ast0.attachable_end
673 let toplevel = function Toplevel
-> true | Favored
| Unfavored
| Decl
-> false
674 let decl = function Decl
-> true | Favored
| Unfavored
| Toplevel
-> false
675 let favored = function Favored
-> true | Unfavored
| Toplevel
| Decl
-> false
678 List.for_all
(List.for_all
(function Ast.Code
_ -> true | _ -> false))
680 (* The following is probably not correct. The idea is to detect what
681 should be placed completely before the declaration. So type/storage
682 related things do not fall into this category, and complete statements do
683 fall into this category. But perhaps other things should be in this
684 category as well, such as { or ;? *)
686 let tester = function
687 (* the following should definitely be true *)
693 | Ast.Pragma
_ -> true
694 (* the following should definitely be false *)
695 | Ast.FullTypeTag
_ | Ast.BaseTypeTag
_ | Ast.StructUnionTag
_
697 | Ast.StorageTag
_ | Ast.ConstVolTag
_ | Ast.TypeCTag
_ -> false
698 (* not sure about the rest *)
700 List.for_all
(List.for_all
tester)
702 let pr = Printf.sprintf
704 let insert thing thinginfo into intoinfo
=
705 let get_last l
= let l = List.rev
l in (List.rev
(List.tl
l),List.hd
l) in
706 let get_first l = (List.hd
l,List.tl
l) in
707 let thing_start = thinginfo
.Ast0.pos_info
.Ast0.logical_start
in
708 let thing_end = thinginfo
.Ast0.pos_info
.Ast0.logical_end
in
709 let thing_offset = thinginfo
.Ast0.pos_info
.Ast0.offset
in
710 let into_start = intoinfo
.Ast0.tline_start
in
711 let into_end = intoinfo
.Ast0.tline_end
in
712 let into_left_offset = intoinfo
.Ast0.left_offset
in
713 let into_right_offset = intoinfo
.Ast0.right_offset
in
714 if thing_end < into_start && thing_start < into_start
716 {{intoinfo
with Ast0.tline_start
= thing_start}
717 with Ast0.left_offset
= thing_offset})
718 else if thing_end = into_start && thing_offset < into_left_offset
720 let (prev
,last
) = get_last thing
in
721 let (first
,rest
) = get_first into
in
722 (prev
@[last
@first
]@rest
,
723 {{intoinfo
with Ast0.tline_start
= thing_start}
724 with Ast0.left_offset
= thing_offset})
725 else if thing_start > into_end && thing_end > into_end
727 {{intoinfo
with Ast0.tline_end
= thing_end}
728 with Ast0.right_offset
= thing_offset})
729 else if thing_start = into_end && thing_offset > into_right_offset
731 let (first
,rest
) = get_first thing
in
732 let (prev
,last
) = get_last into
in
733 (prev
@[last
@first
]@rest
,
734 {{intoinfo
with Ast0.tline_end
= thing_end}
735 with Ast0.right_offset
= thing_offset})
738 Printf.printf
"thing start %d thing end %d into start %d into end %d\n"
739 thing_start thing_end into_start into_end;
740 Printf.printf
"thing offset %d left offset %d right offset %d\n"
741 thing_offset into_left_offset into_right_offset;
742 Pretty_print_cocci.print_anything
"" thing
;
743 Pretty_print_cocci.print_anything
"" into
;
744 failwith
"can't figure out where to put the + code"
747 let init thing
info =
749 {Ast0.tline_start
= info.Ast0.pos_info
.Ast0.logical_start
;
750 Ast0.tline_end
= info.Ast0.pos_info
.Ast0.logical_end
;
751 Ast0.left_offset
= info.Ast0.pos_info
.Ast0.offset
;
752 Ast0.right_offset
= info.Ast0.pos_info
.Ast0.offset
})
754 let attachbefore (infop
,c
,p
) = function
755 Ast0.MINUS
(replacements
) ->
756 let (repl
,ti
) = !replacements
in
760 | repl
-> insert p infop repl ti
in
761 replacements
:= (bef,ti
)
762 | Ast0.CONTEXT
(neighbors
) ->
763 let (repl
,ti1
,ti2
) = !neighbors
in
765 Ast.BEFORE
(bef,it
) ->
766 let (bef,ti1
) = insert p infop
bef ti1
in
767 let it = Ast.lub_count
it c
in
768 neighbors
:= (Ast.BEFORE
(bef,it),ti1
,ti2
)
769 | Ast.AFTER
(aft,it) ->
770 let (bef,ti1
) = init p infop
in
771 let it = Ast.lub_count
it c
in
772 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
773 | Ast.BEFOREAFTER
(bef,aft,it) ->
774 let (bef,ti1
) = insert p infop
bef ti1
in
775 let it = Ast.lub_count
it c
in
776 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
778 let (bef,ti1
) = init p infop
in
779 neighbors
:= (Ast.BEFORE
(bef,c
),ti1
,ti2
))
780 | _ -> failwith
"not possible for attachbefore"
782 let attachafter (infop
,c
,p
) = function
783 Ast0.MINUS
(replacements
) ->
784 let (repl
,ti
) = !replacements
in
788 | repl
-> insert p infop repl ti
in
789 replacements
:= (aft,ti
)
790 | Ast0.CONTEXT
(neighbors
) ->
791 let (repl
,ti1
,ti2
) = !neighbors
in
793 Ast.BEFORE
(bef,it) ->
794 let (aft,ti2
) = init p infop
in
795 let it = Ast.lub_count
it c
in
796 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
797 | Ast.AFTER
(aft,it) ->
798 let (aft,ti2
) = insert p infop
aft ti2
in
799 let it = Ast.lub_count
it c
in
800 neighbors
:= (Ast.AFTER
(aft,it),ti1
,ti2
)
801 | Ast.BEFOREAFTER
(bef,aft,it) ->
802 let (aft,ti2
) = insert p infop
aft ti2
in
803 let it = Ast.lub_count
it c
in
804 neighbors
:= (Ast.BEFOREAFTER
(bef,aft,it),ti1
,ti2
)
806 let (aft,ti2
) = init p infop
in
807 neighbors
:= (Ast.AFTER
(aft,c
),ti1
,ti2
))
808 | _ -> failwith
"not possible for attachbefore"
810 let attach_all_before ps m
=
811 List.iter
(function x
-> attachbefore x m
) ps
813 let attach_all_after ps m
=
814 List.iter
(function x
-> attachafter x m
) ps
816 let split_at_end info ps
=
817 let split_point = info.Ast0.pos_info
.Ast0.logical_end
in
819 (function (info,_,_) -> info.Ast0.pos_info
.Ast0.logical_end
< split_point)
822 let allminus = function
823 Ast0.MINUS
(_) -> true
826 let rec before_m1 ((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
828 | (((infop
,_,_) as p
) :: ps
) as all
->
829 if less_than_start infop infom1
or
830 (allminus m1
&& less_than_end infop infom1
) (* account for trees *)
833 then (attachbefore p m1
; before_m1 x1 x2 rest ps
)
836 (pr "%d: no available token to attach to"
837 infop
.Ast0.pos_info
.Ast0.line_start
)
838 else after_m1 x1 x2 rest all
840 and after_m1
((f1
,infom1
,m1
) as x1
) ((f2
,infom2
,m2
) as x2
) rest
= function
842 | (((infop
,count
,pcode
) as p
) :: ps
) as all
->
843 (* if the following is false, then some + code is stuck in the middle
844 of some context code (m1). could drop down to the token level.
845 this might require adjustments in ast0toast as well, when + code on
846 expressions is dropped down to + code on expressions. it might
847 also break some invariants on which iso depends, particularly on
848 what it can infer from something being CONTEXT with no top-level
849 modifications. for the moment, we thus give an error, asking the
850 user to rewrite the semantic patch. *)
851 if greater_than_end infop infom1
or is_minus m1
or !empty_isos
853 if less_than_start infop infom2
855 if predecl_code pcode
&& good_end infom1
&& decl f1
856 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
857 else if predecl_code pcode
&& good_start infom2
&& decl f2
858 then before_m2 x2 rest all
859 else if top_code pcode
&& good_end infom1
&& toplevel f1
860 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
861 else if top_code pcode
&& good_start infom2
&& toplevel f2
862 then before_m2 x2 rest all
863 else if good_end infom1
&& favored f1
864 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
865 else if good_start infom2
&& favored f2
866 then before_m2 x2 rest all
867 else if good_end infom1
868 then (attachafter p m1
; after_m1 x1 x2 rest ps
)
869 else if good_start infom2
870 then before_m2 x2 rest all
873 (pr "%d: no available token to attach to"
874 infop
.Ast0.pos_info
.Ast0.line_start
)
875 else after_m2 x2 rest all
878 Printf.printf
"between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n"
879 infop
.Ast0.pos_info
.Ast0.line_start
880 infop
.Ast0.pos_info
.Ast0.line_end
881 infom1
.Ast0.pos_info
.Ast0.line_start
882 infom1
.Ast0.pos_info
.Ast0.line_end
883 infom2
.Ast0.pos_info
.Ast0.line_start
884 infom2
.Ast0.pos_info
.Ast0.line_end
;
885 Pretty_print_cocci.print_anything
"" pcode
;
887 "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."
890 (* not sure this is safe. if have iso problems, consider changing this
891 to always return false *)
892 and is_minus
= function
896 and before_m2
((f2
,infom2
,m2
) as x2
) rest
897 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
900 | ([],((infop
,_,_)::_)) ->
901 let (bef_m2
,aft_m2
) = split_at_end infom2 p
in (* bef_m2 isn't empty *)
903 then (attach_all_before bef_m2 m2
; after_m2 x2 rest aft_m2
)
906 (pr "%d: no available token to attach to"
907 infop
.Ast0.pos_info
.Ast0.line_start
)
908 | (m
::ms
,_) -> before_m1 x2 m ms p
910 and after_m2
((f2
,infom2
,m2
) as x2
) rest
911 (p
: (Ast0.info * Ast.count
* Ast.anything list list
) list
) =
914 | ([],((infop
,_,_)::_)) ->
916 then attach_all_after p m2
919 (pr "%d: no available token to attach to"
920 infop
.Ast0.pos_info
.Ast0.line_start
)
921 | (m
::ms
,_) -> after_m1 x2 m ms p
923 let merge_one : (minus_join_point
* Ast0.info * 'a
) list
*
924 (Ast0.info * Ast.count
* Ast.anything list list
) list
-> unit =
927 Printf.printf "minus code\n";
929 (function (_,info,_) ->
930 Printf.printf "start %d end %d real_start %d real_end %d\n"
931 info.Ast0.pos_info.Ast0.logical_start
932 info.Ast0.pos_info.Ast0.logical_end
933 info.Ast0.pos_info.Ast0.line_start
934 info.Ast0.pos_info.Ast0.line_end)
936 Printf.printf "plus code\n";
938 (function (info,p) ->
939 Printf.printf "start %d end %d real_start %d real_end %d\n"
940 info.Ast0.pos_info.Ast0.logical_start
941 info.Ast0.pos_info.Ast0.logical_end
942 info.Ast0.pos_info.Ast0.line_end
943 info.Ast0.pos_info.Ast0.line_end;
944 Pretty_print_cocci.print_anything "" p;
945 Format.print_newline())
950 | (m1
::m2
::restm
,p
) -> before_m1 m1 m2 restm p
951 | ([m
],p
) -> before_m2 m
[] p
952 | ([],_) -> failwith
"minus tree ran out before the plus tree"
954 let merge minus_list plus_list
=
956 Printf.printf "minus list %s\n"
958 (List.map (function (x,_) -> string_of_int x) minus_list));
959 Printf.printf "plus list %s\n"
961 (List.map (function (x,_) -> string_of_int x) plus_list));
964 (function (index,minus_info
) ->
965 let plus_info = List.assoc
index plus_list
in
966 merge_one (minus_info
,plus_info))
969 (* --------------------------------------------------------------------- *)
970 (* --------------------------------------------------------------------- *)
971 (* Need to check that CONTEXT nodes have nothing attached to their tokens.
972 If they do, they become MIXED *)
974 let reevaluate_contextness =
976 let option_default = [] in
978 let mcode (_,_,_,mc
,_,_) =
980 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
985 Ast0.CONTEXT
(mc
) -> let (ba
,_,_) = !mc
in [ba
]
988 let donothing r k e
=
989 match Ast0.get_mcodekind e
with
991 if List.exists
(function Ast.NOTHING
-> false | _ -> true) (k e
)
992 then Ast0.set_mcodekind e
(Ast0.MIXED
(mc
));
994 | _ -> let _ = k e
in [] in
996 (* a case for everything with bef or aft *)
998 match Ast0.unwrap e
with
999 Ast0.Decl
(bef,decl) ->
1000 (info bef) @ (donothing r k e
)
1001 | Ast0.FunDecl
(bef,fi
,name
,lp
,params
,rp
,lbrace
,body
,rbrace
) ->
1002 (info bef) @ (donothing r k e
)
1003 | Ast0.IfThen
(iff
,lp
,exp
,rp
,branch1
,aft) ->
1004 (donothing r k e
) @ (info aft)
1005 | Ast0.IfThenElse
(iff
,lp
,exp
,rp
,branch1
,els
,branch2
,aft) ->
1006 (donothing r k e
) @ (info aft)
1007 | Ast0.While
(whl
,lp
,exp
,rp
,body
,aft) ->
1008 (donothing r k e
) @ (info aft)
1009 | Ast0.For
(fr
,lp
,e1
,sem1
,e2
,sem2
,e3
,rp
,body
,aft) ->
1010 (donothing r k e
) @ (info aft)
1011 | Ast0.Iterator
(nm
,lp
,args
,rp
,body
,aft) ->
1012 (donothing r k e
) @ (info aft)
1013 | _ -> donothing r k e
in
1016 V0.flat_combiner
bind option_default
1017 mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
1018 donothing donothing donothing donothing donothing donothing donothing
1020 donothing donothing donothing donothing stmt donothing donothing in
1021 res.VT0.combiner_rec_top_level
1023 (* --------------------------------------------------------------------- *)
1024 (* --------------------------------------------------------------------- *)
1026 let insert_plus minus plus ei
=
1028 let minus_stream = process_minus minus
in
1029 let plus_stream = process_plus plus
in
1030 merge minus_stream plus_stream;
1031 List.iter
(function x
-> let _ = reevaluate_contextness x
in ()) minus