bundles/menhirLib/menhir-20120123/src/traverse.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 (* Code for traversing or transforming [IL] terms. *)
  16
  17 open IL
  18 open CodeBits
  19
  20 (* This turns a list of value definitions into a hash table. It also
  21 counts and numbers the definitions. We assume that the left-hand
  22 side of every definition is a variable. *)
  23
  24 let tabulate_defs (defs : valdef list) : int * (string, int * valdef) Hashtbl.t =
  25   let count = ref 0 in
  26   let table = Hashtbl.create 1023 in
  27   List.iter (fun def ->
  28           let k = !count in
  29           count := k + 1;
  30           Hashtbl.add table (pat2var def.valpat) (k, def)
  31     ) defs;
  32   !count, table
  33
  34 (* This mixin class, used by [map] and [fold] below, helps maintain
  35    environments, which can be used to keep track of local variable
  36    bindings. *)
  37
  38 class virtual ['env] env = object(self)
  39
  40   (* The virtual method [pvar] records a local variable binding in
  41      the environment. *)
  42
  43   method virtual pvar: 'env -> string -> 'env
  44
  45   method pat env = function
  46     | PWildcard
  47     | PUnit ->
  48         env
  49     | PVar id ->
  50         self#pvar env id
  51     | PTuple ps
  52     | POr ps
  53     | PData (_, ps) ->
  54         self#pats env ps
  55     | PAnnot (p, _) ->
  56         self#pat env p
  57     | PRecord fps ->
  58         self#fpats env fps
  59
  60   method pats env ps =
  61     List.fold_left self#pat env ps
  62
  63   method fpats env fps =
  64     List.fold_left self#fpat env fps
  65
  66   method fpat env (_, p) =
  67     self#pat env p
  68
  69 end
  70
  71 (* A class that helps transform expressions. The environment [env] can be
  72    used to keep track of local variable bindings. *)
  73
  74 exception NoChange
  75
  76 class virtual ['env] map = object (self)
  77
  78   inherit ['env] env
  79
  80   method expr (env : 'env) e =
  81     try
  82       match e with
  83       | EVar x ->
  84           self#evar env x
  85       | EFun (ps, e) ->
  86           self#efun env ps e
  87       | EApp (e, es) ->
  88           self#eapp env e es
  89       | ELet (bs, e) ->
  90           self#elet env bs e
  91       | EMatch (e, bs) ->
  92           self#ematch env e bs
  93       | EIfThen (e, e1) ->
  94           self#eifthen env e e1
  95       | EIfThenElse (e, e1, e2) ->
  96           self#eifthenelse env e e1 e2
  97       | ERaise e ->
  98           self#eraise env e
  99       | ETry (e, bs) ->
 100           self#etry env e bs
 101       | EUnit ->
 102           self#eunit env
 103       | EIntConst k ->
 104           self#eintconst env k
 105       | EStringConst s ->
 106           self#estringconst env s
 107       | EData (d, es) ->
 108           self#edata env d es
 109       | ETuple es ->
 110           self#etuple env es
 111       | EAnnot (e, t) ->
 112           self#eannot env e t
 113       | EMagic e ->
 114           self#emagic env e
 115       | ERepr _ ->
 116           self#erepr env e
 117       | ERecord fs ->
 118           self#erecord env fs
 119       | ERecordAccess (e, f) ->
 120           self#erecordaccess env e f
 121       | ERecordWrite (e, f, e1) ->
 122           self#erecordwrite env e f e1
 123       | ETextual action ->
 124           self#etextual env action
 125       | EComment (s, e) ->
 126           self#ecomment env s e
 127       | EPatComment (s, p, e) ->
 128           self#epatcomment env s p e
 129       | EArray es ->
 130           self#earray env es
 131       | EArrayAccess (e, i) ->
 132           self#earrayaccess env e i
 133     with NoChange ->
 134       e
 135
 136   method evar env x =
 137     raise NoChange
 138
 139   method efun env ps e =
 140     let e' = self#expr (self#pats env ps) e in
 141     if e == e' then
 142       raise NoChange
 143     else
 144       EFun (ps, e')
 145
 146   method eapp env e es =
 147     let e' = self#expr env e
 148     and es' = self#exprs env es in
 149     if e == e' && es == es' then
 150       raise NoChange
 151     else
 152       EApp (e', es')
 153
 154   method elet env bs e =
 155     let env, bs' = self#bindings env bs in
 156     let e' = self#expr env e in
 157     if bs == bs' && e == e' then
 158       raise NoChange
 159     else
 160       ELet (bs', e')
 161
 162   method ematch env e bs =
 163     let e' = self#expr env e
 164     and bs' = self#branches env bs in
 165     if e == e' && bs == bs' then
 166       raise NoChange
 167     else
 168       EMatch (e', bs')
 169
 170   method eifthen env e e1 =
 171     let e' = self#expr env e
 172     and e1' = self#expr env e1 in
 173     if e == e' && e1 == e1' then
 174       raise NoChange
 175     else
 176       EIfThen (e', e1')
 177
 178   method eifthenelse env e e1 e2 =
 179     let e' = self#expr env e
 180     and e1' = self#expr env e1
 181     and e2' = self#expr env e2 in
 182     if e == e' && e1 == e1' && e2 == e2' then
 183       raise NoChange
 184     else
 185       EIfThenElse (e', e1', e2')
 186
 187   method eraise env e =
 188     let e' = self#expr env e in
 189     if e == e' then
 190       raise NoChange
 191     else
 192       ERaise e'
 193
 194   method etry env e bs =
 195     let e' = self#expr env e
 196     and bs' = self#branches env bs in
 197     if e == e' && bs == bs' then
 198       raise NoChange
 199     else
 200       ETry (e', bs')
 201
 202   method eunit env =
 203     raise NoChange
 204
 205   method eintconst env k =
 206     raise NoChange
 207
 208   method estringconst env s =
 209     raise NoChange
 210
 211   method edata env d es =
 212     let es' = self#exprs env es in
 213     if es == es' then
 214       raise NoChange
 215     else
 216       EData (d, es')
 217
 218   method etuple env es =
 219     let es' = self#exprs env es in
 220     if es == es' then
 221       raise NoChange
 222     else
 223       ETuple es'
 224
 225   method eannot env e t =
 226     let e' = self#expr env e in
 227     if e == e' then
 228       raise NoChange
 229     else
 230       EAnnot (e', t)
 231
 232   method emagic env e =
 233     let e' = self#expr env e in
 234     if e == e' then
 235       raise NoChange
 236     else
 237       EMagic e'
 238
 239   method erepr env e =
 240     let e' = self#expr env e in
 241     if e == e' then
 242       raise NoChange
 243     else
 244       ERepr e'
 245
 246   method erecord env fs =
 247     let fs' = self#fields env fs in
 248     if fs == fs' then
 249       raise NoChange
 250     else
 251       ERecord fs'
 252
 253   method erecordaccess env e f =
 254     let e' = self#expr env e in
 255     if e == e' then
 256       raise NoChange
 257     else
 258       ERecordAccess (e', f)
 259
 260   method erecordwrite env e f e1 =
 261     let e' = self#expr env e
 262     and e1' = self#expr env e1 in
 263     if e == e' && e1 == e1' then
 264       raise NoChange
 265     else
 266       ERecordWrite (e', f, e1')
 267
 268   method earray env es =
 269     let es' = self#exprs env es in
 270     if es == es' then
 271       raise NoChange
 272     else
 273       EArray es'
 274
 275   method earrayaccess env e i =
 276     let e' = self#expr env e in
 277     if e == e' then
 278       raise NoChange
 279     else
 280       EArrayAccess (e', i)
 281
 282   method etextual env action =
 283     raise NoChange
 284
 285   method ecomment env s e =
 286     let e' = self#expr env e in
 287     if e == e' then
 288       raise NoChange
 289     else
 290       EComment (s, e')
 291
 292   method epatcomment env s p e =
 293     let e' = self#expr env e in
 294     if e == e' then
 295       raise NoChange
 296     else
 297       EPatComment (s, p, e')
 298
 299   method exprs env es =
 300     Misc.smap (self#expr env) es
 301
 302   method fields env fs =
 303     Misc.smap (self#field env) fs
 304
 305   method field env ((f, e) as field) =
 306     let e' = self#expr env e in
 307     if e == e' then
 308       field
 309     else
 310       (f, e')
 311
 312   method branches env bs =
 313     Misc.smap (self#branch env) bs
 314
 315   method branch env b =
 316     let e = b.branchbody in
 317     let e' = self#expr (self#pat env b.branchpat) e in
 318     if e == e' then
 319       b
 320     else
 321       { b with branchbody = e' }
 322
 323   (* The method [binding] produces a pair of an updated environment
 324      and a transformed binding. *)
 325
 326   method binding env ((p, e) as b) =
 327     let e' = self#expr env e in
 328     self#pat env p,
 329     if e == e' then
 330       b
 331     else
 332       (p, e')
 333
 334   (* For nested non-recursive bindings, the environment produced by
 335      each binding is used to traverse the following bindings. The
 336      method [binding] produces a pair of an updated environment
 337      and a transformed list of bindings. *)
 338
 339   method bindings env bs =
 340     Misc.smapa self#binding env bs
 341
 342   method valdef env def =
 343     let e = def.valval in
 344     let e' = self#expr env e in
 345     if e == e' then
 346       def
 347     else
 348       { def with valval = e' }
 349
 350   method valdefs env defs =
 351     Misc.smap (self#valdef env) defs
 352
 353 end
 354
 355 (* A class that helps iterate, or fold, over expressions. *)
 356
 357 class virtual ['env, 'a] fold = object (self)
 358
 359   inherit ['env] env
 360
 361   method expr (env : 'env) (accu : 'a) e =
 362     match e with
 363     | EVar x ->
 364         self#evar env accu x
 365     | EFun (ps, e) ->
 366         self#efun env accu ps e
 367     | EApp (e, es) ->
 368         self#eapp env accu e es
 369     | ELet (bs, e) ->
 370         self#elet env accu bs e
 371     | EMatch (e, bs) ->
 372         self#ematch env accu e bs
 373     | EIfThen (e, e1) ->
 374         self#eifthen env accu e e1
 375     | EIfThenElse (e, e1, e2) ->
 376         self#eifthenelse env accu e e1 e2
 377     | ERaise e ->
 378         self#eraise env accu e
 379     | ETry (e, bs) ->
 380         self#etry env accu e bs
 381     | EUnit ->
 382         self#eunit env accu
 383     | EIntConst k ->
 384         self#eintconst env accu k
 385     | EStringConst s ->
 386         self#estringconst env accu s
 387     | EData (d, es) ->
 388         self#edata env accu d es
 389     | ETuple es ->
 390         self#etuple env accu es
 391     | EAnnot (e, t) ->
 392         self#eannot env accu e t
 393     | EMagic e ->
 394         self#emagic env accu e
 395     | ERepr _ ->
 396         self#erepr env accu e
 397     | ERecord fs ->
 398         self#erecord env accu fs
 399     | ERecordAccess (e, f) ->
 400         self#erecordaccess env accu e f
 401     | ERecordWrite (e, f, e1) ->
 402         self#erecordwrite env accu e f e1
 403     | ETextual action ->
 404         self#etextual env accu action
 405     | EComment (s, e) ->
 406         self#ecomment env accu s e
 407     | EPatComment (s, p, e) ->
 408         self#epatcomment env accu s p e
 409     | EArray es ->
 410         self#earray env accu es
 411     | EArrayAccess (e, i) ->
 412         self#earrayaccess env accu e i
 413
 414   method evar (env : 'env) (accu : 'a) x =
 415     accu
 416
 417   method efun (env : 'env) (accu : 'a) ps e =
 418     let accu = self#expr (self#pats env ps) accu e in
 419     accu
 420
 421   method eapp (env : 'env) (accu : 'a) e es =
 422     let accu = self#expr env accu e in
 423     let accu = self#exprs env accu es in
 424     accu
 425
 426   method elet (env : 'env) (accu : 'a) bs e =
 427     let env, accu = self#bindings env accu bs in
 428     let accu = self#expr env accu e in
 429     accu
 430
 431   method ematch (env : 'env) (accu : 'a) e bs =
 432     let accu = self#expr env accu e in
 433     let accu = self#branches env accu bs in
 434     accu
 435
 436   method eifthen (env : 'env) (accu : 'a) e e1 =
 437     let accu = self#expr env accu e in
 438     let accu = self#expr env accu e1 in
 439     accu
 440
 441   method eifthenelse (env : 'env) (accu : 'a) e e1 e2 =
 442     let accu = self#expr env accu e in
 443     let accu = self#expr env accu e1 in
 444     let accu = self#expr env accu e2 in
 445     accu
 446
 447   method eraise (env : 'env) (accu : 'a) e =
 448     let accu = self#expr env accu e in
 449     accu
 450
 451   method etry (env : 'env) (accu : 'a) e bs =
 452     let accu = self#expr env accu e in
 453     let accu = self#branches env accu bs in
 454     accu
 455
 456   method eunit (env : 'env) (accu : 'a) =
 457     accu
 458
 459   method eintconst (env : 'env) (accu : 'a) k =
 460     accu
 461
 462   method estringconst (env : 'env) (accu : 'a) s =
 463     accu
 464
 465   method edata (env : 'env) (accu : 'a) d es =
 466     let accu = self#exprs env accu es in
 467     accu
 468
 469   method etuple (env : 'env) (accu : 'a) es =
 470     let accu = self#exprs env accu es in
 471     accu
 472
 473   method eannot (env : 'env) (accu : 'a) e t =
 474     let accu = self#expr env accu e in
 475     accu
 476
 477   method emagic (env : 'env) (accu : 'a) e =
 478     let accu = self#expr env accu e in
 479     accu
 480
 481   method erepr (env : 'env) (accu : 'a) e =
 482     let accu = self#expr env accu e in
 483     accu
 484
 485   method erecord (env : 'env) (accu : 'a) fs =
 486     let accu = self#fields env accu fs in
 487     accu
 488
 489   method erecordaccess (env : 'env) (accu : 'a) e f =
 490     let accu = self#expr env accu e in
 491     accu
 492
 493   method erecordwrite (env : 'env) (accu : 'a) e f e1 =
 494     let accu = self#expr env accu e in
 495     let accu = self#expr env accu e1 in
 496     accu
 497
 498   method earray (env : 'env) (accu : 'a) es =
 499     let accu = self#exprs env accu es in
 500     accu
 501
 502   method earrayaccess (env : 'env) (accu : 'a) e i =
 503     let accu = self#expr env accu e in
 504     accu
 505
 506   method etextual (env : 'env) (accu : 'a) action =
 507     accu
 508
 509   method ecomment (env : 'env) (accu : 'a) s e =
 510     let accu = self#expr env accu e in
 511     accu
 512
 513   method epatcomment (env : 'env) (accu : 'a) s p e =
 514     let accu = self#expr env accu e in
 515     accu
 516
 517   method exprs (env : 'env) (accu : 'a) es =
 518     List.fold_left (self#expr env) accu es
 519
 520   method fields (env : 'env) (accu : 'a) fs =
 521     List.fold_left (self#field env) accu fs
 522
 523   method field (env : 'env) (accu : 'a) (f, e) =
 524     let accu = self#expr env accu e in
 525     accu
 526
 527   method branches (env : 'env) (accu : 'a) bs =
 528     List.fold_left (self#branch env) accu bs
 529
 530   method branch (env : 'env) (accu : 'a) b =
 531     let accu = self#expr (self#pat env b.branchpat) accu b.branchbody in
 532     accu
 533
 534   method binding ((env, accu) : 'env * 'a) (p, e) =
 535     let accu = self#expr env accu e in
 536     self#pat env p,
 537     accu
 538
 539   method bindings (env : 'env) (accu : 'a) bs =
 540     List.fold_left self#binding (env, accu) bs
 541
 542   method valdef (env : 'env) (accu : 'a) def =
 543     let accu = self#expr env accu def.valval in
 544     accu
 545
 546   method valdefs (env : 'env) (accu : 'a) defs =
 547     List.fold_left (self#valdef env) accu defs
 548
 549 end
 550