parsing_cocci/.#context_neg.ml.1.95

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