parsing_cocci/context_neg.ml

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