parsing_cocci/.#context_neg.ml.1.96

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