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