parsing_cocci/.#context_neg.ml.1.104

   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 (* Detects subtrees that are all minus/plus and nodes that are "binding
  24 context nodes".  The latter is a node whose structure and immediate tokens
  25 are the same in the minus and plus trees, and such that for every child,
  26 the set of context nodes in the child subtree is the same in the minus and
  27 plus subtrees. *)
  28
  29 module Ast = Ast_cocci
  30 module Ast0 = Ast0_cocci
  31 module V0 = Visitor_ast0
  32 module U = Unparse_ast0
  33
  34 (* --------------------------------------------------------------------- *)
  35 (* Generic access to code *)
  36
  37 let set_mcodekind x mcodekind =
  38   match x with
  39     Ast0.DotsExprTag(d) -> Ast0.set_mcodekind d mcodekind
  40   | Ast0.DotsInitTag(d) -> Ast0.set_mcodekind d mcodekind
  41   | Ast0.DotsParamTag(d) -> Ast0.set_mcodekind d mcodekind
  42   | Ast0.DotsStmtTag(d) -> Ast0.set_mcodekind d mcodekind
  43   | Ast0.DotsDeclTag(d) -> Ast0.set_mcodekind d mcodekind
  44   | Ast0.DotsCaseTag(d) -> Ast0.set_mcodekind d mcodekind
  45   | Ast0.IdentTag(d) -> Ast0.set_mcodekind d mcodekind
  46   | Ast0.ExprTag(d) -> Ast0.set_mcodekind d mcodekind
  47   | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
  48       failwith "not possible - iso only"
  49   | Ast0.TypeCTag(d) -> Ast0.set_mcodekind d mcodekind
  50   | Ast0.ParamTag(d) -> Ast0.set_mcodekind d mcodekind
  51   | Ast0.DeclTag(d) -> Ast0.set_mcodekind d mcodekind
  52   | Ast0.InitTag(d) -> Ast0.set_mcodekind d mcodekind
  53   | Ast0.StmtTag(d) -> Ast0.set_mcodekind d mcodekind
  54   | Ast0.CaseLineTag(d) -> Ast0.set_mcodekind d mcodekind
  55   | Ast0.TopTag(d) -> Ast0.set_mcodekind d mcodekind
  56   | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
  57   | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
  58   | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
  59   | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
  60
  61 let set_index x index =
  62   match x with
  63     Ast0.DotsExprTag(d) -> Ast0.set_index d index
  64   | Ast0.DotsInitTag(d) -> Ast0.set_index d index
  65   | Ast0.DotsParamTag(d) -> Ast0.set_index d index
  66   | Ast0.DotsStmtTag(d) -> Ast0.set_index d index
  67   | Ast0.DotsDeclTag(d) -> Ast0.set_index d index
  68   | Ast0.DotsCaseTag(d) -> Ast0.set_index d index
  69   | Ast0.IdentTag(d) -> Ast0.set_index d index
  70   | Ast0.ExprTag(d) -> Ast0.set_index d index
  71   | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
  72       failwith "not possible - iso only"
  73   | Ast0.TypeCTag(d) -> Ast0.set_index d index
  74   | Ast0.ParamTag(d) -> Ast0.set_index d index
  75   | Ast0.InitTag(d) -> Ast0.set_index d index
  76   | Ast0.DeclTag(d) -> Ast0.set_index d index
  77   | Ast0.StmtTag(d) -> Ast0.set_index d index
  78   | Ast0.CaseLineTag(d) -> Ast0.set_index d index
  79   | Ast0.TopTag(d) -> Ast0.set_index d index
  80   | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
  81   | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
  82   | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
  83   | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
  84
  85 let get_index = function
  86     Ast0.DotsExprTag(d) -> Index.expression_dots d
  87   | Ast0.DotsInitTag(d) -> Index.initialiser_dots d
  88   | Ast0.DotsParamTag(d) -> Index.parameter_dots d
  89   | Ast0.DotsStmtTag(d) -> Index.statement_dots d
  90   | Ast0.DotsDeclTag(d) -> Index.declaration_dots d
  91   | Ast0.DotsCaseTag(d) -> Index.case_line_dots d
  92   | Ast0.IdentTag(d) -> Index.ident d
  93   | Ast0.ExprTag(d) -> Index.expression d
  94   | Ast0.ArgExprTag(d) | Ast0.TestExprTag(d) ->
  95       failwith "not possible - iso only"
  96   | Ast0.TypeCTag(d) -> Index.typeC d
  97   | Ast0.ParamTag(d) -> Index.parameterTypeDef d
  98   | Ast0.InitTag(d) -> Index.initialiser d
  99   | Ast0.DeclTag(d) -> Index.declaration d
 100   | Ast0.StmtTag(d) -> Index.statement d
 101   | Ast0.CaseLineTag(d) -> Index.case_line d
 102   | Ast0.TopTag(d) -> Index.top_level d
 103   | Ast0.IsoWhenTag(_) -> failwith "only within iso phase"
 104   | Ast0.IsoWhenTTag(_) -> failwith "only within iso phase"
 105   | Ast0.IsoWhenFTag(_) -> failwith "only within iso phase"
 106   | Ast0.MetaPosTag(p) -> failwith "metapostag only within iso phase"
 107
 108 (* --------------------------------------------------------------------- *)
 109 (* Collect the line numbers of the plus code.  This is used for disjunctions.
 110 It is not completely clear why this is necessary, but it seems like an easy
 111 fix for whatever is the problem that is discussed in disj_cases *)
 112
 113 let plus_lines = ref ([] : int list)
 114
 115 let insert n =
 116   let rec loop = function
 117       [] -> [n]
 118     | x::xs ->
 119         match compare n x with
 120           1 -> x::(loop xs)
 121         | 0 -> x::xs
 122         | -1 -> n::x::xs
 123         | _ -> failwith "not possible" in
 124   plus_lines := loop !plus_lines
 125
 126 let find n min max =
 127   let rec loop = function
 128       [] -> (min,max)
 129     | [x] -> if n < x then (min,x) else (x,max)
 130     | x1::x2::rest ->
 131         if n < x1
 132         then (min,x1)
 133         else if n > x1 && n < x2 then (x1,x2) else loop (x2::rest) in
 134   loop !plus_lines
 135
 136 let collect_plus_lines top =
 137   plus_lines := [];
 138   let bind x y = () in
 139   let option_default = () in
 140   let donothing r k e = k e in
 141   let mcode (_,_,info,mcodekind,_) =
 142     match mcodekind with
 143       Ast0.PLUS -> insert info.Ast0.line_start
 144     | _ -> () in
 145   let fn =
 146     V0.combiner bind option_default
 147       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 148       donothing donothing donothing donothing donothing donothing
 149       donothing donothing donothing donothing donothing donothing donothing
 150       donothing donothing in
 151   fn.V0.combiner_top_level top
 152
 153 (* --------------------------------------------------------------------- *)
 154
 155 type kind = Neutral | AllMarked | NotAllMarked (* marked means + or - *)
 156
 157 (* --------------------------------------------------------------------- *)
 158 (* The first part analyzes each of the minus tree and the plus tree
 159 separately *)
 160
 161 (* ints are unique token indices (offset field) *)
 162 type node =
 163     Token (* tokens *) of kind * int (* unique index *) * Ast0.mcodekind *
 164         int list (* context tokens *)
 165   | Recursor (* children *) of kind *
 166         int list (* indices of all tokens at the level below *) *
 167         Ast0.mcodekind list (* tokens at the level below *) *
 168         int list
 169   | Bind (* neighbors *) of kind *
 170         int list (* indices of all tokens at current level *) *
 171         Ast0.mcodekind list (* tokens at current level *) *
 172         int list (* indices of all tokens at the level below *) *
 173         Ast0.mcodekind list (* tokens at the level below *)
 174         * int list list
 175
 176 let kind2c = function
 177     Neutral -> "neutral"
 178   | AllMarked -> "allmarked"
 179   | NotAllMarked -> "notallmarked"
 180
 181 let node2c = function
 182     Token(k,_,_,_) -> Printf.sprintf "token %s\n" (kind2c k)
 183   | Recursor(k,_,_,_) -> Printf.sprintf "recursor %s\n" (kind2c k)
 184   | Bind(k,_,_,_,_,_) -> Printf.sprintf "bind %s\n" (kind2c k)
 185
 186 (* goal: detect negative in both tokens and recursors, or context only in
 187 tokens *)
 188 let bind c1 c2 =
 189   let lub = function
 190       (k1,k2) when k1 = k2 -> k1
 191     | (Neutral,AllMarked) -> AllMarked
 192     | (AllMarked,Neutral) -> AllMarked
 193     | _ -> NotAllMarked in
 194   match (c1,c2) with
 195     (* token/token *)
 196     (* there are tokens at this level, so ignore the level below *)
 197     (Token(k1,i1,t1,l1),Token(k2,i2,t2,l2)) ->
 198       Bind(lub(k1,k2),[i1;i2],[t1;t2],[],[],[l1;l2])
 199
 200     (* token/recursor *)
 201     (* there are tokens at this level, so ignore the level below *)
 202   | (Token(k1,i1,t1,l1),Recursor(k2,_,_,l2)) ->
 203       Bind(lub(k1,k2),[i1],[t1],[],[],[l1;l2])
 204   | (Recursor(k1,_,_,l1),Token(k2,i2,t2,l2)) ->
 205       Bind(lub(k1,k2),[i2],[t2],[],[],[l1;l2])
 206
 207     (* token/bind *)
 208     (* there are tokens at this level, so ignore the level below *)
 209   | (Token(k1,i1,t1,l1),Bind(k2,i2,t2,_,_,l2)) ->
 210       Bind(lub(k1,k2),i1::i2,t1::t2,[],[],l1::l2)
 211   | (Bind(k1,i1,t1,_,_,l1),Token(k2,i2,t2,l2)) ->
 212       Bind(lub(k1,k2),i1@[i2],t1@[t2],[],[],l1@[l2])
 213
 214     (* recursor/bind *)
 215   | (Recursor(k1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
 216       Bind(lub(k1,k2),i2,t2,bi1@bi2,bt1@bt2,l1::l2)
 217   | (Bind(k1,i1,t1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
 218       Bind(lub(k1,k2),i1,t1,bi1@bi2,bt1@bt2,l1@[l2])
 219
 220     (* recursor/recursor and bind/bind - not likely to ever occur *)
 221   | (Recursor(k1,bi1,bt1,l1),Recursor(k2,bi2,bt2,l2)) ->
 222       Bind(lub(k1,k2),[],[],bi1@bi2,bt1@bt2,[l1;l2])
 223   | (Bind(k1,i1,t1,bi1,bt1,l1),Bind(k2,i2,t2,bi2,bt2,l2)) ->
 224       Bind(lub(k1,k2),i1@i2,t1@t2,bi1@bi2,bt1@bt2,l1@l2)
 225
 226
 227 let option_default = (*Bind(Neutral,[],[],[],[],[])*)
 228   Recursor(Neutral,[],[],[])
 229
 230 let mcode (_,_,info,mcodekind,pos) =
 231   let offset = info.Ast0.offset in
 232   match mcodekind with
 233     Ast0.MINUS(_) -> Token(AllMarked,offset,mcodekind,[])
 234   | Ast0.PLUS -> Token(AllMarked,offset,mcodekind,[])
 235   | Ast0.CONTEXT(_) -> Token(NotAllMarked,offset,mcodekind,[offset])
 236   | _ -> failwith "not possible"
 237
 238 let neutral_mcode (_,_,info,mcodekind,pos) =
 239   let offset = info.Ast0.offset in
 240   match mcodekind with
 241     Ast0.MINUS(_) -> Token(Neutral,offset,mcodekind,[])
 242   | Ast0.PLUS -> Token(Neutral,offset,mcodekind,[])
 243   | Ast0.CONTEXT(_) -> Token(Neutral,offset,mcodekind,[offset])
 244   | _ -> failwith "not possible"
 245
 246 let is_context = function Ast0.CONTEXT(_) -> true | _ -> false
 247
 248 let union_all l = List.fold_left Common.union_set [] l
 249
 250 (* is minus is true when we are processing minus code that might be
 251 intermingled with plus code.  it is used in disj_cases *)
 252 let classify is_minus all_marked table code =
 253   let mkres builder k il tl bil btl l e =
 254     (if k = AllMarked
 255     then Ast0.set_mcodekind e (all_marked()) (* definitive *)
 256     else
 257       let check_index il tl =
 258         if List.for_all is_context tl
 259         then
 260           (let e1 = builder e in
 261           let index = (get_index e1)@il in
 262           try
 263             let _ = Hashtbl.find table index in
 264             failwith
 265               (Printf.sprintf "line %d: index %s already used\n"
 266                  (Ast0.get_info e).Ast0.line_start
 267                  (String.concat " " (List.map string_of_int index)))
 268           with Not_found -> Hashtbl.add table index (e1,l)) in
 269       if il = [] then check_index bil btl else check_index il tl);
 270     if il = []
 271     then Recursor(k, bil, btl, union_all l)
 272     else Recursor(k, il, tl, union_all l) in
 273
 274   let compute_result builder e = function
 275       Bind(k,il,tl,bil,btl,l) -> mkres builder k il tl bil btl l e
 276     | Token(k,il,tl,l) -> mkres builder k [il] [tl] [] [] [l] e
 277     | Recursor(k,bil,btl,l) -> mkres builder k [] [] bil btl [l] e in
 278
 279   let make_not_marked = function
 280       Bind(k,il,tl,bil,btl,l) -> Bind(NotAllMarked,il,tl,bil,btl,l)
 281     | Token(k,il,tl,l) -> Token(NotAllMarked,il,tl,l)
 282     | Recursor(k,bil,btl,l) -> Recursor(NotAllMarked,bil,btl,l) in
 283
 284   let do_nothing builder r k e = compute_result builder e (k e) in
 285
 286   let disj_cases disj starter code fn ender =
 287     (* neutral_mcode used so starter and ender don't have an affect on
 288        whether the code is considered all plus/minus, but so that they are
 289        consider in the index list, which is needed to make a disj with
 290        something in one branch and nothing in the other different from code
 291        that just has the something (starter/ender enough, mids not needed
 292        for this).  Cannot agglomerate + code over | boundaries, because two -
 293        cases might have different + code, and don't want to put the + code
 294        together into one unit. *)
 295     let make_not_marked =
 296       if is_minus
 297       then
 298         (let min = Ast0.get_line disj in
 299         let max = Ast0.get_line_end disj in
 300         let (plus_min,plus_max) = find min (min-1) (max+1) in
 301         if max > plus_max then make_not_marked else (function x -> x))
 302       else make_not_marked in
 303     bind (neutral_mcode starter)
 304       (bind (List.fold_right bind
 305                (List.map make_not_marked (List.map fn code))
 306                option_default)
 307          (neutral_mcode ender)) in
 308
 309   (* no whencode in plus tree so have to drop it *)
 310   (* need special cases for dots, nests, and disjs *)
 311   let expression r k e =
 312     compute_result Ast0.expr e
 313       (match Ast0.unwrap e with
 314         Ast0.NestExpr(starter,exp,ender,whencode,multi) ->
 315           k (Ast0.rewrap e (Ast0.NestExpr(starter,exp,ender,None,multi)))
 316       | Ast0.Edots(dots,whencode) ->
 317           k (Ast0.rewrap e (Ast0.Edots(dots,None)))
 318       | Ast0.Ecircles(dots,whencode) ->
 319           k (Ast0.rewrap e (Ast0.Ecircles(dots,None)))
 320       | Ast0.Estars(dots,whencode) ->
 321           k (Ast0.rewrap e (Ast0.Estars(dots,None)))
 322       | Ast0.DisjExpr(starter,expr_list,_,ender) ->
 323           disj_cases e starter expr_list r.V0.combiner_expression ender
 324       | _ -> k e) in
 325
 326   (* not clear why we have the next two cases, since DisjDecl and
 327   DisjType shouldn't have been constructed yet, as they only come from isos *)
 328   let declaration r k e =
 329     compute_result Ast0.decl e
 330       (match Ast0.unwrap e with
 331         Ast0.DisjDecl(starter,decls,_,ender) ->
 332           disj_cases e starter decls r.V0.combiner_declaration ender
 333       | Ast0.Ddots(dots,whencode) ->
 334           k (Ast0.rewrap e (Ast0.Ddots(dots,None)))
 335         (* Need special cases for the following so that the type will be
 336            considered as a unit, rather than distributed around the
 337            declared variable.  This needs to be done because of the call to
 338            compute_result, ie the processing of each term should make a
 339            side-effect on the complete term structure as well as collecting
 340            some information about it.  So we have to visit each complete
 341            term structure.  In (all?) other such cases, we visit the terms
 342            using rebuilder, which just visits the subterms, rather than
 343            reordering their components. *)
 344       | Ast0.Init(stg,ty,id,eq,ini,sem) ->
 345           bind (match stg with Some stg -> mcode stg | _ -> option_default)
 346             (bind (r.V0.combiner_typeC ty)
 347                (bind (r.V0.combiner_ident id)
 348                   (bind (mcode eq)
 349                      (bind (r.V0.combiner_initialiser ini) (mcode sem)))))
 350       | Ast0.UnInit(stg,ty,id,sem) ->
 351           bind (match stg with Some stg -> mcode stg | _ -> option_default)
 352             (bind (r.V0.combiner_typeC ty)
 353                (bind (r.V0.combiner_ident id) (mcode sem)))
 354       | _ -> k e) in
 355
 356   let param r k e =
 357     compute_result Ast0.param e
 358       (match Ast0.unwrap e with
 359         Ast0.Param(ty,Some id) ->
 360           (* needed for the same reason as in the Init and UnInit cases *)
 361           bind (r.V0.combiner_typeC ty) (r.V0.combiner_ident id)
 362       | _ -> k e) in
 363
 364   let typeC r k e =
 365     compute_result Ast0.typeC e
 366       (match Ast0.unwrap e with
 367         Ast0.DisjType(starter,types,_,ender) ->
 368           disj_cases e starter types r.V0.combiner_typeC ender
 369       | _ -> k e) in
 370
 371   let initialiser r k i =
 372     compute_result Ast0.ini i
 373       (match Ast0.unwrap i with
 374         Ast0.Idots(dots,whencode) ->
 375           k (Ast0.rewrap i (Ast0.Idots(dots,None)))
 376       | _ -> k i) in
 377
 378   let statement r k s =
 379     compute_result Ast0.stmt s
 380       (match Ast0.unwrap s with
 381         Ast0.Nest(started,stm_dots,ender,whencode,multi) ->
 382           k (Ast0.rewrap s (Ast0.Nest(started,stm_dots,ender,[],multi)))
 383       | Ast0.Dots(dots,whencode) ->
 384           k (Ast0.rewrap s (Ast0.Dots(dots,[])))
 385       | Ast0.Circles(dots,whencode) ->
 386           k (Ast0.rewrap s (Ast0.Circles(dots,[])))
 387       | Ast0.Stars(dots,whencode) ->
 388           k (Ast0.rewrap s (Ast0.Stars(dots,[])))
 389       | Ast0.Disj(starter,statement_dots_list,_,ender) ->
 390           disj_cases s starter statement_dots_list r.V0.combiner_statement_dots
 391             ender
 392 (*  Why? There is nothing there
 393         (* cases for everything with extra mcode *)
 394       | Ast0.FunDecl((info,bef),_,_,_,_,_,_,_,_)
 395       | Ast0.Decl((info,bef),_) ->
 396           bind (mcode ((),(),info,bef)) (k s)
 397       | Ast0.IfThen(_,_,_,_,_,(info,aft))
 398       | Ast0.IfThenElse(_,_,_,_,_,_,_,(info,aft))
 399       | Ast0.While(_,_,_,_,_,(info,aft)) ->
 400       | Ast0.For(_,_,_,_,_,_,_,_,_,(info,aft)) ->
 401           bind (k s) (mcode ((),(),info,aft))
 402       | Ast0.Iterator(_,_,_,_,_,(info,aft))
 403 *)
 404       | _ -> k s
 405
 406 ) in
 407
 408   let do_top builder r k e = compute_result builder e (k e) in
 409
 410   let combiner =
 411     V0.combiner bind option_default
 412       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 413       (do_nothing Ast0.dotsExpr) (do_nothing Ast0.dotsInit)
 414       (do_nothing Ast0.dotsParam) (do_nothing Ast0.dotsStmt)
 415       (do_nothing Ast0.dotsDecl) (do_nothing Ast0.dotsCase)
 416       (do_nothing Ast0.ident) expression typeC initialiser param declaration
 417       statement (do_nothing Ast0.case_line) (do_top Ast0.top) in
 418   combiner.V0.combiner_top_level code
 419
 420 (* --------------------------------------------------------------------- *)
 421 (* Traverse the hash tables and find corresponding context nodes that have
 422 the same context children *)
 423
 424 (* this is just a sanity check - really only need to look at the top-level
 425    structure *)
 426 let equal_mcode (_,_,info1,_,_) (_,_,info2,_,_) =
 427   info1.Ast0.offset = info2.Ast0.offset
 428
 429 let equal_option e1 e2 =
 430   match (e1,e2) with
 431     (Some x, Some y) -> equal_mcode x y
 432   | (None, None) -> true
 433   | _ -> false
 434
 435 let dots fn d1 d2 =
 436   match (Ast0.unwrap d1,Ast0.unwrap d2) with
 437     (Ast0.DOTS(l1),Ast0.DOTS(l2)) -> List.length l1 = List.length l2
 438   | (Ast0.CIRCLES(l1),Ast0.CIRCLES(l2)) -> List.length l1 = List.length l2
 439   | (Ast0.STARS(l1),Ast0.STARS(l2)) -> List.length l1 = List.length l2
 440   | _ -> false
 441
 442 let rec equal_ident i1 i2 =
 443   match (Ast0.unwrap i1,Ast0.unwrap i2) with
 444     (Ast0.Id(name1),Ast0.Id(name2)) -> equal_mcode name1 name2
 445   | (Ast0.MetaId(name1,_,_),Ast0.MetaId(name2,_,_)) ->
 446       equal_mcode name1 name2
 447   | (Ast0.MetaFunc(name1,_,_),Ast0.MetaFunc(name2,_,_)) ->
 448       equal_mcode name1 name2
 449   | (Ast0.MetaLocalFunc(name1,_,_),Ast0.MetaLocalFunc(name2,_,_)) ->
 450       equal_mcode name1 name2
 451   | (Ast0.OptIdent(_),Ast0.OptIdent(_)) -> true
 452   | (Ast0.UniqueIdent(_),Ast0.UniqueIdent(_)) -> true
 453   | _ -> false
 454
 455 let rec equal_expression e1 e2 =
 456   match (Ast0.unwrap e1,Ast0.unwrap e2) with
 457     (Ast0.Ident(_),Ast0.Ident(_)) -> true
 458   | (Ast0.Constant(const1),Ast0.Constant(const2)) -> equal_mcode const1 const2
 459   | (Ast0.FunCall(_,lp1,_,rp1),Ast0.FunCall(_,lp2,_,rp2)) ->
 460       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 461   | (Ast0.Assignment(_,op1,_,_),Ast0.Assignment(_,op2,_,_)) ->
 462       equal_mcode op1 op2
 463   | (Ast0.CondExpr(_,why1,_,colon1,_),Ast0.CondExpr(_,why2,_,colon2,_)) ->
 464       equal_mcode why1 why2 && equal_mcode colon1 colon2
 465   | (Ast0.Postfix(_,op1),Ast0.Postfix(_,op2)) -> equal_mcode op1 op2
 466   | (Ast0.Infix(_,op1),Ast0.Infix(_,op2)) -> equal_mcode op1 op2
 467   | (Ast0.Unary(_,op1),Ast0.Unary(_,op2)) -> equal_mcode op1 op2
 468   | (Ast0.Binary(_,op1,_),Ast0.Binary(_,op2,_)) -> equal_mcode op1 op2
 469   | (Ast0.Paren(lp1,_,rp1),Ast0.Paren(lp2,_,rp2)) ->
 470       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 471   | (Ast0.ArrayAccess(_,lb1,_,rb1),Ast0.ArrayAccess(_,lb2,_,rb2)) ->
 472       equal_mcode lb1 lb2 && equal_mcode rb1 rb2
 473   | (Ast0.RecordAccess(_,pt1,_),Ast0.RecordAccess(_,pt2,_)) ->
 474       equal_mcode pt1 pt2
 475   | (Ast0.RecordPtAccess(_,ar1,_),Ast0.RecordPtAccess(_,ar2,_)) ->
 476       equal_mcode ar1 ar2
 477   | (Ast0.Cast(lp1,_,rp1,_),Ast0.Cast(lp2,_,rp2,_)) ->
 478       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 479   | (Ast0.SizeOfExpr(szf1,_),Ast0.SizeOfExpr(szf2,_)) ->
 480       equal_mcode szf1 szf2
 481   | (Ast0.SizeOfType(szf1,lp1,_,rp1),Ast0.SizeOfType(szf2,lp2,_,rp2)) ->
 482       equal_mcode szf1 szf2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 483   | (Ast0.TypeExp(_),Ast0.TypeExp(_)) -> true
 484   | (Ast0.MetaErr(name1,_,_),Ast0.MetaErr(name2,_,_))
 485   | (Ast0.MetaExpr(name1,_,_,_,_),Ast0.MetaExpr(name2,_,_,_,_))
 486   | (Ast0.MetaExprList(name1,_,_),Ast0.MetaExprList(name2,_,_)) ->
 487       equal_mcode name1 name2
 488   | (Ast0.EComma(cm1),Ast0.EComma(cm2)) -> equal_mcode cm1 cm2
 489   | (Ast0.DisjExpr(starter1,_,mids1,ender1),
 490      Ast0.DisjExpr(starter2,_,mids2,ender2)) ->
 491        equal_mcode starter1 starter2 &&
 492        List.for_all2 equal_mcode mids1 mids2 &&
 493        equal_mcode ender1 ender2
 494   | (Ast0.NestExpr(starter1,_,ender1,_,m1),
 495      Ast0.NestExpr(starter2,_,ender2,_,m2)) ->
 496       equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
 497   | (Ast0.Edots(dots1,_),Ast0.Edots(dots2,_))
 498   | (Ast0.Ecircles(dots1,_),Ast0.Ecircles(dots2,_))
 499   | (Ast0.Estars(dots1,_),Ast0.Estars(dots2,_)) -> equal_mcode dots1 dots2
 500   | (Ast0.OptExp(_),Ast0.OptExp(_)) -> true
 501   | (Ast0.UniqueExp(_),Ast0.UniqueExp(_)) -> true
 502   | _ -> false
 503
 504 let rec equal_typeC t1 t2 =
 505   match (Ast0.unwrap t1,Ast0.unwrap t2) with
 506     (Ast0.ConstVol(cv1,_),Ast0.ConstVol(cv2,_)) -> equal_mcode cv1 cv2
 507   | (Ast0.BaseType(ty1,stringsa),Ast0.BaseType(ty2,stringsb)) ->
 508       List.for_all2 equal_mcode stringsa stringsb
 509   | (Ast0.Signed(sign1,_),Ast0.Signed(sign2,_)) ->
 510       equal_mcode sign1 sign2
 511   | (Ast0.Pointer(_,star1),Ast0.Pointer(_,star2)) ->
 512       equal_mcode star1 star2
 513   | (Ast0.Array(_,lb1,_,rb1),Ast0.Array(_,lb2,_,rb2)) ->
 514       equal_mcode lb1 lb2 && equal_mcode rb1 rb2
 515   | (Ast0.EnumName(kind1,_),Ast0.EnumName(kind2,_)) ->
 516       equal_mcode kind1 kind2
 517   | (Ast0.StructUnionName(kind1,_),Ast0.StructUnionName(kind2,_)) ->
 518       equal_mcode kind1 kind2
 519   | (Ast0.FunctionType(ty1,lp1,p1,rp1),Ast0.FunctionType(ty2,lp2,p2,rp2)) ->
 520       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 521   | (Ast0.StructUnionDef(_,lb1,_,rb1),
 522      Ast0.StructUnionDef(_,lb2,_,rb2)) ->
 523        equal_mcode lb1 lb2 && equal_mcode rb1 rb2
 524   | (Ast0.TypeName(name1),Ast0.TypeName(name2)) -> equal_mcode name1 name2
 525   | (Ast0.MetaType(name1,_),Ast0.MetaType(name2,_)) ->
 526       equal_mcode name1 name2
 527   | (Ast0.DisjType(starter1,_,mids1,ender1),
 528      Ast0.DisjType(starter2,_,mids2,ender2)) ->
 529        equal_mcode starter1 starter2 &&
 530        List.for_all2 equal_mcode mids1 mids2 &&
 531        equal_mcode ender1 ender2
 532   | (Ast0.OptType(_),Ast0.OptType(_)) -> true
 533   | (Ast0.UniqueType(_),Ast0.UniqueType(_)) -> true
 534   | _ -> false
 535
 536 let equal_declaration d1 d2 =
 537   match (Ast0.unwrap d1,Ast0.unwrap d2) with
 538     (Ast0.Init(stg1,_,_,eq1,_,sem1),Ast0.Init(stg2,_,_,eq2,_,sem2)) ->
 539       equal_option stg1 stg2 && equal_mcode eq1 eq2 && equal_mcode sem1 sem2
 540   | (Ast0.UnInit(stg1,_,_,sem1),Ast0.UnInit(stg2,_,_,sem2)) ->
 541       equal_option stg1 stg2 && equal_mcode sem1 sem2
 542   | (Ast0.MacroDecl(nm1,lp1,_,rp1,sem1),Ast0.MacroDecl(nm2,lp2,_,rp2,sem2)) ->
 543       equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
 544   | (Ast0.TyDecl(_,sem1),Ast0.TyDecl(_,sem2)) -> equal_mcode sem1 sem2
 545   | (Ast0.Ddots(dots1,_),Ast0.Ddots(dots2,_)) -> equal_mcode dots1 dots2
 546   | (Ast0.OptDecl(_),Ast0.OptDecl(_)) -> true
 547   | (Ast0.UniqueDecl(_),Ast0.UniqueDecl(_)) -> true
 548   | (Ast0.DisjDecl _,_) | (_,Ast0.DisjDecl _) ->
 549       failwith "DisjDecl not expected here"
 550   | _ -> false
 551
 552 let equal_designator d1 d2 =
 553   match (d1,d2) with
 554     (Ast0.DesignatorField(dot1,_),Ast0.DesignatorField(dot2,_)) ->
 555       equal_mcode dot1 dot2
 556   | (Ast0.DesignatorIndex(lb1,_,rb1),Ast0.DesignatorIndex(lb2,_,rb2)) ->
 557       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
 558   | (Ast0.DesignatorRange(lb1,_,dots1,_,rb1),
 559      Ast0.DesignatorRange(lb2,_,dots2,_,rb2)) ->
 560        (equal_mcode lb1 lb2) && (equal_mcode dots1 dots2) &&
 561        (equal_mcode rb1 rb2)
 562   | _ -> false
 563
 564 let equal_initialiser i1 i2 =
 565   match (Ast0.unwrap i1,Ast0.unwrap i2) with
 566     (Ast0.MetaInit(name1,_),Ast0.MetaInit(name2,_)) ->
 567       equal_mcode name1 name2
 568   | (Ast0.InitExpr(_),Ast0.InitExpr(_)) -> true
 569   | (Ast0.InitList(lb1,_,rb1),Ast0.InitList(lb2,_,rb2)) ->
 570       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
 571   | (Ast0.InitGccExt(designators1,eq1,_),
 572      Ast0.InitGccExt(designators2,eq2,_)) ->
 573        (List.for_all2 equal_designator designators1 designators2) &&
 574        (equal_mcode eq1 eq2)
 575   | (Ast0.InitGccName(_,eq1,_),Ast0.InitGccName(_,eq2,_)) ->
 576       equal_mcode eq1 eq2
 577   | (Ast0.IComma(cm1),Ast0.IComma(cm2)) -> equal_mcode cm1 cm2
 578   | (Ast0.Idots(d1,_),Ast0.Idots(d2,_)) -> equal_mcode d1 d2
 579   | (Ast0.OptIni(_),Ast0.OptIni(_)) -> true
 580   | (Ast0.UniqueIni(_),Ast0.UniqueIni(_)) -> true
 581   | _ -> false
 582
 583 let equal_parameterTypeDef p1 p2 =
 584   match (Ast0.unwrap p1,Ast0.unwrap p2) with
 585     (Ast0.VoidParam(_),Ast0.VoidParam(_)) -> true
 586   | (Ast0.Param(_,_),Ast0.Param(_,_)) -> true
 587   | (Ast0.MetaParam(name1,_),Ast0.MetaParam(name2,_))
 588   | (Ast0.MetaParamList(name1,_,_),Ast0.MetaParamList(name2,_,_)) ->
 589       equal_mcode name1 name2
 590   | (Ast0.PComma(cm1),Ast0.PComma(cm2)) -> equal_mcode cm1 cm2
 591   | (Ast0.Pdots(dots1),Ast0.Pdots(dots2))
 592   | (Ast0.Pcircles(dots1),Ast0.Pcircles(dots2)) -> equal_mcode dots1 dots2
 593   | (Ast0.OptParam(_),Ast0.OptParam(_)) -> true
 594   | (Ast0.UniqueParam(_),Ast0.UniqueParam(_)) -> true
 595   | _ -> false
 596
 597 let rec equal_statement s1 s2 =
 598   match (Ast0.unwrap s1,Ast0.unwrap s2) with
 599     (Ast0.FunDecl(_,fninfo1,_,lp1,_,rp1,lbrace1,_,rbrace1),
 600      Ast0.FunDecl(_,fninfo2,_,lp2,_,rp2,lbrace2,_,rbrace2)) ->
 601        (List.length fninfo1) = (List.length fninfo2) &&
 602        List.for_all2 equal_fninfo fninfo1 fninfo2 &&
 603        equal_mcode lp1 lp2 && equal_mcode rp1 rp2 &&
 604        equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 605   | (Ast0.Decl(_,_),Ast0.Decl(_,_)) -> true
 606   | (Ast0.Seq(lbrace1,_,rbrace1),Ast0.Seq(lbrace2,_,rbrace2)) ->
 607       equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 608   | (Ast0.ExprStatement(_,sem1),Ast0.ExprStatement(_,sem2)) ->
 609       equal_mcode sem1 sem2
 610   | (Ast0.IfThen(iff1,lp1,_,rp1,_,_),Ast0.IfThen(iff2,lp2,_,rp2,_,_)) ->
 611       equal_mcode iff1 iff2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 612   | (Ast0.IfThenElse(iff1,lp1,_,rp1,_,els1,_,_),
 613      Ast0.IfThenElse(iff2,lp2,_,rp2,_,els2,_,_)) ->
 614        equal_mcode iff1 iff2 &&
 615          equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode els1 els2
 616   | (Ast0.While(whl1,lp1,_,rp1,_,_),Ast0.While(whl2,lp2,_,rp2,_,_)) ->
 617       equal_mcode whl1 whl2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 618   | (Ast0.Do(d1,_,whl1,lp1,_,rp1,sem1),Ast0.Do(d2,_,whl2,lp2,_,rp2,sem2)) ->
 619       equal_mcode whl1 whl2 && equal_mcode d1 d2 &&
 620       equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
 621   | (Ast0.For(fr1,lp1,_,sem11,_,sem21,_,rp1,_,_),
 622      Ast0.For(fr2,lp2,_,sem12,_,sem22,_,rp2,_,_)) ->
 623        equal_mcode fr1 fr2 && equal_mcode lp1 lp2 &&
 624        equal_mcode sem11 sem12 && equal_mcode sem21 sem22 &&
 625        equal_mcode rp1 rp2
 626   | (Ast0.Iterator(nm1,lp1,_,rp1,_,_),Ast0.Iterator(nm2,lp2,_,rp2,_,_)) ->
 627       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 628   | (Ast0.Switch(switch1,lp1,_,rp1,lb1,case1,rb1),
 629      Ast0.Switch(switch2,lp2,_,rp2,lb2,case2,rb2)) ->
 630        equal_mcode switch1 switch2 && equal_mcode lp1 lp2 &&
 631        equal_mcode rp1 rp2 && equal_mcode lb1 lb2 &&
 632        equal_mcode rb1 rb2
 633   | (Ast0.Break(br1,sem1),Ast0.Break(br2,sem2)) ->
 634       equal_mcode br1 br2 && equal_mcode sem1 sem2
 635   | (Ast0.Continue(cont1,sem1),Ast0.Continue(cont2,sem2)) ->
 636       equal_mcode cont1 cont2 && equal_mcode sem1 sem2
 637   | (Ast0.Label(_,dd1),Ast0.Label(_,dd2)) ->
 638       equal_mcode dd1 dd2
 639   | (Ast0.Goto(g1,_,sem1),Ast0.Goto(g2,_,sem2)) ->
 640       equal_mcode g1 g2 && equal_mcode sem1 sem2
 641   | (Ast0.Return(ret1,sem1),Ast0.Return(ret2,sem2)) ->
 642       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 643   | (Ast0.ReturnExpr(ret1,_,sem1),Ast0.ReturnExpr(ret2,_,sem2)) ->
 644       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 645   | (Ast0.MetaStmt(name1,_),Ast0.MetaStmt(name2,_))
 646   | (Ast0.MetaStmtList(name1,_),Ast0.MetaStmtList(name2,_)) ->
 647       equal_mcode name1 name2
 648   | (Ast0.Disj(starter1,_,mids1,ender1),Ast0.Disj(starter2,_,mids2,ender2)) ->
 649       equal_mcode starter1 starter2 &&
 650       List.for_all2 equal_mcode mids1 mids2 &&
 651       equal_mcode ender1 ender2
 652   | (Ast0.Nest(starter1,_,ender1,_,m1),Ast0.Nest(starter2,_,ender2,_,m2)) ->
 653       equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
 654   | (Ast0.Exp(_),Ast0.Exp(_)) -> true
 655   | (Ast0.TopExp(_),Ast0.TopExp(_)) -> true
 656   | (Ast0.Ty(_),Ast0.Ty(_)) -> true
 657   | (Ast0.TopInit(_),Ast0.TopInit(_)) -> true
 658   | (Ast0.Dots(d1,_),Ast0.Dots(d2,_))
 659   | (Ast0.Circles(d1,_),Ast0.Circles(d2,_))
 660   | (Ast0.Stars(d1,_),Ast0.Stars(d2,_)) -> equal_mcode d1 d2
 661   | (Ast0.Include(inc1,name1),Ast0.Include(inc2,name2)) ->
 662       equal_mcode inc1 inc2 && equal_mcode name1 name2
 663   | (Ast0.Define(def1,_,_,_),Ast0.Define(def2,_,_,_)) ->
 664       equal_mcode def1 def2
 665   | (Ast0.OptStm(_),Ast0.OptStm(_)) -> true
 666   | (Ast0.UniqueStm(_),Ast0.UniqueStm(_)) -> true
 667   | _ -> false
 668
 669 and equal_fninfo x y =
 670   match (x,y) with
 671     (Ast0.FStorage(s1),Ast0.FStorage(s2)) -> equal_mcode s1 s2
 672   | (Ast0.FType(_),Ast0.FType(_)) -> true
 673   | (Ast0.FInline(i1),Ast0.FInline(i2)) -> equal_mcode i1 i2
 674   | (Ast0.FAttr(i1),Ast0.FAttr(i2)) -> equal_mcode i1 i2
 675   | _ -> false
 676
 677 let equal_case_line c1 c2 =
 678   match (Ast0.unwrap c1,Ast0.unwrap c2) with
 679     (Ast0.Default(def1,colon1,_),Ast0.Default(def2,colon2,_)) ->
 680       equal_mcode def1 def2 && equal_mcode colon1 colon2
 681   | (Ast0.Case(case1,_,colon1,_),Ast0.Case(case2,_,colon2,_)) ->
 682       equal_mcode case1 case2 && equal_mcode colon1 colon2
 683   | (Ast0.OptCase(_),Ast0.OptCase(_)) -> true
 684   | _ -> false
 685
 686 let rec equal_top_level t1 t2 =
 687   match (Ast0.unwrap t1,Ast0.unwrap t2) with
 688     (Ast0.DECL(_),Ast0.DECL(_)) -> true
 689   | (Ast0.FILEINFO(old_file1,new_file1),Ast0.FILEINFO(old_file2,new_file2)) ->
 690       equal_mcode old_file1 old_file2 && equal_mcode new_file1 new_file2
 691   | (Ast0.CODE(_),Ast0.CODE(_)) -> true
 692   | (Ast0.ERRORWORDS(_),Ast0.ERRORWORDS(_)) -> true
 693   | _ -> false
 694
 695 let root_equal e1 e2 =
 696   match (e1,e2) with
 697     (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> dots equal_expression d1 d2
 698   | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
 699       dots equal_parameterTypeDef d1 d2
 700   | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> dots equal_statement d1 d2
 701   | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> dots equal_declaration d1 d2
 702   | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> dots equal_case_line d1 d2
 703   | (Ast0.IdentTag(i1),Ast0.IdentTag(i2)) -> equal_ident i1 i2
 704   | (Ast0.ExprTag(e1),Ast0.ExprTag(e2)) -> equal_expression e1 e2
 705   | (Ast0.ArgExprTag(d),_) -> failwith "not possible - iso only"
 706   | (Ast0.TypeCTag(t1),Ast0.TypeCTag(t2)) -> equal_typeC t1 t2
 707   | (Ast0.ParamTag(p1),Ast0.ParamTag(p2)) -> equal_parameterTypeDef p1 p2
 708   | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> equal_initialiser d1 d2
 709   | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> equal_declaration d1 d2
 710   | (Ast0.StmtTag(s1),Ast0.StmtTag(s2)) -> equal_statement s1 s2
 711   | (Ast0.TopTag(t1),Ast0.TopTag(t2)) -> equal_top_level t1 t2
 712   | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_))
 713   | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_))
 714   | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
 715       failwith "only within iso phase"
 716   | _ -> false
 717
 718 let default_context _ =
 719   Ast0.CONTEXT(ref(Ast.NOTHING,
 720                    Ast0.default_token_info,Ast0.default_token_info))
 721
 722 let traverse minus_table plus_table =
 723   Hashtbl.iter
 724     (function key ->
 725       function (e,l) ->
 726         try
 727           let (plus_e,plus_l) = Hashtbl.find plus_table key in
 728           if root_equal e plus_e &&
 729             List.for_all (function x -> x)
 730               (List.map2 Common.equal_set l plus_l)
 731           then
 732             let i = Ast0.fresh_index() in
 733             (set_index e i; set_index plus_e i;
 734              set_mcodekind e (default_context());
 735              set_mcodekind plus_e (default_context()))
 736         with Not_found -> ())
 737     minus_table
 738
 739 (* --------------------------------------------------------------------- *)
 740 (* contextify the whencode *)
 741
 742 let contextify_all =
 743   let bind x y = () in
 744   let option_default = () in
 745   let mcode x = () in
 746   let do_nothing r k e = Ast0.set_mcodekind e (default_context()); k e in
 747
 748   V0.combiner bind option_default
 749     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 750     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 751     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 752     do_nothing do_nothing do_nothing
 753
 754 let contextify_whencode =
 755   let bind x y = () in
 756   let option_default = () in
 757   let mcode x = () in
 758   let do_nothing r k e = k e in
 759
 760   let expression r k e =
 761     k e;
 762     match Ast0.unwrap e with
 763       Ast0.NestExpr(_,_,_,Some whencode,_)
 764     | Ast0.Edots(_,Some whencode)
 765     | Ast0.Ecircles(_,Some whencode)
 766     | Ast0.Estars(_,Some whencode) ->
 767         contextify_all.V0.combiner_expression whencode
 768     | _ -> () in
 769
 770   let initialiser r k i =
 771     match Ast0.unwrap i with
 772       Ast0.Idots(dots,Some whencode) ->
 773         contextify_all.V0.combiner_initialiser whencode
 774     | _ -> k i in
 775
 776   let whencode = function
 777       Ast0.WhenNot sd -> contextify_all.V0.combiner_statement_dots sd
 778     | Ast0.WhenAlways s -> contextify_all.V0.combiner_statement s
 779     | Ast0.WhenModifier(_) -> ()
 780     | Ast0.WhenNotTrue(e) -> contextify_all.V0.combiner_expression e
 781     | Ast0.WhenNotFalse(e) -> contextify_all.V0.combiner_expression e in
 782
 783   let statement r k (s : Ast0.statement) =
 784     k s;
 785     match Ast0.unwrap s with
 786       Ast0.Nest(_,_,_,whn,_)
 787     | Ast0.Dots(_,whn) | Ast0.Circles(_,whn) | Ast0.Stars(_,whn) ->
 788         List.iter whencode whn
 789     | _ -> () in
 790
 791   let combiner =
 792     V0.combiner bind option_default
 793       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 794       do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 795       do_nothing
 796       expression
 797       do_nothing initialiser do_nothing do_nothing statement do_nothing
 798       do_nothing in
 799   combiner.V0.combiner_top_level
 800
 801 (* --------------------------------------------------------------------- *)
 802
 803 (* the first int list is the tokens in the node, the second is the tokens
 804 in the descendents *)
 805 let minus_table =
 806   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 807 let plus_table =
 808   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 809
 810 let iscode t =
 811   match Ast0.unwrap t with
 812     Ast0.DECL(_) -> true
 813   | Ast0.FILEINFO(_) -> true
 814   | Ast0.ERRORWORDS(_) -> false
 815   | Ast0.CODE(_) -> true
 816   | Ast0.OTHER(_) -> failwith "unexpected top level code"
 817
 818 (* ------------------------------------------------------------------- *)
 819 (* alignment of minus and plus *)
 820
 821 let concat = function
 822     [] -> []
 823   | [s] -> [s]
 824   | l ->
 825       let rec loop = function
 826           [] -> []
 827         | x::rest ->
 828             (match Ast0.unwrap x with
 829               Ast0.DECL(s) -> let stms = loop rest in s::stms
 830             | Ast0.CODE(ss) ->
 831                 let stms = loop rest in
 832                 (match Ast0.unwrap ss with
 833                   Ast0.DOTS(d) -> d@stms
 834                 | _ -> failwith "no dots allowed in pure plus code")
 835             | _ -> failwith "plus code is being discarded") in
 836       let res =
 837         Compute_lines.statement_dots
 838           (Ast0.rewrap (List.hd l) (Ast0.DOTS (loop l))) in
 839       [Ast0.rewrap res (Ast0.CODE res)]
 840
 841 let collect_up_to m plus =
 842   let minfo = Ast0.get_info m in
 843   let mend = minfo.Ast0.logical_end in
 844   let rec loop = function
 845       [] -> ([],[])
 846     | p::plus ->
 847         let pinfo = Ast0.get_info p in
 848         let pstart = pinfo.Ast0.logical_start in
 849         if pstart > mend
 850         then ([],p::plus)
 851         else let (plus,rest) = loop plus in (p::plus,rest) in
 852   let (plus,rest) = loop plus in
 853   (concat plus,rest)
 854
 855 let realign minus plus =
 856   let rec loop = function
 857       ([],_) -> failwith "not possible, some context required"
 858     | ([m],p) -> ([m],concat p)
 859     | (m::minus,plus) ->
 860         let (p,plus) = collect_up_to m plus in
 861         let (minus,plus) = loop (minus,plus) in
 862         (m::minus,p@plus) in
 863   loop (minus,plus)
 864
 865 (* ------------------------------------------------------------------- *)
 866 (* check compatible: check that at the top level the minus and plus code is
 867 of the same kind.  Could go further and make the correspondence between the
 868 code between ...s. *)
 869
 870 let isonly f l = match Ast0.undots l with [s] -> f s | _ -> false
 871
 872 let isall f l = List.for_all (isonly f) l
 873
 874 let rec is_exp s =
 875   match Ast0.unwrap s with
 876     Ast0.Exp(e) -> true
 877   | Ast0.Disj(_,stmts,_,_) -> isall is_exp stmts
 878   | _ -> false
 879
 880 let rec is_ty s =
 881   match Ast0.unwrap s with
 882     Ast0.Ty(e) -> true
 883   | Ast0.Disj(_,stmts,_,_) -> isall is_ty stmts
 884   | _ -> false
 885
 886 let rec is_init s =
 887   match Ast0.unwrap s with
 888     Ast0.TopInit(e) -> true
 889   | Ast0.Disj(_,stmts,_,_) -> isall is_init stmts
 890   | _ -> false
 891
 892 let rec is_decl s =
 893   match Ast0.unwrap s with
 894     Ast0.Decl(_,e) -> true
 895   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 896   | Ast0.Disj(_,stmts,_,_) -> isall is_decl stmts
 897   | _ -> false
 898
 899 let rec is_fndecl s =
 900   match Ast0.unwrap s with
 901     Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 902   | Ast0.Disj(_,stmts,_,_) -> isall is_fndecl stmts
 903   | _ -> false
 904
 905 let rec is_toplevel s =
 906   match Ast0.unwrap s with
 907     Ast0.Decl(_,e) -> true
 908   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 909   | Ast0.Disj(_,stmts,_,_) -> isall is_toplevel stmts
 910   | Ast0.ExprStatement(fc,_) ->
 911       (match Ast0.unwrap fc with
 912         Ast0.FunCall(_,_,_,_) -> true
 913       | _ -> false)
 914   | Ast0.Include(_,_) -> true
 915   | Ast0.Define(_,_,_,_) -> true
 916   | _ -> false
 917
 918 let check_compatible m p =
 919   let fail _ =
 920     failwith
 921       (Printf.sprintf
 922          "incompatible minus and plus code starting on lines %d and %d"
 923          (Ast0.get_line m) (Ast0.get_line p)) in
 924   match (Ast0.unwrap m, Ast0.unwrap p) with
 925     (Ast0.DECL(decl1),Ast0.DECL(decl2)) ->
 926       if not (is_decl decl1 && is_decl decl2)
 927       then fail()
 928   | (Ast0.DECL(decl1),Ast0.CODE(code2)) ->
 929       let v1 = is_decl decl1 in
 930       let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 931       if !Flag.make_hrule = None && v1 && not v2 then fail()
 932   | (Ast0.CODE(code1),Ast0.DECL(decl2)) ->
 933       let v1 = List.for_all is_toplevel (Ast0.undots code1) in
 934       let v2 = is_decl decl2 in
 935       if v1 && not v2 then fail()
 936   | (Ast0.CODE(code1),Ast0.CODE(code2)) ->
 937       let v1 = isonly is_init code1 in
 938       let v2a = isonly is_init code2 in
 939       let v2b = isonly is_exp code2 in
 940       if v1
 941       then (if not (v2a || v2b) then fail())
 942       else
 943         let testers = [is_exp;is_ty] in
 944         List.iter
 945           (function tester ->
 946             let v1 = isonly tester code1 in
 947             let v2 = isonly tester code2 in
 948             if (v1 && not v2) or (!Flag.make_hrule = None && v2 && not v1)
 949             then fail())
 950           testers;
 951         let v1 = isonly is_fndecl code1 in
 952         let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 953         if !Flag.make_hrule = None && v1 && not v2 then fail()
 954   | (Ast0.FILEINFO(_,_),Ast0.FILEINFO(_,_)) -> ()
 955   | (Ast0.OTHER(_),Ast0.OTHER(_)) -> ()
 956   | _ -> fail()
 957
 958 (* ------------------------------------------------------------------- *)
 959
 960 (* returns a list of corresponding minus and plus trees *)
 961 let context_neg minus plus =
 962   Hashtbl.clear minus_table;
 963   Hashtbl.clear plus_table;
 964   List.iter contextify_whencode minus;
 965   let (minus,plus) = realign minus plus in
 966   let rec loop = function
 967       ([],[]) -> []
 968     | ([],l) ->
 969         failwith (Printf.sprintf "%d plus things remaining" (List.length l))
 970     | (minus,[]) ->
 971         plus_lines := [];
 972         let _ =
 973           List.map
 974             (function m ->
 975               classify true
 976                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
 977                 minus_table m)
 978             minus in
 979         []
 980     | (((m::minus) as mall),((p::plus) as pall)) ->
 981         let minfo = Ast0.get_info m in
 982         let pinfo = Ast0.get_info p in
 983         let mstart = minfo.Ast0.logical_start in
 984         let mend = minfo.Ast0.logical_end in
 985         let pstart = pinfo.Ast0.logical_start in
 986         let pend = pinfo.Ast0.logical_end in
 987         if (iscode m or iscode p) &&
 988           (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
 989            (mstart <= pstart && mend >= pstart) or
 990            (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
 991         then
 992           begin
 993             (* ensure that the root of each tree has a unique index,
 994                although it might get overwritten if the node is a context
 995                node *)
 996             let i = Ast0.fresh_index() in
 997             Ast0.set_index m i; Ast0.set_index p i;
 998             check_compatible m p;
 999             collect_plus_lines p;
1000             let _ =
1001               classify true
1002                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
1003                 minus_table m in
1004             let _ = classify false (function _ -> Ast0.PLUS) plus_table p in
1005             traverse minus_table plus_table;
1006             (m,p)::loop(minus,plus)
1007           end
1008         else
1009           if not(iscode m or iscode p)
1010           then loop(minus,plus)
1011           else
1012             if mstart < pstart
1013             then
1014               begin
1015                 plus_lines := [];
1016                 let _ =
1017                   classify true
1018                     (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
1019                     minus_table m in
1020                 loop(minus,pall)
1021               end
1022             else loop(mall,plus) in
1023   loop(minus,plus)