| 1 | (* |
| 2 | * Copyright 2005-2009, Ecole des Mines de Nantes, University of Copenhagen |
| 3 | * Yoann Padioleau, Julia Lawall, Rene Rydhof Hansen, Henrik Stuart, Gilles Muller |
| 4 | * This file is part of Coccinelle. |
| 5 | * |
| 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. |
| 9 | * |
| 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. |
| 14 | * |
| 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/>. |
| 17 | * |
| 18 | * The authors reserve the right to distribute this or future versions of |
| 19 | * Coccinelle under other licenses. |
| 20 | *) |
| 21 | |
| 22 | |
| 23 | (* The error message "no available token to attach to" often comes in an |
| 24 | argument list of unbounded length. In this case, one should move a comma so |
| 25 | that there is a comma after the + code. *) |
| 26 | |
| 27 | (* Start at all of the corresponding BindContext nodes in the minus and |
| 28 | plus trees, and traverse their children. We take the same strategy as |
| 29 | before: collect the list of minus/context nodes/tokens and the list of plus |
| 30 | tokens, and then merge them. *) |
| 31 | |
| 32 | module Ast = Ast_cocci |
| 33 | module Ast0 = Ast0_cocci |
| 34 | module V0 = Visitor_ast0 |
| 35 | module CN = Context_neg |
| 36 | |
| 37 | let empty_isos = ref false |
| 38 | |
| 39 | let get_option f = function |
| 40 | None -> [] |
| 41 | | Some x -> f x |
| 42 | |
| 43 | (* --------------------------------------------------------------------- *) |
| 44 | (* Collect root and all context nodes in a tree *) |
| 45 | |
| 46 | let collect_context e = |
| 47 | let bind x y = x @ y in |
| 48 | let option_default = [] in |
| 49 | |
| 50 | let mcode _ = [] in |
| 51 | |
| 52 | let donothing builder r k e = |
| 53 | match Ast0.get_mcodekind e with |
| 54 | Ast0.CONTEXT(_) -> (builder e) :: (k e) |
| 55 | | _ -> k e in |
| 56 | |
| 57 | (* special case for everything that contains whencode, so that we skip over |
| 58 | it *) |
| 59 | let expression r k e = |
| 60 | donothing Ast0.expr r k |
| 61 | (Ast0.rewrap e |
| 62 | (match Ast0.unwrap e with |
| 63 | Ast0.NestExpr(starter,exp,ender,whencode,multi) -> |
| 64 | Ast0.NestExpr(starter,exp,ender,None,multi) |
| 65 | | Ast0.Edots(dots,whencode) -> Ast0.Edots(dots,None) |
| 66 | | Ast0.Ecircles(dots,whencode) -> Ast0.Ecircles(dots,None) |
| 67 | | Ast0.Estars(dots,whencode) -> Ast0.Estars(dots,None) |
| 68 | | e -> e)) in |
| 69 | |
| 70 | let initialiser r k i = |
| 71 | donothing Ast0.ini r k |
| 72 | (Ast0.rewrap i |
| 73 | (match Ast0.unwrap i with |
| 74 | Ast0.Idots(dots,whencode) -> Ast0.Idots(dots,None) |
| 75 | | i -> i)) in |
| 76 | |
| 77 | let statement r k s = |
| 78 | donothing Ast0.stmt r k |
| 79 | (Ast0.rewrap s |
| 80 | (match Ast0.unwrap s with |
| 81 | Ast0.Nest(started,stm_dots,ender,whencode,multi) -> |
| 82 | Ast0.Nest(started,stm_dots,ender,[],multi) |
| 83 | | Ast0.Dots(dots,whencode) -> Ast0.Dots(dots,[]) |
| 84 | | Ast0.Circles(dots,whencode) -> Ast0.Circles(dots,[]) |
| 85 | | Ast0.Stars(dots,whencode) -> Ast0.Stars(dots,[]) |
| 86 | | s -> s)) in |
| 87 | |
| 88 | let topfn r k e = Ast0.TopTag(e) :: (k e) in |
| 89 | |
| 90 | let res = |
| 91 | V0.combiner bind option_default |
| 92 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode |
| 93 | (donothing Ast0.dotsExpr) (donothing Ast0.dotsInit) |
| 94 | (donothing Ast0.dotsParam) (donothing Ast0.dotsStmt) |
| 95 | (donothing Ast0.dotsDecl) (donothing Ast0.dotsCase) |
| 96 | (donothing Ast0.ident) expression (donothing Ast0.typeC) initialiser |
| 97 | (donothing Ast0.param) (donothing Ast0.decl) statement |
| 98 | (donothing Ast0.case_line) topfn in |
| 99 | res.V0.combiner_top_level e |
| 100 | |
| 101 | (* --------------------------------------------------------------------- *) |
| 102 | (* --------------------------------------------------------------------- *) |
| 103 | (* collect the possible join points, in order, among the children of a |
| 104 | BindContext. Dots are not allowed. Nests and disjunctions are no problem, |
| 105 | because their delimiters take up a line by themselves *) |
| 106 | |
| 107 | (* An Unfavored token is one that is in a BindContext node; using this causes |
| 108 | the node to become Neither, meaning that isomorphisms can't be applied *) |
| 109 | (* Toplevel is for the bef token of a function declaration and is for |
| 110 | attaching top-level definitions that should come before the complete |
| 111 | declaration *) |
| 112 | type minus_join_point = Favored | Unfavored | Toplevel | Decl |
| 113 | |
| 114 | (* Maps the index of a node to the indices of the mcodes it contains *) |
| 115 | let root_token_table = (Hashtbl.create(50) : (int, int list) Hashtbl.t) |
| 116 | |
| 117 | let create_root_token_table minus = |
| 118 | Hashtbl.iter |
| 119 | (function tokens -> |
| 120 | function (node,_) -> |
| 121 | let key = |
| 122 | match node with |
| 123 | Ast0.DotsExprTag(d) -> Ast0.get_index d |
| 124 | | Ast0.DotsInitTag(d) -> Ast0.get_index d |
| 125 | | Ast0.DotsParamTag(d) -> Ast0.get_index d |
| 126 | | Ast0.DotsStmtTag(d) -> Ast0.get_index d |
| 127 | | Ast0.DotsDeclTag(d) -> Ast0.get_index d |
| 128 | | Ast0.DotsCaseTag(d) -> Ast0.get_index d |
| 129 | | Ast0.IdentTag(d) -> Ast0.get_index d |
| 130 | | Ast0.ExprTag(d) -> Ast0.get_index d |
| 131 | | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) -> |
| 132 | failwith "not possible - iso only" |
| 133 | | Ast0.TypeCTag(d) -> Ast0.get_index d |
| 134 | | Ast0.ParamTag(d) -> Ast0.get_index d |
| 135 | | Ast0.InitTag(d) -> Ast0.get_index d |
| 136 | | Ast0.DeclTag(d) -> Ast0.get_index d |
| 137 | | Ast0.StmtTag(d) -> Ast0.get_index d |
| 138 | | Ast0.CaseLineTag(d) -> Ast0.get_index d |
| 139 | | Ast0.TopTag(d) -> Ast0.get_index d |
| 140 | | Ast0.IsoWhenTag(_) -> failwith "only within iso phase" |
| 141 | | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase" |
| 142 | | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase" |
| 143 | | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase" |
| 144 | in |
| 145 | Hashtbl.add root_token_table key tokens) |
| 146 | CN.minus_table; |
| 147 | List.iter |
| 148 | (function r -> |
| 149 | let index = Ast0.get_index r in |
| 150 | try let _ = Hashtbl.find root_token_table index in () |
| 151 | with Not_found -> Hashtbl.add root_token_table index []) |
| 152 | minus |
| 153 | |
| 154 | let collect_minus_join_points root = |
| 155 | let root_index = Ast0.get_index root in |
| 156 | let unfavored_tokens = Hashtbl.find root_token_table root_index in |
| 157 | let bind x y = x @ y in |
| 158 | let option_default = [] in |
| 159 | |
| 160 | let mcode (_,_,info,mcodekind,_) = |
| 161 | if List.mem (info.Ast0.offset) unfavored_tokens |
| 162 | then [(Unfavored,info,mcodekind)] |
| 163 | else [(Favored,info,mcodekind)] in |
| 164 | |
| 165 | let do_nothing r k e = |
| 166 | let info = Ast0.get_info e in |
| 167 | let index = Ast0.get_index e in |
| 168 | match Ast0.get_mcodekind e with |
| 169 | (Ast0.MINUS(_)) as mc -> [(Favored,info,mc)] |
| 170 | | (Ast0.CONTEXT(_)) as mc when not(index = root_index) -> |
| 171 | (* This was unfavored at one point, but I don't remember why *) |
| 172 | [(Favored,info,mc)] |
| 173 | | _ -> k e in |
| 174 | |
| 175 | (* don't want to attach to the outside of DOTS, because metavariables can't |
| 176 | bind to that; not good for isomorphisms *) |
| 177 | |
| 178 | let dots f k d = |
| 179 | let multibind l = |
| 180 | let rec loop = function |
| 181 | [] -> option_default |
| 182 | | [x] -> x |
| 183 | | x::xs -> bind x (loop xs) in |
| 184 | loop l in |
| 185 | |
| 186 | match Ast0.unwrap d with |
| 187 | Ast0.DOTS(l) -> multibind (List.map f l) |
| 188 | | Ast0.CIRCLES(l) -> multibind (List.map f l) |
| 189 | | Ast0.STARS(l) -> multibind (List.map f l) in |
| 190 | |
| 191 | let edots r k d = dots r.V0.combiner_expression k d in |
| 192 | let idots r k d = dots r.V0.combiner_initialiser k d in |
| 193 | let pdots r k d = dots r.V0.combiner_parameter k d in |
| 194 | let sdots r k d = dots r.V0.combiner_statement k d in |
| 195 | let ddots r k d = dots r.V0.combiner_declaration k d in |
| 196 | let cdots r k d = dots r.V0.combiner_case_line k d in |
| 197 | |
| 198 | (* a case for everything that has a Opt *) |
| 199 | |
| 200 | let statement r k s = |
| 201 | (* |
| 202 | let redo_branched res (ifinfo,aftmc) = |
| 203 | let redo fv info mc rest = |
| 204 | let new_info = {info with Ast0.attachable_end = false} in |
| 205 | List.rev ((Favored,ifinfo,aftmc)::(fv,new_info,mc)::rest) in |
| 206 | match List.rev res with |
| 207 | [(fv,info,mc)] -> |
| 208 | (match mc with |
| 209 | Ast0.MINUS(_) | Ast0.CONTEXT(_) -> |
| 210 | (* even for -, better for isos not to integrate code after an |
| 211 | if into the if body. |
| 212 | but the problem is that this can extend the region in |
| 213 | which a variable is bound, because a variable bound in the |
| 214 | aft node would seem to have to be live in the whole if, |
| 215 | whereas we might like it to be live in only one branch. |
| 216 | ie ideally, if we can keep the minus code in the right |
| 217 | order, we would like to drop it as close to the bindings |
| 218 | of its free variables. This could be anywhere in the minus |
| 219 | code. Perhaps we would like to do this after the |
| 220 | application of isomorphisms, though. |
| 221 | *) |
| 222 | redo fv info mc [] |
| 223 | | _ -> res) |
| 224 | | (fv,info,mc)::rest -> |
| 225 | (match mc with |
| 226 | Ast0.CONTEXT(_) -> redo fv info mc rest |
| 227 | | _ -> res) |
| 228 | | _ -> failwith "unexpected empty code" in *) |
| 229 | match Ast0.unwrap s with |
| 230 | (* Ast0.IfThen(_,_,_,_,_,aft) |
| 231 | | Ast0.IfThenElse(_,_,_,_,_,_,_,aft) |
| 232 | | Ast0.While(_,_,_,_,_,aft) |
| 233 | | Ast0.For(_,_,_,_,_,_,_,_,_,aft) |
| 234 | | Ast0.Iterator(_,_,_,_,_,aft) -> |
| 235 | redo_branched (do_nothing r k s) aft*) |
| 236 | | Ast0.FunDecl((info,bef),fninfo,name,lp,params,rp,lbrace,body,rbrace) -> |
| 237 | (Toplevel,info,bef)::(k s) |
| 238 | | Ast0.Decl((info,bef),decl) -> (Decl,info,bef)::(k s) |
| 239 | | Ast0.Nest(starter,stmt_dots,ender,whencode,multi) -> |
| 240 | mcode starter @ r.V0.combiner_statement_dots stmt_dots @ mcode ender |
| 241 | | Ast0.Dots(d,whencode) | Ast0.Circles(d,whencode) |
| 242 | | Ast0.Stars(d,whencode) -> mcode d (* ignore whencode *) |
| 243 | | Ast0.OptStm s | Ast0.UniqueStm s -> |
| 244 | (* put the + code on the thing, not on the opt *) |
| 245 | r.V0.combiner_statement s |
| 246 | | _ -> do_nothing r k s in |
| 247 | |
| 248 | let expression r k e = |
| 249 | match Ast0.unwrap e with |
| 250 | Ast0.NestExpr(starter,expr_dots,ender,whencode,multi) -> |
| 251 | mcode starter @ |
| 252 | r.V0.combiner_expression_dots expr_dots @ mcode ender |
| 253 | | Ast0.Edots(d,whencode) | Ast0.Ecircles(d,whencode) |
| 254 | | Ast0.Estars(d,whencode) -> mcode d (* ignore whencode *) |
| 255 | | Ast0.OptExp e | Ast0.UniqueExp e -> |
| 256 | (* put the + code on the thing, not on the opt *) |
| 257 | r.V0.combiner_expression e |
| 258 | | _ -> do_nothing r k e in |
| 259 | |
| 260 | let ident r k e = |
| 261 | match Ast0.unwrap e with |
| 262 | Ast0.OptIdent i | Ast0.UniqueIdent i -> |
| 263 | (* put the + code on the thing, not on the opt *) |
| 264 | r.V0.combiner_ident i |
| 265 | | _ -> do_nothing r k e in |
| 266 | |
| 267 | let typeC r k e = |
| 268 | match Ast0.unwrap e with |
| 269 | Ast0.OptType t | Ast0.UniqueType t -> |
| 270 | (* put the + code on the thing, not on the opt *) |
| 271 | r.V0.combiner_typeC t |
| 272 | | _ -> do_nothing r k e in |
| 273 | |
| 274 | let decl r k e = |
| 275 | match Ast0.unwrap e with |
| 276 | Ast0.OptDecl d | Ast0.UniqueDecl d -> |
| 277 | (* put the + code on the thing, not on the opt *) |
| 278 | r.V0.combiner_declaration d |
| 279 | | _ -> do_nothing r k e in |
| 280 | |
| 281 | let initialiser r k e = |
| 282 | match Ast0.unwrap e with |
| 283 | Ast0.Idots(d,whencode) -> mcode d (* ignore whencode *) |
| 284 | | Ast0.OptIni i | Ast0.UniqueIni i -> |
| 285 | (* put the + code on the thing, not on the opt *) |
| 286 | r.V0.combiner_initialiser i |
| 287 | | _ -> do_nothing r k e in |
| 288 | |
| 289 | let param r k e = |
| 290 | match Ast0.unwrap e with |
| 291 | Ast0.OptParam p | Ast0.UniqueParam p -> |
| 292 | (* put the + code on the thing, not on the opt *) |
| 293 | r.V0.combiner_parameter p |
| 294 | | _ -> do_nothing r k e in |
| 295 | |
| 296 | let case_line r k e = |
| 297 | match Ast0.unwrap e with |
| 298 | Ast0.OptCase c -> |
| 299 | (* put the + code on the thing, not on the opt *) |
| 300 | r.V0.combiner_case_line c |
| 301 | | _ -> do_nothing r k e in |
| 302 | |
| 303 | let do_top r k (e: Ast0.top_level) = k e in |
| 304 | |
| 305 | V0.combiner bind option_default |
| 306 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode |
| 307 | edots idots pdots sdots ddots cdots |
| 308 | ident expression typeC initialiser param decl statement case_line do_top |
| 309 | |
| 310 | |
| 311 | let call_collect_minus context_nodes : |
| 312 | (int * (minus_join_point * Ast0.info * Ast0.mcodekind) list) list = |
| 313 | List.map |
| 314 | (function e -> |
| 315 | match e with |
| 316 | Ast0.DotsExprTag(e) -> |
| 317 | (Ast0.get_index e, |
| 318 | (collect_minus_join_points e).V0.combiner_expression_dots e) |
| 319 | | Ast0.DotsInitTag(e) -> |
| 320 | (Ast0.get_index e, |
| 321 | (collect_minus_join_points e).V0.combiner_initialiser_list e) |
| 322 | | Ast0.DotsParamTag(e) -> |
| 323 | (Ast0.get_index e, |
| 324 | (collect_minus_join_points e).V0.combiner_parameter_list e) |
| 325 | | Ast0.DotsStmtTag(e) -> |
| 326 | (Ast0.get_index e, |
| 327 | (collect_minus_join_points e).V0.combiner_statement_dots e) |
| 328 | | Ast0.DotsDeclTag(e) -> |
| 329 | (Ast0.get_index e, |
| 330 | (collect_minus_join_points e).V0.combiner_declaration_dots e) |
| 331 | | Ast0.DotsCaseTag(e) -> |
| 332 | (Ast0.get_index e, |
| 333 | (collect_minus_join_points e).V0.combiner_case_line_dots e) |
| 334 | | Ast0.IdentTag(e) -> |
| 335 | (Ast0.get_index e, |
| 336 | (collect_minus_join_points e).V0.combiner_ident e) |
| 337 | | Ast0.ExprTag(e) -> |
| 338 | (Ast0.get_index e, |
| 339 | (collect_minus_join_points e).V0.combiner_expression e) |
| 340 | | Ast0.ArgExprTag(e) | Ast0.TestExprTag(e) -> |
| 341 | failwith "not possible - iso only" |
| 342 | | Ast0.TypeCTag(e) -> |
| 343 | (Ast0.get_index e, |
| 344 | (collect_minus_join_points e).V0.combiner_typeC e) |
| 345 | | Ast0.ParamTag(e) -> |
| 346 | (Ast0.get_index e, |
| 347 | (collect_minus_join_points e).V0.combiner_parameter e) |
| 348 | | Ast0.InitTag(e) -> |
| 349 | (Ast0.get_index e, |
| 350 | (collect_minus_join_points e).V0.combiner_initialiser e) |
| 351 | | Ast0.DeclTag(e) -> |
| 352 | (Ast0.get_index e, |
| 353 | (collect_minus_join_points e).V0.combiner_declaration e) |
| 354 | | Ast0.StmtTag(e) -> |
| 355 | (Ast0.get_index e, |
| 356 | (collect_minus_join_points e).V0.combiner_statement e) |
| 357 | | Ast0.CaseLineTag(e) -> |
| 358 | (Ast0.get_index e, |
| 359 | (collect_minus_join_points e).V0.combiner_case_line e) |
| 360 | | Ast0.TopTag(e) -> |
| 361 | (Ast0.get_index e, |
| 362 | (collect_minus_join_points e).V0.combiner_top_level e) |
| 363 | | Ast0.IsoWhenTag(_) -> failwith "only within iso phase" |
| 364 | | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase" |
| 365 | | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase" |
| 366 | | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase") |
| 367 | context_nodes |
| 368 | |
| 369 | (* result of collecting the join points should be sorted in nondecreasing |
| 370 | order by line *) |
| 371 | let verify l = |
| 372 | let get_info = function |
| 373 | (Favored,info,_) | (Unfavored,info,_) | (Toplevel,info,_) |
| 374 | | (Decl,info,_) -> info in |
| 375 | let token_start_line x = (get_info x).Ast0.logical_start in |
| 376 | let token_end_line x = (get_info x).Ast0.logical_end in |
| 377 | let token_real_start_line x = (get_info x).Ast0.line_start in |
| 378 | let token_real_end_line x = (get_info x).Ast0.line_end in |
| 379 | List.iter |
| 380 | (function |
| 381 | (index,((_::_) as l1)) -> |
| 382 | let _ = |
| 383 | List.fold_left |
| 384 | (function (prev,real_prev) -> |
| 385 | function cur -> |
| 386 | let ln = token_start_line cur in |
| 387 | if ln < prev |
| 388 | then |
| 389 | failwith |
| 390 | (Printf.sprintf |
| 391 | "error in collection of - tokens %d less than %d" |
| 392 | (token_real_start_line cur) real_prev); |
| 393 | (token_end_line cur,token_real_end_line cur)) |
| 394 | (token_end_line (List.hd l1), token_real_end_line (List.hd l1)) |
| 395 | (List.tl l1) in |
| 396 | () |
| 397 | | _ -> ()) (* dots, in eg f() has no join points *) |
| 398 | l |
| 399 | |
| 400 | let process_minus minus = |
| 401 | create_root_token_table minus; |
| 402 | List.concat |
| 403 | (List.map |
| 404 | (function x -> |
| 405 | let res = call_collect_minus (collect_context x) in |
| 406 | verify res; |
| 407 | res) |
| 408 | minus) |
| 409 | |
| 410 | (* --------------------------------------------------------------------- *) |
| 411 | (* --------------------------------------------------------------------- *) |
| 412 | (* collect the plus tokens *) |
| 413 | |
| 414 | let mk_structUnion x = Ast.StructUnionTag x |
| 415 | let mk_sign x = Ast.SignTag x |
| 416 | let mk_ident x = Ast.IdentTag (Ast0toast.ident x) |
| 417 | let mk_expression x = Ast.ExpressionTag (Ast0toast.expression x) |
| 418 | let mk_constant x = Ast.ConstantTag x |
| 419 | let mk_unaryOp x = Ast.UnaryOpTag x |
| 420 | let mk_assignOp x = Ast.AssignOpTag x |
| 421 | let mk_fixOp x = Ast.FixOpTag x |
| 422 | let mk_binaryOp x = Ast.BinaryOpTag x |
| 423 | let mk_arithOp x = Ast.ArithOpTag x |
| 424 | let mk_logicalOp x = Ast.LogicalOpTag x |
| 425 | let mk_declaration x = Ast.DeclarationTag (Ast0toast.declaration x) |
| 426 | let mk_topdeclaration x = Ast.DeclarationTag (Ast0toast.declaration x) |
| 427 | let mk_storage x = Ast.StorageTag x |
| 428 | let mk_inc_file x = Ast.IncFileTag x |
| 429 | let mk_statement x = Ast.StatementTag (Ast0toast.statement x) |
| 430 | let mk_case_line x = Ast.CaseLineTag (Ast0toast.case_line x) |
| 431 | let mk_const_vol x = Ast.ConstVolTag x |
| 432 | let mk_token x info = Ast.Token (x,Some info) |
| 433 | let mk_meta (_,x) info = Ast.Token (x,Some info) |
| 434 | let mk_code x = Ast.Code (Ast0toast.top_level x) |
| 435 | |
| 436 | let mk_exprdots x = Ast.ExprDotsTag (Ast0toast.expression_dots x) |
| 437 | let mk_paramdots x = Ast.ParamDotsTag (Ast0toast.parameter_list x) |
| 438 | let mk_stmtdots x = Ast.StmtDotsTag (Ast0toast.statement_dots x) |
| 439 | let mk_decldots x = Ast.DeclDotsTag (Ast0toast.declaration_dots x) |
| 440 | let mk_casedots x = failwith "+ case lines not supported" |
| 441 | let mk_typeC x = Ast.FullTypeTag (Ast0toast.typeC x) |
| 442 | let mk_init x = Ast.InitTag (Ast0toast.initialiser x) |
| 443 | let mk_param x = Ast.ParamTag (Ast0toast.parameterTypeDef x) |
| 444 | |
| 445 | let collect_plus_nodes root = |
| 446 | let root_index = Ast0.get_index root in |
| 447 | |
| 448 | let bind x y = x @ y in |
| 449 | let option_default = [] in |
| 450 | |
| 451 | let mcode fn (term,_,info,mcodekind,_) = |
| 452 | match mcodekind with Ast0.PLUS -> [(info,fn term)] | _ -> [] in |
| 453 | |
| 454 | let imcode fn (term,_,info,mcodekind,_) = |
| 455 | match mcodekind with |
| 456 | Ast0.PLUS -> [(info,fn term (Ast0toast.convert_info info))] |
| 457 | | _ -> [] in |
| 458 | |
| 459 | let do_nothing fn r k e = |
| 460 | match Ast0.get_mcodekind e with |
| 461 | (Ast0.CONTEXT(_)) when not(Ast0.get_index e = root_index) -> [] |
| 462 | | Ast0.PLUS -> [(Ast0.get_info e,fn e)] |
| 463 | | _ -> k e in |
| 464 | |
| 465 | (* case for everything that is just a wrapper for a simpler thing *) |
| 466 | let stmt r k e = |
| 467 | match Ast0.unwrap e with |
| 468 | Ast0.Exp(exp) -> r.V0.combiner_expression exp |
| 469 | | Ast0.TopExp(exp) -> r.V0.combiner_expression exp |
| 470 | | Ast0.Ty(ty) -> r.V0.combiner_typeC ty |
| 471 | | Ast0.TopInit(init) -> r.V0.combiner_initialiser init |
| 472 | | Ast0.Decl(_,decl) -> r.V0.combiner_declaration decl |
| 473 | | _ -> do_nothing mk_statement r k e in |
| 474 | |
| 475 | (* statementTag is preferred, because it indicates that one statement is |
| 476 | replaced by one statement, in single_statement *) |
| 477 | let stmt_dots r k e = |
| 478 | match Ast0.unwrap e with |
| 479 | Ast0.DOTS([s]) | Ast0.CIRCLES([s]) | Ast0.STARS([s]) -> |
| 480 | r.V0.combiner_statement s |
| 481 | | _ -> do_nothing mk_stmtdots r k e in |
| 482 | |
| 483 | let toplevel r k e = |
| 484 | match Ast0.unwrap e with |
| 485 | Ast0.DECL(s) -> r.V0.combiner_statement s |
| 486 | | Ast0.CODE(sdots) -> r.V0.combiner_statement_dots sdots |
| 487 | | _ -> do_nothing mk_code r k e in |
| 488 | |
| 489 | let initdots r k e = k e in |
| 490 | |
| 491 | V0.combiner bind option_default |
| 492 | (imcode mk_meta) (imcode mk_token) (mcode mk_constant) (mcode mk_assignOp) |
| 493 | (mcode mk_fixOp) |
| 494 | (mcode mk_unaryOp) (mcode mk_binaryOp) (mcode mk_const_vol) |
| 495 | (mcode mk_sign) (mcode mk_structUnion) |
| 496 | (mcode mk_storage) (mcode mk_inc_file) |
| 497 | (do_nothing mk_exprdots) initdots |
| 498 | (do_nothing mk_paramdots) stmt_dots (do_nothing mk_decldots) |
| 499 | (do_nothing mk_casedots) |
| 500 | (do_nothing mk_ident) (do_nothing mk_expression) |
| 501 | (do_nothing mk_typeC) (do_nothing mk_init) (do_nothing mk_param) |
| 502 | (do_nothing mk_declaration) |
| 503 | stmt (do_nothing mk_case_line) toplevel |
| 504 | |
| 505 | let call_collect_plus context_nodes : |
| 506 | (int * (Ast0.info * Ast.anything) list) list = |
| 507 | List.map |
| 508 | (function e -> |
| 509 | match e with |
| 510 | Ast0.DotsExprTag(e) -> |
| 511 | (Ast0.get_index e, |
| 512 | (collect_plus_nodes e).V0.combiner_expression_dots e) |
| 513 | | Ast0.DotsInitTag(e) -> |
| 514 | (Ast0.get_index e, |
| 515 | (collect_plus_nodes e).V0.combiner_initialiser_list e) |
| 516 | | Ast0.DotsParamTag(e) -> |
| 517 | (Ast0.get_index e, |
| 518 | (collect_plus_nodes e).V0.combiner_parameter_list e) |
| 519 | | Ast0.DotsStmtTag(e) -> |
| 520 | (Ast0.get_index e, |
| 521 | (collect_plus_nodes e).V0.combiner_statement_dots e) |
| 522 | | Ast0.DotsDeclTag(e) -> |
| 523 | (Ast0.get_index e, |
| 524 | (collect_plus_nodes e).V0.combiner_declaration_dots e) |
| 525 | | Ast0.DotsCaseTag(e) -> |
| 526 | (Ast0.get_index e, |
| 527 | (collect_plus_nodes e).V0.combiner_case_line_dots e) |
| 528 | | Ast0.IdentTag(e) -> |
| 529 | (Ast0.get_index e, |
| 530 | (collect_plus_nodes e).V0.combiner_ident e) |
| 531 | | Ast0.ExprTag(e) -> |
| 532 | (Ast0.get_index e, |
| 533 | (collect_plus_nodes e).V0.combiner_expression e) |
| 534 | | Ast0.ArgExprTag(_) | Ast0.TestExprTag(_) -> |
| 535 | failwith "not possible - iso only" |
| 536 | | Ast0.TypeCTag(e) -> |
| 537 | (Ast0.get_index e, |
| 538 | (collect_plus_nodes e).V0.combiner_typeC e) |
| 539 | | Ast0.InitTag(e) -> |
| 540 | (Ast0.get_index e, |
| 541 | (collect_plus_nodes e).V0.combiner_initialiser e) |
| 542 | | Ast0.ParamTag(e) -> |
| 543 | (Ast0.get_index e, |
| 544 | (collect_plus_nodes e).V0.combiner_parameter e) |
| 545 | | Ast0.DeclTag(e) -> |
| 546 | (Ast0.get_index e, |
| 547 | (collect_plus_nodes e).V0.combiner_declaration e) |
| 548 | | Ast0.StmtTag(e) -> |
| 549 | (Ast0.get_index e, |
| 550 | (collect_plus_nodes e).V0.combiner_statement e) |
| 551 | | Ast0.CaseLineTag(e) -> |
| 552 | (Ast0.get_index e, |
| 553 | (collect_plus_nodes e).V0.combiner_case_line e) |
| 554 | | Ast0.TopTag(e) -> |
| 555 | (Ast0.get_index e, |
| 556 | (collect_plus_nodes e).V0.combiner_top_level e) |
| 557 | | Ast0.IsoWhenTag(_) -> failwith "only within iso phase" |
| 558 | | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase" |
| 559 | | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase" |
| 560 | | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase") |
| 561 | context_nodes |
| 562 | |
| 563 | (* The plus fragments are converted to a list of lists of lists. |
| 564 | Innermost list: Elements have type anything. For any pair of successive |
| 565 | elements, n and n+1, the ending line of n is the same as the starting line |
| 566 | of n+1. |
| 567 | Middle lists: For any pair of successive elements, n and n+1, the ending |
| 568 | line of n is one less than the starting line of n+1. |
| 569 | Outer list: For any pair of successive elements, n and n+1, the ending |
| 570 | line of n is more than one less than the starting line of n+1. *) |
| 571 | |
| 572 | let logstart info = info.Ast0.logical_start |
| 573 | let logend info = info.Ast0.logical_end |
| 574 | |
| 575 | let redo info start finish = |
| 576 | {{info with Ast0.logical_start = start} with Ast0.logical_end = finish} |
| 577 | |
| 578 | let rec find_neighbors (index,l) : |
| 579 | int * (Ast0.info * (Ast.anything list list)) list = |
| 580 | let rec loop = function |
| 581 | [] -> [] |
| 582 | | (i,x)::rest -> |
| 583 | (match loop rest with |
| 584 | ((i1,(x1::rest_inner))::rest_middle)::rest_outer -> |
| 585 | let finish1 = logend i in |
| 586 | let start2 = logstart i1 in |
| 587 | if finish1 = start2 |
| 588 | then |
| 589 | ((redo i (logstart i) (logend i1),(x::x1::rest_inner)) |
| 590 | ::rest_middle) |
| 591 | ::rest_outer |
| 592 | else if finish1 + 1 = start2 |
| 593 | then ((i,[x])::(i1,(x1::rest_inner))::rest_middle)::rest_outer |
| 594 | else [(i,[x])]::((i1,(x1::rest_inner))::rest_middle)::rest_outer |
| 595 | | _ -> [[(i,[x])]]) (* rest must be [] *) in |
| 596 | let res = |
| 597 | List.map |
| 598 | (function l -> |
| 599 | let (start_info,_) = List.hd l in |
| 600 | let (end_info,_) = List.hd (List.rev l) in |
| 601 | (redo start_info (logstart start_info) (logend end_info), |
| 602 | List.map (function (_,x) -> x) l)) |
| 603 | (loop l) in |
| 604 | (index,res) |
| 605 | |
| 606 | let process_plus plus : |
| 607 | (int * (Ast0.info * Ast.anything list list) list) list = |
| 608 | List.concat |
| 609 | (List.map |
| 610 | (function x -> |
| 611 | List.map find_neighbors (call_collect_plus (collect_context x))) |
| 612 | plus) |
| 613 | |
| 614 | (* --------------------------------------------------------------------- *) |
| 615 | (* --------------------------------------------------------------------- *) |
| 616 | (* merge *) |
| 617 | (* |
| 618 | let merge_one = function |
| 619 | (m1::m2::minus_info,p::plus_info) -> |
| 620 | if p < m1, then |
| 621 | attach p to the beginning of m1.bef if m1 is Good, fail if it is bad |
| 622 | if p > m1 && p < m2, then consider the following possibilities, in order |
| 623 | m1 is Good and favored: attach to the beginning of m1.aft |
| 624 | m2 is Good and favored: attach to the beginning of m2.bef; drop m1 |
| 625 | m1 is Good and unfavored: attach to the beginning of m1.aft |
| 626 | m2 is Good and unfavored: attach to the beginning of m2.bef; drop m1 |
| 627 | also flip m1.bef if the first where > m1 |
| 628 | if we drop m1, then flip m1.aft first |
| 629 | if p > m2 |
| 630 | m2 is Good and favored: attach to the beginning of m2.aft; drop m1 |
| 631 | *) |
| 632 | |
| 633 | (* end of first argument < start/end of second argument *) |
| 634 | let less_than_start info1 info2 = |
| 635 | info1.Ast0.logical_end < info2.Ast0.logical_start |
| 636 | let less_than_end info1 info2 = |
| 637 | info1.Ast0.logical_end < info2.Ast0.logical_end |
| 638 | let greater_than_end info1 info2 = |
| 639 | info1.Ast0.logical_start > info2.Ast0.logical_end |
| 640 | let good_start info = info.Ast0.attachable_start |
| 641 | let good_end info = info.Ast0.attachable_end |
| 642 | |
| 643 | let toplevel = function Toplevel -> true | Favored | Unfavored | Decl -> false |
| 644 | let decl = function Decl -> true | Favored | Unfavored | Toplevel -> false |
| 645 | let favored = function Favored -> true | Unfavored | Toplevel | Decl -> false |
| 646 | |
| 647 | let top_code = |
| 648 | List.for_all (List.for_all (function Ast.Code _ -> true | _ -> false)) |
| 649 | |
| 650 | (* The following is probably not correct. The idea is to detect what |
| 651 | should be placed completely before the declaration. So type/storage |
| 652 | related things do not fall into this category, and complete statements do |
| 653 | fall into this category. But perhaps other things should be in this |
| 654 | category as well, such as { or ;? *) |
| 655 | let predecl_code = |
| 656 | let tester = function |
| 657 | (* the following should definitely be true *) |
| 658 | Ast.DeclarationTag _ |
| 659 | | Ast.StatementTag _ |
| 660 | | Ast.Rule_elemTag _ |
| 661 | | Ast.StmtDotsTag _ |
| 662 | | Ast.Code _ -> true |
| 663 | (* the following should definitely be false *) |
| 664 | | Ast.FullTypeTag _ | Ast.BaseTypeTag _ | Ast.StructUnionTag _ |
| 665 | | Ast.SignTag _ |
| 666 | | Ast.StorageTag _ | Ast.ConstVolTag _ | Ast.TypeCTag _ -> false |
| 667 | (* not sure about the rest *) |
| 668 | | _ -> false in |
| 669 | List.for_all (List.for_all tester) |
| 670 | |
| 671 | let pr = Printf.sprintf |
| 672 | |
| 673 | let insert thing thinginfo into intoinfo = |
| 674 | let get_last l = let l = List.rev l in (List.rev(List.tl l),List.hd l) in |
| 675 | let get_first l = (List.hd l,List.tl l) in |
| 676 | let thing_start = thinginfo.Ast0.logical_start in |
| 677 | let thing_end = thinginfo.Ast0.logical_end in |
| 678 | let thing_offset = thinginfo.Ast0.offset in |
| 679 | let into_start = intoinfo.Ast0.tline_start in |
| 680 | let into_end = intoinfo.Ast0.tline_end in |
| 681 | let into_left_offset = intoinfo.Ast0.left_offset in |
| 682 | let into_right_offset = intoinfo.Ast0.right_offset in |
| 683 | if thing_end < into_start && thing_start < into_start |
| 684 | then (thing@into, |
| 685 | {{intoinfo with Ast0.tline_start = thing_start} |
| 686 | with Ast0.left_offset = thing_offset}) |
| 687 | else if thing_end = into_start && thing_offset < into_left_offset |
| 688 | then |
| 689 | let (prev,last) = get_last thing in |
| 690 | let (first,rest) = get_first into in |
| 691 | (prev@[last@first]@rest, |
| 692 | {{intoinfo with Ast0.tline_start = thing_start} |
| 693 | with Ast0.left_offset = thing_offset}) |
| 694 | else if thing_start > into_end && thing_end > into_end |
| 695 | then (into@thing, |
| 696 | {{intoinfo with Ast0.tline_end = thing_end} |
| 697 | with Ast0.right_offset = thing_offset}) |
| 698 | else if thing_start = into_end && thing_offset > into_right_offset |
| 699 | then |
| 700 | let (first,rest) = get_first thing in |
| 701 | let (prev,last) = get_last into in |
| 702 | (prev@[last@first]@rest, |
| 703 | {{intoinfo with Ast0.tline_end = thing_end} |
| 704 | with Ast0.right_offset = thing_offset}) |
| 705 | else |
| 706 | begin |
| 707 | Printf.printf "thing start %d thing end %d into start %d into end %d\n" |
| 708 | thing_start thing_end into_start into_end; |
| 709 | Printf.printf "thing offset %d left offset %d right offset %d\n" |
| 710 | thing_offset into_left_offset into_right_offset; |
| 711 | Pretty_print_cocci.print_anything "" thing; |
| 712 | Pretty_print_cocci.print_anything "" into; |
| 713 | failwith "can't figure out where to put the + code" |
| 714 | end |
| 715 | |
| 716 | let init thing info = |
| 717 | (thing, |
| 718 | {Ast0.tline_start = info.Ast0.logical_start; |
| 719 | Ast0.tline_end = info.Ast0.logical_end; |
| 720 | Ast0.left_offset = info.Ast0.offset; |
| 721 | Ast0.right_offset = info.Ast0.offset}) |
| 722 | |
| 723 | let attachbefore (infop,p) = function |
| 724 | Ast0.MINUS(replacements) -> |
| 725 | (match !replacements with |
| 726 | ([],ti) -> replacements := init p infop |
| 727 | | (repl,ti) -> replacements := insert p infop repl ti) |
| 728 | | Ast0.CONTEXT(neighbors) -> |
| 729 | let (repl,ti1,ti2) = !neighbors in |
| 730 | (match repl with |
| 731 | Ast.BEFORE(bef) -> |
| 732 | let (bef,ti1) = insert p infop bef ti1 in |
| 733 | neighbors := (Ast.BEFORE(bef),ti1,ti2) |
| 734 | | Ast.AFTER(aft) -> |
| 735 | let (bef,ti1) = init p infop in |
| 736 | neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2) |
| 737 | | Ast.BEFOREAFTER(bef,aft) -> |
| 738 | let (bef,ti1) = insert p infop bef ti1 in |
| 739 | neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2) |
| 740 | | Ast.NOTHING -> |
| 741 | let (bef,ti1) = init p infop in |
| 742 | neighbors := (Ast.BEFORE(bef),ti1,ti2)) |
| 743 | | _ -> failwith "not possible for attachbefore" |
| 744 | |
| 745 | let attachafter (infop,p) = function |
| 746 | Ast0.MINUS(replacements) -> |
| 747 | (match !replacements with |
| 748 | ([],ti) -> replacements := init p infop |
| 749 | | (repl,ti) -> replacements := insert p infop repl ti) |
| 750 | | Ast0.CONTEXT(neighbors) -> |
| 751 | let (repl,ti1,ti2) = !neighbors in |
| 752 | (match repl with |
| 753 | Ast.BEFORE(bef) -> |
| 754 | let (aft,ti2) = init p infop in |
| 755 | neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2) |
| 756 | | Ast.AFTER(aft) -> |
| 757 | let (aft,ti2) = insert p infop aft ti2 in |
| 758 | neighbors := (Ast.AFTER(aft),ti1,ti2) |
| 759 | | Ast.BEFOREAFTER(bef,aft) -> |
| 760 | let (aft,ti2) = insert p infop aft ti2 in |
| 761 | neighbors := (Ast.BEFOREAFTER(bef,aft),ti1,ti2) |
| 762 | | Ast.NOTHING -> |
| 763 | let (aft,ti2) = init p infop in |
| 764 | neighbors := (Ast.AFTER(aft),ti1,ti2)) |
| 765 | | _ -> failwith "not possible for attachbefore" |
| 766 | |
| 767 | let attach_all_before ps m = |
| 768 | List.iter (function x -> attachbefore x m) ps |
| 769 | |
| 770 | let attach_all_after ps m = |
| 771 | List.iter (function x -> attachafter x m) ps |
| 772 | |
| 773 | let split_at_end info ps = |
| 774 | let split_point = info.Ast0.logical_end in |
| 775 | List.partition |
| 776 | (function (info,_) -> info.Ast0.logical_end < split_point) |
| 777 | ps |
| 778 | |
| 779 | let allminus = function |
| 780 | Ast0.MINUS(_) -> true |
| 781 | | _ -> false |
| 782 | |
| 783 | let rec before_m1 ((f1,infom1,m1) as x1) ((f2,infom2,m2) as x2) rest = function |
| 784 | [] -> () |
| 785 | | (((infop,_) as p) :: ps) as all -> |
| 786 | if less_than_start infop infom1 or |
| 787 | (allminus m1 && less_than_end infop infom1) (* account for trees *) |
| 788 | then |
| 789 | if good_start infom1 |
| 790 | then (attachbefore p m1; before_m1 x1 x2 rest ps) |
| 791 | else |
| 792 | failwith |
| 793 | (pr "%d: no available token to attach to" infop.Ast0.line_start) |
| 794 | else after_m1 x1 x2 rest all |
| 795 | |
| 796 | and after_m1 ((f1,infom1,m1) as x1) ((f2,infom2,m2) as x2) rest = function |
| 797 | [] -> () |
| 798 | | (((infop,pcode) as p) :: ps) as all -> |
| 799 | (* if the following is false, then some + code is stuck in the middle |
| 800 | of some context code (m1). could drop down to the token level. |
| 801 | this might require adjustments in ast0toast as well, when + code on |
| 802 | expressions is dropped down to + code on expressions. it might |
| 803 | also break some invariants on which iso depends, particularly on |
| 804 | what it can infer from something being CONTEXT with no top-level |
| 805 | modifications. for the moment, we thus give an error, asking the |
| 806 | user to rewrite the semantic patch. *) |
| 807 | if greater_than_end infop infom1 or is_minus m1 or !empty_isos |
| 808 | then |
| 809 | if less_than_start infop infom2 |
| 810 | then |
| 811 | if predecl_code pcode && good_end infom1 && decl f1 |
| 812 | then (attachafter p m1; after_m1 x1 x2 rest ps) |
| 813 | else if predecl_code pcode && good_start infom2 && decl f2 |
| 814 | then before_m2 x2 rest all |
| 815 | else if top_code pcode && good_end infom1 && toplevel f1 |
| 816 | then (attachafter p m1; after_m1 x1 x2 rest ps) |
| 817 | else if top_code pcode && good_start infom2 && toplevel f2 |
| 818 | then before_m2 x2 rest all |
| 819 | else if good_end infom1 && favored f1 |
| 820 | then (attachafter p m1; after_m1 x1 x2 rest ps) |
| 821 | else if good_start infom2 && favored f2 |
| 822 | then before_m2 x2 rest all |
| 823 | else if good_end infom1 |
| 824 | then (attachafter p m1; after_m1 x1 x2 rest ps) |
| 825 | else if good_start infom2 |
| 826 | then before_m2 x2 rest all |
| 827 | else |
| 828 | failwith |
| 829 | (pr "%d: no available token to attach to" infop.Ast0.line_start) |
| 830 | else after_m2 x2 rest all |
| 831 | else |
| 832 | begin |
| 833 | Printf.printf "between: p start %d p end %d m1 start %d m1 end %d m2 start %d m2 end %d\n" |
| 834 | infop.Ast0.line_start infop.Ast0.line_end |
| 835 | infom1.Ast0.line_start infom1.Ast0.line_end |
| 836 | infom2.Ast0.line_start infom2.Ast0.line_end; |
| 837 | Pretty_print_cocci.print_anything "" pcode; |
| 838 | failwith |
| 839 | "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." |
| 840 | end |
| 841 | |
| 842 | (* not sure this is safe. if have iso problems, consider changing this |
| 843 | to always return false *) |
| 844 | and is_minus = function |
| 845 | Ast0.MINUS _ -> true |
| 846 | | _ -> false |
| 847 | |
| 848 | and before_m2 ((f2,infom2,m2) as x2) rest |
| 849 | (p : (Ast0.info * Ast.anything list list) list) = |
| 850 | match (rest,p) with |
| 851 | (_,[]) -> () |
| 852 | | ([],((infop,_)::_)) -> |
| 853 | let (bef_m2,aft_m2) = split_at_end infom2 p in (* bef_m2 isn't empty *) |
| 854 | if good_start infom2 |
| 855 | then (attach_all_before bef_m2 m2; after_m2 x2 rest aft_m2) |
| 856 | else |
| 857 | failwith |
| 858 | (pr "%d: no available token to attach to" infop.Ast0.line_start) |
| 859 | | (m::ms,_) -> before_m1 x2 m ms p |
| 860 | |
| 861 | and after_m2 ((f2,infom2,m2) as x2) rest |
| 862 | (p : (Ast0.info * Ast.anything list list) list) = |
| 863 | match (rest,p) with |
| 864 | (_,[]) -> () |
| 865 | | ([],((infop,_)::_)) -> |
| 866 | if good_end infom2 |
| 867 | then attach_all_after p m2 |
| 868 | else |
| 869 | failwith |
| 870 | (pr "%d: no available token to attach to" infop.Ast0.line_start) |
| 871 | | (m::ms,_) -> after_m1 x2 m ms p |
| 872 | |
| 873 | let merge_one : (minus_join_point * Ast0.info * 'a) list * |
| 874 | (Ast0.info * Ast.anything list list) list -> unit = function (m,p) -> |
| 875 | (* |
| 876 | Printf.printf "minus code\n"; |
| 877 | List.iter |
| 878 | (function (_,info,_) -> |
| 879 | Printf.printf "start %d end %d real_start %d real_end %d\n" |
| 880 | info.Ast0.logical_start info.Ast0.logical_end |
| 881 | info.Ast0.line_start info.Ast0.line_end) |
| 882 | m; |
| 883 | Printf.printf "plus code\n"; |
| 884 | List.iter |
| 885 | (function (info,p) -> |
| 886 | Printf.printf "start %d end %d real_start %d real_end %d\n" |
| 887 | info.Ast0.logical_start info.Ast0.logical_end |
| 888 | info.Ast0.line_end info.Ast0.line_end; |
| 889 | Pretty_print_cocci.print_anything "" p; |
| 890 | Format.print_newline()) |
| 891 | p; |
| 892 | *) |
| 893 | match (m,p) with |
| 894 | (_,[]) -> () |
| 895 | | (m1::m2::restm,p) -> before_m1 m1 m2 restm p |
| 896 | | ([m],p) -> before_m2 m [] p |
| 897 | | ([],_) -> failwith "minus tree ran out before the plus tree" |
| 898 | |
| 899 | let merge minus_list plus_list = |
| 900 | (* |
| 901 | Printf.printf "minus list %s\n" |
| 902 | (String.concat " " |
| 903 | (List.map (function (x,_) -> string_of_int x) minus_list)); |
| 904 | Printf.printf "plus list %s\n" |
| 905 | (String.concat " " |
| 906 | (List.map (function (x,_) -> string_of_int x) plus_list)); |
| 907 | *) |
| 908 | List.iter |
| 909 | (function (index,minus_info) -> |
| 910 | let plus_info = List.assoc index plus_list in |
| 911 | merge_one (minus_info,plus_info)) |
| 912 | minus_list |
| 913 | |
| 914 | (* --------------------------------------------------------------------- *) |
| 915 | (* --------------------------------------------------------------------- *) |
| 916 | (* Need to check that CONTEXT nodes have nothing attached to their tokens. |
| 917 | If they do, they become MIXED *) |
| 918 | |
| 919 | let reevaluate_contextness = |
| 920 | let bind = (@) in |
| 921 | let option_default = [] in |
| 922 | |
| 923 | let mcode (_,_,_,mc,_) = |
| 924 | match mc with |
| 925 | Ast0.CONTEXT(mc) -> let (ba,_,_) = !mc in [ba] |
| 926 | | _ -> [] in |
| 927 | |
| 928 | let donothing r k e = |
| 929 | match Ast0.get_mcodekind e with |
| 930 | Ast0.CONTEXT(mc) -> |
| 931 | if List.exists (function Ast.NOTHING -> false | _ -> true) (k e) |
| 932 | then Ast0.set_mcodekind e (Ast0.MIXED(mc)); |
| 933 | [] |
| 934 | | _ -> let _ = k e in [] in |
| 935 | |
| 936 | let res = |
| 937 | V0.combiner bind option_default |
| 938 | mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode |
| 939 | donothing donothing donothing donothing donothing donothing donothing |
| 940 | donothing |
| 941 | donothing donothing donothing donothing donothing donothing donothing in |
| 942 | res.V0.combiner_top_level |
| 943 | |
| 944 | (* --------------------------------------------------------------------- *) |
| 945 | (* --------------------------------------------------------------------- *) |
| 946 | |
| 947 | let insert_plus minus plus ei = |
| 948 | empty_isos := ei; |
| 949 | let minus_stream = process_minus minus in |
| 950 | let plus_stream = process_plus plus in |
| 951 | merge minus_stream plus_stream; |
| 952 | List.iter (function x -> let _ = reevaluate_contextness x in ()) minus |