parsing_cocci/context_neg.ml

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