parsing_cocci/context_neg.ml

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