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.Init(stg1,_,_,eq1,_,sem1),Ast0.Init(stg2,_,_,eq2,_,sem2)) ->
 542       equal_option stg1 stg2 && equal_mcode eq1 eq2 && equal_mcode sem1 sem2
 543   | (Ast0.UnInit(stg1,_,_,sem1),Ast0.UnInit(stg2,_,_,sem2)) ->
 544       equal_option stg1 stg2 && equal_mcode sem1 sem2
 545   | (Ast0.MacroDecl(nm1,lp1,_,rp1,sem1),Ast0.MacroDecl(nm2,lp2,_,rp2,sem2)) ->
 546       equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
 547   | (Ast0.TyDecl(_,sem1),Ast0.TyDecl(_,sem2)) -> equal_mcode sem1 sem2
 548   | (Ast0.Ddots(dots1,_),Ast0.Ddots(dots2,_)) -> equal_mcode dots1 dots2
 549   | (Ast0.OptDecl(_),Ast0.OptDecl(_)) -> true
 550   | (Ast0.UniqueDecl(_),Ast0.UniqueDecl(_)) -> true
 551   | (Ast0.DisjDecl _,_) | (_,Ast0.DisjDecl _) ->
 552       failwith "DisjDecl not expected here"
 553   | _ -> false
 554
 555 let equal_designator d1 d2 =
 556   match (d1,d2) with
 557     (Ast0.DesignatorField(dot1,_),Ast0.DesignatorField(dot2,_)) ->
 558       equal_mcode dot1 dot2
 559   | (Ast0.DesignatorIndex(lb1,_,rb1),Ast0.DesignatorIndex(lb2,_,rb2)) ->
 560       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
 561   | (Ast0.DesignatorRange(lb1,_,dots1,_,rb1),
 562      Ast0.DesignatorRange(lb2,_,dots2,_,rb2)) ->
 563        (equal_mcode lb1 lb2) && (equal_mcode dots1 dots2) &&
 564        (equal_mcode rb1 rb2)
 565   | _ -> false
 566
 567 let equal_initialiser i1 i2 =
 568   match (Ast0.unwrap i1,Ast0.unwrap i2) with
 569     (Ast0.MetaInit(name1,_),Ast0.MetaInit(name2,_)) ->
 570       equal_mcode name1 name2
 571   | (Ast0.InitExpr(_),Ast0.InitExpr(_)) -> true
 572   | (Ast0.InitList(lb1,_,rb1),Ast0.InitList(lb2,_,rb2)) ->
 573       (equal_mcode lb1 lb2) && (equal_mcode rb1 rb2)
 574   | (Ast0.InitGccExt(designators1,eq1,_),
 575      Ast0.InitGccExt(designators2,eq2,_)) ->
 576        (List.for_all2 equal_designator designators1 designators2) &&
 577        (equal_mcode eq1 eq2)
 578   | (Ast0.InitGccName(_,eq1,_),Ast0.InitGccName(_,eq2,_)) ->
 579       equal_mcode eq1 eq2
 580   | (Ast0.IComma(cm1),Ast0.IComma(cm2)) -> equal_mcode cm1 cm2
 581   | (Ast0.Idots(d1,_),Ast0.Idots(d2,_)) -> equal_mcode d1 d2
 582   | (Ast0.OptIni(_),Ast0.OptIni(_)) -> true
 583   | (Ast0.UniqueIni(_),Ast0.UniqueIni(_)) -> true
 584   | _ -> false
 585
 586 let equal_parameterTypeDef p1 p2 =
 587   match (Ast0.unwrap p1,Ast0.unwrap p2) with
 588     (Ast0.VoidParam(_),Ast0.VoidParam(_)) -> true
 589   | (Ast0.Param(_,_),Ast0.Param(_,_)) -> true
 590   | (Ast0.MetaParam(name1,_),Ast0.MetaParam(name2,_))
 591   | (Ast0.MetaParamList(name1,_,_),Ast0.MetaParamList(name2,_,_)) ->
 592       equal_mcode name1 name2
 593   | (Ast0.PComma(cm1),Ast0.PComma(cm2)) -> equal_mcode cm1 cm2
 594   | (Ast0.Pdots(dots1),Ast0.Pdots(dots2))
 595   | (Ast0.Pcircles(dots1),Ast0.Pcircles(dots2)) -> equal_mcode dots1 dots2
 596   | (Ast0.OptParam(_),Ast0.OptParam(_)) -> true
 597   | (Ast0.UniqueParam(_),Ast0.UniqueParam(_)) -> true
 598   | _ -> false
 599
 600 let rec equal_statement s1 s2 =
 601   match (Ast0.unwrap s1,Ast0.unwrap s2) with
 602     (Ast0.FunDecl(_,fninfo1,_,lp1,_,rp1,lbrace1,_,rbrace1),
 603      Ast0.FunDecl(_,fninfo2,_,lp2,_,rp2,lbrace2,_,rbrace2)) ->
 604        (List.length fninfo1) = (List.length fninfo2) &&
 605        List.for_all2 equal_fninfo fninfo1 fninfo2 &&
 606        equal_mcode lp1 lp2 && equal_mcode rp1 rp2 &&
 607        equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 608   | (Ast0.Decl(_,_),Ast0.Decl(_,_)) -> true
 609   | (Ast0.Seq(lbrace1,_,rbrace1),Ast0.Seq(lbrace2,_,rbrace2)) ->
 610       equal_mcode lbrace1 lbrace2 && equal_mcode rbrace1 rbrace2
 611   | (Ast0.ExprStatement(_,sem1),Ast0.ExprStatement(_,sem2)) ->
 612       equal_mcode sem1 sem2
 613   | (Ast0.IfThen(iff1,lp1,_,rp1,_,_),Ast0.IfThen(iff2,lp2,_,rp2,_,_)) ->
 614       equal_mcode iff1 iff2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 615   | (Ast0.IfThenElse(iff1,lp1,_,rp1,_,els1,_,_),
 616      Ast0.IfThenElse(iff2,lp2,_,rp2,_,els2,_,_)) ->
 617        equal_mcode iff1 iff2 &&
 618          equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode els1 els2
 619   | (Ast0.While(whl1,lp1,_,rp1,_,_),Ast0.While(whl2,lp2,_,rp2,_,_)) ->
 620       equal_mcode whl1 whl2 && equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 621   | (Ast0.Do(d1,_,whl1,lp1,_,rp1,sem1),Ast0.Do(d2,_,whl2,lp2,_,rp2,sem2)) ->
 622       equal_mcode whl1 whl2 && equal_mcode d1 d2 &&
 623       equal_mcode lp1 lp2 && equal_mcode rp1 rp2 && equal_mcode sem1 sem2
 624   | (Ast0.For(fr1,lp1,_,sem11,_,sem21,_,rp1,_,_),
 625      Ast0.For(fr2,lp2,_,sem12,_,sem22,_,rp2,_,_)) ->
 626        equal_mcode fr1 fr2 && equal_mcode lp1 lp2 &&
 627        equal_mcode sem11 sem12 && equal_mcode sem21 sem22 &&
 628        equal_mcode rp1 rp2
 629   | (Ast0.Iterator(nm1,lp1,_,rp1,_,_),Ast0.Iterator(nm2,lp2,_,rp2,_,_)) ->
 630       equal_mcode lp1 lp2 && equal_mcode rp1 rp2
 631   | (Ast0.Switch(switch1,lp1,_,rp1,lb1,_,_,rb1),
 632      Ast0.Switch(switch2,lp2,_,rp2,lb2,_,_,rb2)) ->
 633        equal_mcode switch1 switch2 && equal_mcode lp1 lp2 &&
 634        equal_mcode rp1 rp2 && equal_mcode lb1 lb2 &&
 635        equal_mcode rb1 rb2
 636   | (Ast0.Break(br1,sem1),Ast0.Break(br2,sem2)) ->
 637       equal_mcode br1 br2 && equal_mcode sem1 sem2
 638   | (Ast0.Continue(cont1,sem1),Ast0.Continue(cont2,sem2)) ->
 639       equal_mcode cont1 cont2 && equal_mcode sem1 sem2
 640   | (Ast0.Label(_,dd1),Ast0.Label(_,dd2)) ->
 641       equal_mcode dd1 dd2
 642   | (Ast0.Goto(g1,_,sem1),Ast0.Goto(g2,_,sem2)) ->
 643       equal_mcode g1 g2 && equal_mcode sem1 sem2
 644   | (Ast0.Return(ret1,sem1),Ast0.Return(ret2,sem2)) ->
 645       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 646   | (Ast0.ReturnExpr(ret1,_,sem1),Ast0.ReturnExpr(ret2,_,sem2)) ->
 647       equal_mcode ret1 ret2 && equal_mcode sem1 sem2
 648   | (Ast0.MetaStmt(name1,_),Ast0.MetaStmt(name2,_))
 649   | (Ast0.MetaStmtList(name1,_),Ast0.MetaStmtList(name2,_)) ->
 650       equal_mcode name1 name2
 651   | (Ast0.Disj(starter1,_,mids1,ender1),Ast0.Disj(starter2,_,mids2,ender2)) ->
 652       equal_mcode starter1 starter2 &&
 653       List.for_all2 equal_mcode mids1 mids2 &&
 654       equal_mcode ender1 ender2
 655   | (Ast0.Nest(starter1,_,ender1,_,m1),Ast0.Nest(starter2,_,ender2,_,m2)) ->
 656       equal_mcode starter1 starter2 && equal_mcode ender1 ender2 && m1 = m2
 657   | (Ast0.Exp(_),Ast0.Exp(_)) -> true
 658   | (Ast0.TopExp(_),Ast0.TopExp(_)) -> true
 659   | (Ast0.Ty(_),Ast0.Ty(_)) -> true
 660   | (Ast0.TopInit(_),Ast0.TopInit(_)) -> true
 661   | (Ast0.Dots(d1,_),Ast0.Dots(d2,_))
 662   | (Ast0.Circles(d1,_),Ast0.Circles(d2,_))
 663   | (Ast0.Stars(d1,_),Ast0.Stars(d2,_)) -> equal_mcode d1 d2
 664   | (Ast0.Include(inc1,name1),Ast0.Include(inc2,name2)) ->
 665       equal_mcode inc1 inc2 && equal_mcode name1 name2
 666   | (Ast0.Define(def1,_,_,_),Ast0.Define(def2,_,_,_)) ->
 667       equal_mcode def1 def2
 668   | (Ast0.OptStm(_),Ast0.OptStm(_)) -> true
 669   | (Ast0.UniqueStm(_),Ast0.UniqueStm(_)) -> true
 670   | _ -> false
 671
 672 and equal_fninfo x y =
 673   match (x,y) with
 674     (Ast0.FStorage(s1),Ast0.FStorage(s2)) -> equal_mcode s1 s2
 675   | (Ast0.FType(_),Ast0.FType(_)) -> true
 676   | (Ast0.FInline(i1),Ast0.FInline(i2)) -> equal_mcode i1 i2
 677   | (Ast0.FAttr(i1),Ast0.FAttr(i2)) -> equal_mcode i1 i2
 678   | _ -> false
 679
 680 let equal_case_line c1 c2 =
 681   match (Ast0.unwrap c1,Ast0.unwrap c2) with
 682     (Ast0.Default(def1,colon1,_),Ast0.Default(def2,colon2,_)) ->
 683       equal_mcode def1 def2 && equal_mcode colon1 colon2
 684   | (Ast0.Case(case1,_,colon1,_),Ast0.Case(case2,_,colon2,_)) ->
 685       equal_mcode case1 case2 && equal_mcode colon1 colon2
 686   | (Ast0.DisjCase(starter1,_,mids1,ender1),
 687      Ast0.DisjCase(starter2,_,mids2,ender2)) ->
 688        equal_mcode starter1 starter2 &&
 689        List.for_all2 equal_mcode mids1 mids2 &&
 690        equal_mcode ender1 ender2
 691   | (Ast0.OptCase(_),Ast0.OptCase(_)) -> true
 692   | _ -> false
 693
 694 let rec equal_top_level t1 t2 =
 695   match (Ast0.unwrap t1,Ast0.unwrap t2) with
 696     (Ast0.DECL(_),Ast0.DECL(_)) -> true
 697   | (Ast0.FILEINFO(old_file1,new_file1),Ast0.FILEINFO(old_file2,new_file2)) ->
 698       equal_mcode old_file1 old_file2 && equal_mcode new_file1 new_file2
 699   | (Ast0.CODE(_),Ast0.CODE(_)) -> true
 700   | (Ast0.ERRORWORDS(_),Ast0.ERRORWORDS(_)) -> true
 701   | _ -> false
 702
 703 let root_equal e1 e2 =
 704   match (e1,e2) with
 705     (Ast0.DotsExprTag(d1),Ast0.DotsExprTag(d2)) -> dots equal_expression d1 d2
 706   | (Ast0.DotsParamTag(d1),Ast0.DotsParamTag(d2)) ->
 707       dots equal_parameterTypeDef d1 d2
 708   | (Ast0.DotsStmtTag(d1),Ast0.DotsStmtTag(d2)) -> dots equal_statement d1 d2
 709   | (Ast0.DotsDeclTag(d1),Ast0.DotsDeclTag(d2)) -> dots equal_declaration d1 d2
 710   | (Ast0.DotsCaseTag(d1),Ast0.DotsCaseTag(d2)) -> dots equal_case_line d1 d2
 711   | (Ast0.IdentTag(i1),Ast0.IdentTag(i2)) -> equal_ident i1 i2
 712   | (Ast0.ExprTag(e1),Ast0.ExprTag(e2)) -> equal_expression e1 e2
 713   | (Ast0.ArgExprTag(d),_) -> failwith "not possible - iso only"
 714   | (Ast0.TypeCTag(t1),Ast0.TypeCTag(t2)) -> equal_typeC t1 t2
 715   | (Ast0.ParamTag(p1),Ast0.ParamTag(p2)) -> equal_parameterTypeDef p1 p2
 716   | (Ast0.InitTag(d1),Ast0.InitTag(d2)) -> equal_initialiser d1 d2
 717   | (Ast0.DeclTag(d1),Ast0.DeclTag(d2)) -> equal_declaration d1 d2
 718   | (Ast0.StmtTag(s1),Ast0.StmtTag(s2)) -> equal_statement s1 s2
 719   | (Ast0.TopTag(t1),Ast0.TopTag(t2)) -> equal_top_level t1 t2
 720   | (Ast0.IsoWhenTag(_),_) | (_,Ast0.IsoWhenTag(_))
 721   | (Ast0.IsoWhenTTag(_),_) | (_,Ast0.IsoWhenTTag(_))
 722   | (Ast0.IsoWhenFTag(_),_) | (_,Ast0.IsoWhenFTag(_)) ->
 723       failwith "only within iso phase"
 724   | _ -> false
 725
 726 let default_context _ =
 727   Ast0.CONTEXT(ref(Ast.NOTHING,
 728                    Ast0.default_token_info,Ast0.default_token_info))
 729
 730 let traverse minus_table plus_table =
 731   Hashtbl.iter
 732     (function key ->
 733       function (e,l) ->
 734         try
 735           let (plus_e,plus_l) = Hashtbl.find plus_table key in
 736           if root_equal e plus_e &&
 737             List.for_all (function x -> x)
 738               (List.map2 Common.equal_set l plus_l)
 739           then
 740             let i = Ast0.fresh_index() in
 741             (set_index e i; set_index plus_e i;
 742              set_mcodekind e (default_context());
 743              set_mcodekind plus_e (default_context()))
 744         with Not_found -> ())
 745     minus_table
 746
 747 (* --------------------------------------------------------------------- *)
 748 (* contextify the whencode *)
 749
 750 let contextify_all =
 751   let bind x y = () in
 752   let option_default = () in
 753   let mcode x = () in
 754   let do_nothing r k e = Ast0.set_mcodekind e (default_context()); k e in
 755
 756   V0.flat_combiner bind option_default
 757     mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode mcode
 758     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 759     do_nothing do_nothing do_nothing do_nothing do_nothing do_nothing
 760     do_nothing do_nothing do_nothing
 761
 762 let contextify_whencode =
 763   let bind x y = () in
 764   let option_default = () in
 765
 766   let expression r k e =
 767     k e;
 768     match Ast0.unwrap e with
 769       Ast0.NestExpr(_,_,_,Some whencode,_)
 770     | Ast0.Edots(_,Some whencode)
 771     | Ast0.Ecircles(_,Some whencode)
 772     | Ast0.Estars(_,Some whencode) ->
 773         contextify_all.VT0.combiner_rec_expression whencode
 774     | _ -> () in
 775
 776   let initialiser r k i =
 777     match Ast0.unwrap i with
 778       Ast0.Idots(dots,Some whencode) ->
 779         contextify_all.VT0.combiner_rec_initialiser whencode
 780     | _ -> k i in
 781
 782   let whencode = function
 783       Ast0.WhenNot sd -> contextify_all.VT0.combiner_rec_statement_dots sd
 784     | Ast0.WhenAlways s -> contextify_all.VT0.combiner_rec_statement s
 785     | Ast0.WhenModifier(_) -> ()
 786     | Ast0.WhenNotTrue(e) -> contextify_all.VT0.combiner_rec_expression e
 787     | Ast0.WhenNotFalse(e) -> contextify_all.VT0.combiner_rec_expression e in
 788
 789   let statement r k (s : Ast0.statement) =
 790     k s;
 791     match Ast0.unwrap s with
 792       Ast0.Nest(_,_,_,whn,_)
 793     | Ast0.Dots(_,whn) | Ast0.Circles(_,whn) | Ast0.Stars(_,whn) ->
 794         List.iter whencode whn
 795     | _ -> () in
 796
 797   let combiner =
 798     V0.combiner bind option_default
 799       {V0.combiner_functions with
 800         VT0.combiner_exprfn = expression;
 801         VT0.combiner_initfn = initialiser;
 802         VT0.combiner_stmtfn = statement} in
 803   combiner.VT0.combiner_rec_top_level
 804
 805 (* --------------------------------------------------------------------- *)
 806
 807 (* the first int list is the tokens in the node, the second is the tokens
 808 in the descendents *)
 809 let minus_table =
 810   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 811 let plus_table =
 812   (Hashtbl.create(50) : (int list, Ast0.anything * int list list) Hashtbl.t)
 813
 814 let iscode t =
 815   match Ast0.unwrap t with
 816     Ast0.DECL(_) -> true
 817   | Ast0.FILEINFO(_) -> true
 818   | Ast0.ERRORWORDS(_) -> false
 819   | Ast0.CODE(_) -> true
 820   | Ast0.OTHER(_) -> failwith "unexpected top level code"
 821
 822 (* ------------------------------------------------------------------- *)
 823 (* alignment of minus and plus *)
 824
 825 let concat = function
 826     [] -> []
 827   | [s] -> [s]
 828   | l ->
 829       let rec loop = function
 830           [] -> []
 831         | x::rest ->
 832             (match Ast0.unwrap x with
 833               Ast0.DECL(s) -> let stms = loop rest in s::stms
 834             | Ast0.CODE(ss) ->
 835                 let stms = loop rest in
 836                 (match Ast0.unwrap ss with
 837                   Ast0.DOTS(d) -> d@stms
 838                 | _ -> failwith "no dots allowed in pure plus code")
 839             | _ -> failwith "plus code is being discarded") in
 840       let res =
 841         Compute_lines.compute_statement_dots_lines false
 842           (Ast0.rewrap (List.hd l) (Ast0.DOTS (loop l))) in
 843       [Ast0.rewrap res (Ast0.CODE res)]
 844
 845 let collect_up_to m plus =
 846   let minfo = Ast0.get_info m in
 847   let mend = minfo.Ast0.pos_info.Ast0.logical_end in
 848   let rec loop = function
 849       [] -> ([],[])
 850     | p::plus ->
 851         let pinfo = Ast0.get_info p in
 852         let pstart = pinfo.Ast0.pos_info.Ast0.logical_start in
 853         if pstart > mend
 854         then ([],p::plus)
 855         else let (plus,rest) = loop plus in (p::plus,rest) in
 856   let (plus,rest) = loop plus in
 857   (concat plus,rest)
 858
 859 let realign minus plus =
 860   let rec loop = function
 861       ([],_) -> failwith "not possible, some context required"
 862     | ([m],p) -> ([m],concat p)
 863     | (m::minus,plus) ->
 864         let (p,plus) = collect_up_to m plus in
 865         let (minus,plus) = loop (minus,plus) in
 866         (m::minus,p@plus) in
 867   loop (minus,plus)
 868
 869 (* ------------------------------------------------------------------- *)
 870 (* check compatible: check that at the top level the minus and plus code is
 871 of the same kind.  Could go further and make the correspondence between the
 872 code between ...s. *)
 873
 874 let isonly f l = match Ast0.undots l with [s] -> f s | _ -> false
 875
 876 let isall f l = List.for_all (isonly f) l
 877
 878 let rec is_exp s =
 879   match Ast0.unwrap s with
 880     Ast0.Exp(e) -> true
 881   | Ast0.Disj(_,stmts,_,_) -> isall is_exp stmts
 882   | _ -> false
 883
 884 let rec is_ty s =
 885   match Ast0.unwrap s with
 886     Ast0.Ty(e) -> true
 887   | Ast0.Disj(_,stmts,_,_) -> isall is_ty stmts
 888   | _ -> false
 889
 890 let rec is_init s =
 891   match Ast0.unwrap s with
 892     Ast0.TopInit(e) -> true
 893   | Ast0.Disj(_,stmts,_,_) -> isall is_init stmts
 894   | _ -> false
 895
 896 let rec is_decl s =
 897   match Ast0.unwrap s with
 898     Ast0.Decl(_,e) -> true
 899   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 900   | Ast0.Disj(_,stmts,_,_) -> isall is_decl stmts
 901   | _ -> false
 902
 903 let rec is_fndecl s =
 904   match Ast0.unwrap s with
 905     Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 906   | Ast0.Disj(_,stmts,_,_) -> isall is_fndecl stmts
 907   | _ -> false
 908
 909 let rec is_toplevel s =
 910   match Ast0.unwrap s with
 911     Ast0.Decl(_,e) -> true
 912   | Ast0.FunDecl(_,_,_,_,_,_,_,_,_) -> true
 913   | Ast0.Disj(_,stmts,_,_) -> isall is_toplevel stmts
 914   | Ast0.ExprStatement(fc,_) ->
 915       (match Ast0.unwrap fc with
 916         Ast0.FunCall(_,_,_,_) -> true
 917       | _ -> false)
 918   | Ast0.Include(_,_) -> true
 919   | Ast0.Define(_,_,_,_) -> true
 920   | _ -> false
 921
 922 let check_compatible m p =
 923   let fail _ =
 924     failwith
 925       (Printf.sprintf
 926          "incompatible minus and plus code starting on lines %d and %d"
 927          (Ast0.get_line m) (Ast0.get_line p)) in
 928   match (Ast0.unwrap m, Ast0.unwrap p) with
 929     (Ast0.DECL(decl1),Ast0.DECL(decl2)) ->
 930       if not (is_decl decl1 && is_decl decl2)
 931       then fail()
 932   | (Ast0.DECL(decl1),Ast0.CODE(code2)) ->
 933       let v1 = is_decl decl1 in
 934       let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 935       if !Flag.make_hrule = None && v1 && not v2 then fail()
 936   | (Ast0.CODE(code1),Ast0.DECL(decl2)) ->
 937       let v1 = List.for_all is_toplevel (Ast0.undots code1) in
 938       let v2 = is_decl decl2 in
 939       if v1 && not v2 then fail()
 940   | (Ast0.CODE(code1),Ast0.CODE(code2)) ->
 941       let v1 = isonly is_init code1 in
 942       let v2a = isonly is_init code2 in
 943       let v2b = isonly is_exp code2 in
 944       if v1
 945       then (if not (v2a || v2b) then fail())
 946       else
 947         let testers = [is_exp;is_ty] in
 948         List.iter
 949           (function tester ->
 950             let v1 = isonly tester code1 in
 951             let v2 = isonly tester code2 in
 952             if (v1 && not v2) or (!Flag.make_hrule = None && v2 && not v1)
 953             then fail())
 954           testers;
 955         let v1 = isonly is_fndecl code1 in
 956         let v2 = List.for_all is_toplevel (Ast0.undots code2) in
 957         if !Flag.make_hrule = None && v1 && not v2 then fail()
 958   | (Ast0.FILEINFO(_,_),Ast0.FILEINFO(_,_)) -> ()
 959   | (Ast0.OTHER(_),Ast0.OTHER(_)) -> ()
 960   | _ -> fail()
 961
 962 (* ------------------------------------------------------------------- *)
 963
 964 (* returns a list of corresponding minus and plus trees *)
 965 let context_neg minus plus =
 966   Hashtbl.clear minus_table;
 967   Hashtbl.clear plus_table;
 968   List.iter contextify_whencode minus;
 969   let (minus,plus) = realign minus plus in
 970   let rec loop = function
 971       ([],[]) -> []
 972     | ([],l) ->
 973         failwith (Printf.sprintf "%d plus things remaining" (List.length l))
 974     | (minus,[]) ->
 975         plus_lines := [];
 976         let _ =
 977           List.map
 978             (function m ->
 979               classify true
 980                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
 981                 minus_table m)
 982             minus in
 983         []
 984     | (((m::minus) as mall),((p::plus) as pall)) ->
 985         let minfo = Ast0.get_info m in
 986         let pinfo = Ast0.get_info p in
 987         let mstart = minfo.Ast0.pos_info.Ast0.logical_start in
 988         let mend = minfo.Ast0.pos_info.Ast0.logical_end in
 989         let pstart = pinfo.Ast0.pos_info.Ast0.logical_start in
 990         let pend = pinfo.Ast0.pos_info.Ast0.logical_end in
 991         if (iscode m or iscode p) &&
 992           (mend + 1 = pstart or pend + 1 = mstart or (* adjacent *)
 993            (mstart <= pstart && mend >= pstart) or
 994            (pstart <= mstart && pend >= mstart)) (* overlapping or nested *)
 995         then
 996           begin
 997             (* ensure that the root of each tree has a unique index,
 998                although it might get overwritten if the node is a context
 999                node *)
1000             let i = Ast0.fresh_index() in
1001             Ast0.set_index m i; Ast0.set_index p i;
1002             check_compatible m p;
1003             collect_plus_lines p;
1004             let _ =
1005               classify true
1006                 (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
1007                 minus_table m in
1008             let _ = classify false (function c -> Ast0.PLUS c) plus_table p in
1009             traverse minus_table plus_table;
1010             (m,p)::loop(minus,plus)
1011           end
1012         else
1013           if not(iscode m or iscode p)
1014           then loop(minus,plus)
1015           else
1016             if mstart < pstart
1017             then
1018               begin
1019                 plus_lines := [];
1020                 let _ =
1021                   classify true
1022                     (function _ -> Ast0.MINUS(ref([],Ast0.default_token_info)))
1023                     minus_table m in
1024                 loop(minus,pall)
1025               end
1026             else loop(mall,plus) in
1027   loop(minus,plus)