parsing_cocci/.#context_neg.ml.1.103

   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_initialiser i1 i2 =
 553   match (Ast0.unwrap i1,Ast0.unwrap i2) with
 554     (Ast0.InitExpr(_),Ast0.InitExpr(_)) -> true
 555   | (Ast0.InitList(lb1,_,rb1),Ast0.InitList(lb2,_,rb2)) ->
 556       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
 557   | (Ast0.InitGccDotName(dot1,_,eq1,_),Ast0.InitGccDotName(dot2,_,eq2,_)) ->
 558       (equal_mcode dot1 dot2) && (equal_mcode eq1 eq2)
 559   | (Ast0.InitGccName(_,eq1,_),Ast0.InitGccName(_,eq2,_)) ->
 560       equal_mcode eq1 eq2
 561   | (Ast0.InitGccIndex(lb1,_,rb1,eq1,_),Ast0.InitGccIndex(lb2,_,rb2,eq2,_)) ->
 562       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2) && (equal_mcode eq1 eq2)
 563   | (Ast0.InitGccRange(lb1,_,dots1,_,rb1,eq1,_),
 564      Ast0.InitGccRange(lb2,_,dots2,_,rb2,eq2,_)) ->
 565       (equal_mcode lb1 lb2) && (equal_mcode dots1 dots2) &&
 566        (equal_mcode rb1 rb2) && (equal_mcode eq1 eq2)
 567  | (Ast0.IComma(cm1),Ast0.IComma(cm2)) -> equal_mcode cm1 cm2
 568   | (Ast0.Idots(d1,_),Ast0.Idots(d2,_)) -> equal_mcode d1 d2
 569   | (Ast0.OptIni(_),Ast0.OptIni(_)) -> true
 570   | (Ast0.UniqueIni(_),Ast0.UniqueIni(_)) -> true
 571   | _ -> false
 572
 573 let equal_parameterTypeDef p1 p2 =
 574   match (Ast0.unwrap p1,Ast0.unwrap p2) with
 575     (Ast0.VoidParam(_),Ast0.VoidParam(_)) -> true
 576   | (Ast0.Param(_,_),Ast0.Param(_,_)) -> true
 577   | (Ast0.MetaParam(name1,_),Ast0.MetaParam(name2,_))
 578   | (Ast0.MetaParamList(name1,_,_),Ast0.MetaParamList(name2,_,_)) ->
 579       equal_mcode name1 name2
 580   | (Ast0.PComma(cm1),Ast0.PComma(cm2)) -> equal_mcode cm1 cm2
 581   | (Ast0.Pdots(dots1),Ast0.Pdots(dots2))
 582   | (Ast0.Pcircles(dots1),Ast0.Pcircles(dots2)) -> equal_mcode dots1 dots2
 583   | (Ast0.OptParam(_),Ast0.OptParam(_)) -> true
 584   | (Ast0.UniqueParam(_),Ast0.UniqueParam(_)) -> true
 585   | _ -> false
 586
 587 let rec equal_statement s1 s2 =
 588   match (Ast0.unwrap s1,Ast0.unwrap s2) with
 589     (Ast0.FunDecl(_,fninfo1,_,lp1,_,rp1,lbrace1,_,rbrace1),
 590      Ast0.FunDecl(_,fninfo2,_,lp2,_,rp2,lbrace2,_,rbrace2)) ->
 591        (List.length fninfo1) = (List.length fninfo2) &&
 592        List.for_all2 equal_fninfo fninfo1 fninfo2 &&
 593        equal_mcode lp1 lp2 && equal_mcode rp1 rp2 &&
 594        equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 595   | (Ast0.Decl(_,_),Ast0.Decl(_,_)) -> true
 596   | (Ast0.Seq(lbrace1,_,rbrace1),Ast0.Seq(lbrace2,_,rbrace2)) ->
 597       equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 598   | (Ast0.ExprStatement(_,sem1),Ast0.ExprStatement(_,sem2)) ->
 599       equal_mcode sem1 sem2
 600   | (Ast0.IfThen(iff1,lp1,_,rp1,_,_),Ast0.IfThen(iff2,lp2,_,rp2,_,_)) ->
 601       equal_mcode iff1 iff2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 602   | (Ast0.IfThenElse(iff1,lp1,_,rp1,_,els1,_,_),
 603      Ast0.IfThenElse(iff2,lp2,_,rp2,_,els2,_,_)) ->
 604        equal_mcode iff1 iff2 &&
 605          equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode els1 els2
 606   | (Ast0.While(whl1,lp1,_,rp1,_,_),Ast0.While(whl2,lp2,_,rp2,_,_)) ->
 607       equal_mcode whl1 whl2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 608   | (Ast0.Do(d1,_,whl1,lp1,_,rp1,sem1),Ast0.Do(d2,_,whl2,lp2,_,rp2,sem2)) ->
 609       equal_mcode whl1 whl2 && equal_mcode d1 d2 &&
 610       equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
 611   | (Ast0.For(fr1,lp1,_,sem11,_,sem21,_,rp1,_,_),
 612      Ast0.For(fr2,lp2,_,sem12,_,sem22,_,rp2,_,_)) ->
 613        equal_mcode fr1 fr2 && equal_mcode lp1 lp2 &&
 614        equal_mcode sem11 sem12 && equal_mcode sem21 sem22 &&
 615        equal_mcode rp1 rp2
 616   | (Ast0.Iterator(nm1,lp1,_,rp1,_,_),Ast0.Iterator(nm2,lp2,_,rp2,_,_)) ->
 617       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 618   | (Ast0.Switch(switch1,lp1,_,rp1,lb1,case1,rb1),
 619      Ast0.Switch(switch2,lp2,_,rp2,lb2,case2,rb2)) ->
 620        equal_mcode switch1 switch2 && equal_mcode lp1 lp2 &&
 621        equal_mcode rp1 rp2 && equal_mcode lb1 lb2 &&
 622        equal_mcode rb1 rb2
 623   | (Ast0.Break(br1,sem1),Ast0.Break(br2,sem2)) ->
 624       equal_mcode br1 br2 && equal_mcode sem1 sem2
 625   | (Ast0.Continue(cont1,sem1),Ast0.Continue(cont2,sem2)) ->
 626       equal_mcode cont1 cont2 && equal_mcode sem1 sem2
 627   | (Ast0.Label(_,dd1),Ast0.Label(_,dd2)) ->
 628       equal_mcode dd1 dd2
 629   | (Ast0.Goto(g1,_,sem1),Ast0.Goto(g2,_,sem2)) ->
 630       equal_mcode g1 g2 && equal_mcode sem1 sem2
 631   | (Ast0.Return(ret1,sem1),Ast0.Return(ret2,sem2)) ->
 632       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 633   | (Ast0.ReturnExpr(ret1,_,sem1),Ast0.ReturnExpr(ret2,_,sem2)) ->
 634       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 635   | (Ast0.MetaStmt(name1,_),Ast0.MetaStmt(name2,_))
 636   | (Ast0.MetaStmtList(name1,_),Ast0.MetaStmtList(name2,_)) ->
 637       equal_mcode name1 name2
 638   | (Ast0.Disj(starter1,_,mids1,ender1),Ast0.Disj(starter2,_,mids2,ender2)) ->
 639       equal_mcode starter1 starter2 &&
 640       List.for_all2 equal_mcode mids1 mids2 &&
 641       equal_mcode ender1 ender2
 642   | (Ast0.Nest(starter1,_,ender1,_,m1),Ast0.Nest(starter2,_,ender2,_,m2)) ->
 643       equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
 644   | (Ast0.Exp(_),Ast0.Exp(_)) -> true
 645   | (Ast0.TopExp(_),Ast0.TopExp(_)) -> true
 646   | (Ast0.Ty(_),Ast0.Ty(_)) -> true
 647   | (Ast0.TopInit(_),Ast0.TopInit(_)) -> true
 648   | (Ast0.Dots(d1,_),Ast0.Dots(d2,_))
 649   | (Ast0.Circles(d1,_),Ast0.Circles(d2,_))
 650   | (Ast0.Stars(d1,_),Ast0.Stars(d2,_)) -> equal_mcode d1 d2
 651   | (Ast0.Include(inc1,name1),Ast0.Include(inc2,name2)) ->
 652       equal_mcode inc1 inc2 && equal_mcode name1 name2
 653   | (Ast0.Define(def1,_,_,_),Ast0.Define(def2,_,_,_)) ->
 654       equal_mcode def1 def2
 655   | (Ast0.OptStm(_),Ast0.OptStm(_)) -> true
 656   | (Ast0.UniqueStm(_),Ast0.UniqueStm(_)) -> true
 657   | _ -> false
 658
 659 and equal_fninfo x y =
 660   match (x,y) with
 661     (Ast0.FStorage(s1),Ast0.FStorage(s2)) -> equal_mcode s1 s2
 662   | (Ast0.FType(_),Ast0.FType(_)) -> true
 663   | (Ast0.FInline(i1),Ast0.FInline(i2)) -> equal_mcode i1 i2
 664   | (Ast0.FAttr(i1),Ast0.FAttr(i2)) -> equal_mcode i1 i2
 665   | _ -> false
 666
 667 let equal_case_line c1 c2 =
 668   match (Ast0.unwrap c1,Ast0.unwrap c2) with
 669     (Ast0.Default(def1,colon1,_),Ast0.Default(def2,colon2,_)) ->
 670       equal_mcode def1 def2 && equal_mcode colon1 colon2
 671   | (Ast0.Case(case1,_,colon1,_),Ast0.Case(case2,_,colon2,_)) ->
 672       equal_mcode case1 case2 && equal_mcode colon1 colon2
 673   | (Ast0.OptCase(_),Ast0.OptCase(_)) -> true
 674   | _ -> false
 675
 676 let rec equal_top_level t1 t2 =
 677   match (Ast0.unwrap t1,Ast0.unwrap t2) with
 678     (Ast0.DECL(_),Ast0.DECL(_)) -> true
 679   | (Ast0.FILEINFO(old_file1,new_file1),Ast0.FILEINFO(old_file2,new_file2)) ->
 680       equal_mcode old_file1 old_file2 && equal_mcode new_file1 new_file2
 681   | (Ast0.CODE(_),Ast0.CODE(_)) -> true
 682   | (Ast0.ERRORWORDS(_),Ast0.ERRORWORDS(_)) -> true
 683   | _ -> false
 684
 685 let root_equal e1 e2 =
 686   match (e1,e2) with
 687     (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> dots equal_expression d1 d2
 688   | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
 689       dots equal_parameterTypeDef d1 d2
 690   | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> dots equal_statement d1 d2
 691   | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> dots equal_declaration d1 d2
 692   | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> dots equal_case_line d1 d2
 693   | (Ast0.IdentTag(i1),Ast0.IdentTag(i2)) -> equal_ident i1 i2
 694   | (Ast0.ExprTag(e1),Ast0.ExprTag(e2)) -> equal_expression e1 e2
 695   | (Ast0.ArgExprTag(d),_) -> failwith "not possible - iso only"
 696   | (Ast0.TypeCTag(t1),Ast0.TypeCTag(t2)) -> equal_typeC t1 t2
 697   | (Ast0.ParamTag(p1),Ast0.ParamTag(p2)) -> equal_parameterTypeDef p1 p2
 698   | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> equal_initialiser d1 d2
 699   | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> equal_declaration d1 d2
 700   | (Ast0.StmtTag(s1),Ast0.StmtTag(s2)) -> equal_statement s1 s2
 701   | (Ast0.TopTag(t1),Ast0.TopTag(t2)) -> equal_top_level t1 t2
 702   | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_))
 703   | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_))
 704   | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
 705       failwith "only within iso phase"
 706   | _ -> false
 707
 708 let default_context _ =
 709   Ast0.CONTEXT(ref(Ast.NOTHING,
 710                    Ast0.default_token_info,Ast0.default_token_info))
 711
 712 let traverse minus_table plus_table =
 713   Hashtbl.iter
 714     (function key ->
 715       function (e,l) ->
 716         try
 717           let (plus_e,plus_l) = Hashtbl.find plus_table key in
 718           if root_equal e plus_e &&
 719             List.for_all (function x -> x)
 720               (List.map2 Common.equal_set l plus_l)
 721           then
 722             let i = Ast0.fresh_index() in
 723             (set_index e i; set_index plus_e i;
 724              set_mcodekind e (default_context());
 725              set_mcodekind plus_e (default_context()))
 726         with Not_found -> ())
 727     minus_table
 728
 729 (* --------------------------------------------------------------------- *)
 730 (* contextify the whencode *)
 731
 732 let contextify_all =
 733   let bind x y = () in
 734   let option_default = () in
 735   let mcode x = () in
 736   let do_nothing r k e = Ast0.set_mcodekind e (default_context()); k e in
 737
 738   V0.combiner bind option_default
 739     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 740     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 741     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 742     do_nothing do_nothing do_nothing
 743
 744 let contextify_whencode =
 745   let bind x y = () in
 746   let option_default = () in
 747   let mcode x = () in
 748   let do_nothing r k e = k e in
 749
 750   let expression r k e =
 751     k e;
 752     match Ast0.unwrap e with
 753       Ast0.NestExpr(_,_,_,Some whencode,_)
 754     | Ast0.Edots(_,Some whencode)
 755     | Ast0.Ecircles(_,Some whencode)
 756     | Ast0.Estars(_,Some whencode) ->
 757         contextify_all.V0.combiner_expression whencode
 758     | _ -> () in
 759
 760   let initialiser r k i =
 761     match Ast0.unwrap i with
 762       Ast0.Idots(dots,Some whencode) ->
 763         contextify_all.V0.combiner_initialiser whencode
 764     | _ -> k i in
 765
 766   let whencode = function
 767       Ast0.WhenNot sd -> contextify_all.V0.combiner_statement_dots sd
 768     | Ast0.WhenAlways s -> contextify_all.V0.combiner_statement s
 769     | Ast0.WhenModifier(_) -> ()
 770     | Ast0.WhenNotTrue(e) -> contextify_all.V0.combiner_expression e
 771     | Ast0.WhenNotFalse(e) -> contextify_all.V0.combiner_expression e in
 772
 773   let statement r k (s : Ast0.statement) =
 774     k s;
 775     match Ast0.unwrap s with
 776       Ast0.Nest(_,_,_,whn,_)
 777     | Ast0.Dots(_,whn) | Ast0.Circles(_,whn) | Ast0.Stars(_,whn) ->
 778         List.iter whencode whn
 779     | _ -> () in
 780
 781   let combiner =
 782     V0.combiner bind option_default
 783       mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 784       do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 785       do_nothing
 786       expression
 787       do_nothing initialiser do_nothing do_nothing statement do_nothing
 788       do_nothing in
 789   combiner.V0.combiner_top_level
 790
 791 (* --------------------------------------------------------------------- *)
 792
 793 (* the first int list is the tokens in the node, the second is the tokens
 794 in the descendents *)
 795 let minus_table =
 796   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 797 let plus_table =
 798   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 799
 800 let iscode t =
 801   match Ast0.unwrap t with
 802     Ast0.DECL(_) -> true
 803   | Ast0.FILEINFO(_) -> true
 804   | Ast0.ERRORWORDS(_) -> false
 805   | Ast0.CODE(_) -> true
 806   | Ast0.OTHER(_) -> failwith "unexpected top level code"
 807
 808 (* ------------------------------------------------------------------- *)
 809 (* alignment of minus and plus *)
 810
 811 let concat = function
 812     [] -> []
 813   | [s] -> [s]
 814   | l ->
 815       let rec loop = function
 816           [] -> []
 817         | x::rest ->
 818             (match Ast0.unwrap x with
 819               Ast0.DECL(s) -> let stms = loop rest in s::stms
 820             | Ast0.CODE(ss) ->
 821                 let stms = loop rest in
 822                 (match Ast0.unwrap ss with
 823                   Ast0.DOTS(d) -> d@stms
 824                 | _ -> failwith "no dots allowed in pure plus code")
 825             | _ -> failwith "plus code is being discarded") in
 826       let res =
 827         Compute_lines.statement_dots
 828           (Ast0.rewrap (List.hd l) (Ast0.DOTS (loop l))) in
 829       [Ast0.rewrap res (Ast0.CODE res)]
 830
 831 let collect_up_to m plus =
 832   let minfo = Ast0.get_info m in
 833   let mend = minfo.Ast0.logical_end in
 834   let rec loop = function
 835       [] -> ([],[])
 836     | p::plus ->
 837         let pinfo = Ast0.get_info p in
 838         let pstart = pinfo.Ast0.logical_start in
 839         if pstart > mend
 840         then ([],p::plus)
 841         else let (plus,rest) = loop plus in (p::plus,rest) in
 842   let (plus,rest) = loop plus in
 843   (concat plus,rest)
 844
 845 let realign minus plus =
 846   let rec loop = function
 847       ([],_) -> failwith "not possible, some context required"
 848     | ([m],p) -> ([m],concat p)
 849     | (m::minus,plus) ->
 850         let (p,plus) = collect_up_to m plus in
 851         let (minus,plus) = loop (minus,plus) in
 852         (m::minus,p@plus) in
 853   loop (minus,plus)
 854
 855 (* ------------------------------------------------------------------- *)
 856 (* check compatible: check that at the top level the minus and plus code is
 857 of the same kind.  Could go further and make the correspondence between the
 858 code between ...s. *)
 859
 860 let isonly f l = match Ast0.undots l with [s] -> f s | _ -> false
 861
 862 let isall f l = List.for_all (isonly f) l
 863
 864 let rec is_exp s =
 865   match Ast0.unwrap s with
 866     Ast0.Exp(e) -> true
 867   | Ast0.Disj(_,stmts,_,_) -> isall is_exp stmts
 868   | _ -> false
 869
 870 let rec is_ty s =
 871   match Ast0.unwrap s with
 872     Ast0.Ty(e) -> true
 873   | Ast0.Disj(_,stmts,_,_) -> isall is_ty stmts
 874   | _ -> false
 875
 876 let rec is_init s =
 877   match Ast0.unwrap s with
 878     Ast0.TopInit(e) -> true
 879   | Ast0.Disj(_,stmts,_,_) -> isall is_init stmts
 880   | _ -> false
 881
 882 let rec is_decl s =
 883   match Ast0.unwrap s with
 884     Ast0.Decl(_,e) -> true
 885   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 886   | Ast0.Disj(_,stmts,_,_) -> isall is_decl stmts
 887   | _ -> false
 888
 889 let rec is_fndecl s =
 890   match Ast0.unwrap s with
 891     Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 892   | Ast0.Disj(_,stmts,_,_) -> isall is_fndecl stmts
 893   | _ -> false
 894
 895 let rec is_toplevel s =
 896   match Ast0.unwrap s with
 897     Ast0.Decl(_,e) -> true
 898   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 899   | Ast0.Disj(_,stmts,_,_) -> isall is_toplevel stmts
 900   | Ast0.ExprStatement(fc,_) ->
 901       (match Ast0.unwrap fc with
 902         Ast0.FunCall(_,_,_,_) -> true
 903       | _ -> false)
 904   | Ast0.Include(_,_) -> true
 905   | Ast0.Define(_,_,_,_) -> true
 906   | _ -> false
 907
 908 let check_compatible m p =
 909   let fail _ =
 910     failwith
 911       (Printf.sprintf
 912          "incompatible minus and plus code starting on lines %d and %d"
 913          (Ast0.get_line m) (Ast0.get_line p)) in
 914   match (Ast0.unwrap m, Ast0.unwrap p) with
 915     (Ast0.DECL(decl1),Ast0.DECL(decl2)) ->
 916       if not (is_decl decl1 && is_decl decl2)
 917       then fail()
 918   | (Ast0.DECL(decl1),Ast0.CODE(code2)) ->
 919       let v1 = is_decl decl1 in
 920       let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 921       if !Flag.make_hrule = None && v1 && not v2 then fail()
 922   | (Ast0.CODE(code1),Ast0.DECL(decl2)) ->
 923       let v1 = List.for_all is_toplevel (Ast0.undots code1) in
 924       let v2 = is_decl decl2 in
 925       if v1 && not v2 then fail()
 926   | (Ast0.CODE(code1),Ast0.CODE(code2)) ->
 927       let v1 = isonly is_init code1 in
 928       let v2a = isonly is_init code2 in
 929       let v2b = isonly is_exp code2 in
 930       if v1
 931       then (if not (v2a || v2b) then fail())
 932       else
 933         let testers = [is_exp;is_ty] in
 934         List.iter
 935           (function tester ->
 936             let v1 = isonly tester code1 in
 937             let v2 = isonly tester code2 in
 938             if (v1 && not v2) or (!Flag.make_hrule = None && v2 && not v1)
 939             then fail())
 940           testers;
 941         let v1 = isonly is_fndecl code1 in
 942         let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 943         if !Flag.make_hrule = None && v1 && not v2 then fail()
 944   | (Ast0.FILEINFO(_,_),Ast0.FILEINFO(_,_)) -> ()
 945   | (Ast0.OTHER(_),Ast0.OTHER(_)) -> ()
 946   | _ -> fail()
 947
 948 (* ------------------------------------------------------------------- *)
 949
 950 (* returns a list of corresponding minus and plus trees *)
 951 let context_neg minus plus =
 952   Hashtbl.clear minus_table;
 953   Hashtbl.clear plus_table;
 954   List.iter contextify_whencode minus;
 955   let (minus,plus) = realign minus plus in
 956   let rec loop = function
 957       ([],[]) -> []
 958     | ([],l) ->
 959         failwith (Printf.sprintf "%d plus things remaining" (List.length l))
 960     | (minus,[]) ->
 961         plus_lines := [];
 962         let _ =
 963           List.map
 964             (function m ->
 965               classify true
 966                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
 967                 minus_table m)
 968             minus in
 969         []
 970     | (((m::minus) as mall),((p::plus) as pall)) ->
 971         let minfo = Ast0.get_info m in
 972         let pinfo = Ast0.get_info p in
 973         let mstart = minfo.Ast0.logical_start in
 974         let mend = minfo.Ast0.logical_end in
 975         let pstart = pinfo.Ast0.logical_start in
 976         let pend = pinfo.Ast0.logical_end in
 977         if (iscode m or iscode p) &&
 978           (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
 979            (mstart <= pstart && mend >= pstart) or
 980            (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
 981         then
 982           begin
 983             (* ensure that the root of each tree has a unique index,
 984                although it might get overwritten if the node is a context
 985                node *)
 986             let i = Ast0.fresh_index() in
 987             Ast0.set_index m i; Ast0.set_index p i;
 988             check_compatible m p;
 989             collect_plus_lines p;
 990             let _ =
 991               classify true
 992                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
 993                 minus_table m in
 994             let _ = classify false (function _ -> Ast0.PLUS) plus_table p in
 995             traverse minus_table plus_table;
 996             (m,p)::loop(minus,plus)
 997           end
 998         else
 999           if not(iscode m or iscode p)
1000           then loop(minus,plus)
1001           else
1002             if mstart < pstart
1003             then
1004               begin
1005                 plus_lines := [];
1006                 let _ =
1007                   classify true
1008                     (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
1009                     minus_table m in
1010                 loop(minus,pall)
1011               end
1012             else loop(mall,plus) in
1013   loop(minus,plus)