module/language/tree-il.scm

   1 ;;;;    Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 3 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (language tree-il)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-11)
  22   #:use-module (system base pmatch)
  23   #:use-module (system base syntax)
  24   #:export (tree-il-src
  25
  26             <void> void? make-void void-src
  27             <const> const? make-const const-src const-exp
  28             <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
  29             <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
  30             <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
  31             <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
  32             <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
  33             <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
  34             <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
  35             <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
  36             <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
  37             <call> call? make-call call-src call-proc call-args
  38             <primcall> primcall? make-primcall primcall-src primcall-name primcall-args
  39             <sequence> sequence? make-sequence sequence-src sequence-exps
  40             <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
  41             <lambda-case> lambda-case? make-lambda-case lambda-case-src
  42                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
  43                           lambda-case-inits lambda-case-gensyms
  44                           lambda-case-body lambda-case-alternate
  45             <let> let? make-let let-src let-names let-gensyms let-vals let-body
  46             <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
  47             <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
  48             <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
  49             <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
  50             <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
  51             <dynref> dynref? make-dynref dynref-src dynref-fluid
  52             <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
  53             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
  54             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
  55
  56             parse-tree-il
  57             unparse-tree-il
  58             tree-il->scheme
  59
  60             tree-il-fold
  61             make-tree-il-folder
  62             post-order!
  63             pre-order!))
  64
  65 (define (print-tree-il exp port)
  66   (format port "#<tree-il ~S>" (unparse-tree-il exp)))
  67
  68 (define-syntax borrow-core-vtables
  69   (lambda (x)
  70     (syntax-case x ()
  71       ((_)
  72        (let lp ((n 0) (out '()))
  73          (if (< n (vector-length %expanded-vtables))
  74              (lp (1+ n)
  75                  (let* ((vtable (vector-ref %expanded-vtables n))
  76                         (stem (struct-ref vtable (+ vtable-offset-user 0)))
  77                         (fields (struct-ref vtable (+ vtable-offset-user 2)))
  78                         (sfields (map
  79                                   (lambda (f) (datum->syntax x f))
  80                                   fields))
  81                         (type (datum->syntax x (symbol-append '< stem '>)))
  82                         (ctor (datum->syntax x (symbol-append 'make- stem)))
  83                         (pred (datum->syntax x (symbol-append stem '?))))
  84                    (let lp ((n 0) (fields fields)
  85                             (out (cons*
  86                                   #`(define (#,ctor #,@sfields)
  87                                       (make-struct #,type 0 #,@sfields))
  88                                   #`(define (#,pred x)
  89                                       (and (struct? x)
  90                                            (eq? (struct-vtable x) #,type)))
  91                                   #`(struct-set! #,type vtable-index-printer
  92                                                  print-tree-il)
  93                                   #`(define #,type
  94                                            (vector-ref %expanded-vtables #,n))
  95                                        out)))
  96                      (if (null? fields)
  97                          out
  98                          (lp (1+ n)
  99                              (cdr fields)
 100                              (let ((acc (datum->syntax
 101                                          x (symbol-append stem '- (car fields)))))
 102                                (cons #`(define #,acc
 103                                          (make-procedure-with-setter
 104                                           (lambda (x) (struct-ref x #,n))
 105                                           (lambda (x v) (struct-set! x #,n v))))
 106                                      out)))))))
 107              #`(begin #,@(reverse out))))))))
 108
 109 (borrow-core-vtables)
 110
 111   ;; (<void>)
 112   ;; (<const> exp)
 113   ;; (<primitive-ref> name)
 114   ;; (<lexical-ref> name gensym)
 115   ;; (<lexical-set> name gensym exp)
 116   ;; (<module-ref> mod name public?)
 117   ;; (<module-set> mod name public? exp)
 118   ;; (<toplevel-ref> name)
 119   ;; (<toplevel-set> name exp)
 120   ;; (<toplevel-define> name exp)
 121   ;; (<conditional> test consequent alternate)
 122   ;; (<call> proc args)
 123   ;; (<primcall> name args)
 124   ;; (<sequence> exps)
 125   ;; (<lambda> meta body)
 126   ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
 127   ;; (<let> names gensyms vals body)
 128   ;; (<letrec> in-order? names gensyms vals body)
 129   ;; (<dynlet> fluids vals body)
 130
 131 (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
 132   (<fix> names gensyms vals body)
 133   (<let-values> exp body)
 134   (<dynwind> winder body unwinder)
 135   (<dynref> fluid)
 136   (<dynset> fluid exp)
 137   (<prompt> tag body handler)
 138   (<abort> tag args tail))
 139
 140 \f
 141
 142 (define (location x)
 143   (and (pair? x)
 144        (let ((props (source-properties x)))
 145          (and (pair? props) props))))
 146
 147 (define (parse-tree-il exp)
 148   (let ((loc (location exp))
 149         (retrans (lambda (x) (parse-tree-il x))))
 150     (pmatch exp
 151      ((void)
 152       (make-void loc))
 153
 154      ((call ,proc . ,args)
 155       (make-call loc (retrans proc) (map retrans args)))
 156
 157      ((primcall ,name . ,args)
 158       (make-primcall loc name (map retrans args)))
 159
 160      ((if ,test ,consequent ,alternate)
 161       (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
 162
 163      ((primitive ,name) (guard (symbol? name))
 164       (make-primitive-ref loc name))
 165
 166      ((lexical ,name) (guard (symbol? name))
 167       (make-lexical-ref loc name name))
 168
 169      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
 170       (make-lexical-ref loc name sym))
 171
 172      ((set! (lexical ,name) ,exp) (guard (symbol? name))
 173       (make-lexical-set loc name name (retrans exp)))
 174
 175      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
 176       (make-lexical-set loc name sym (retrans exp)))
 177
 178      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 179       (make-module-ref loc mod name #t))
 180
 181      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 182       (make-module-set loc mod name #t (retrans exp)))
 183
 184      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 185       (make-module-ref loc mod name #f))
 186
 187      ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 188       (make-module-set loc mod name #f (retrans exp)))
 189
 190      ((toplevel ,name) (guard (symbol? name))
 191       (make-toplevel-ref loc name))
 192
 193      ((set! (toplevel ,name) ,exp) (guard (symbol? name))
 194       (make-toplevel-set loc name (retrans exp)))
 195
 196      ((define ,name ,exp) (guard (symbol? name))
 197       (make-toplevel-define loc name (retrans exp)))
 198
 199      ((lambda ,meta ,body)
 200       (make-lambda loc meta (retrans body)))
 201
 202      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
 203       (make-lambda-case loc req opt rest kw
 204                         (map retrans inits) gensyms
 205                         (retrans body)
 206                         (and=> alternate retrans)))
 207
 208      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
 209       (make-lambda-case loc req opt rest kw
 210                         (map retrans inits) gensyms
 211                         (retrans body)
 212                         #f))
 213
 214      ((const ,exp)
 215       (make-const loc exp))
 216
 217      ((begin . ,exps)
 218       (make-sequence loc (map retrans exps)))
 219
 220      ((let ,names ,gensyms ,vals ,body)
 221       (make-let loc names gensyms (map retrans vals) (retrans body)))
 222
 223      ((letrec ,names ,gensyms ,vals ,body)
 224       (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
 225
 226      ((letrec* ,names ,gensyms ,vals ,body)
 227       (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
 228
 229      ((fix ,names ,gensyms ,vals ,body)
 230       (make-fix loc names gensyms (map retrans vals) (retrans body)))
 231
 232      ((let-values ,exp ,body)
 233       (make-let-values loc (retrans exp) (retrans body)))
 234
 235      ((dynwind ,winder ,body ,unwinder)
 236       (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
 237
 238      ((dynlet ,fluids ,vals ,body)
 239       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
 240
 241      ((dynref ,fluid)
 242       (make-dynref loc (retrans fluid)))
 243
 244      ((dynset ,fluid ,exp)
 245       (make-dynset loc (retrans fluid) (retrans exp)))
 246
 247      ((prompt ,tag ,body ,handler)
 248       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
 249
 250      ((abort ,tag ,args ,tail)
 251       (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
 252
 253      (else
 254       (error "unrecognized tree-il" exp)))))
 255
 256 (define (unparse-tree-il tree-il)
 257   (record-case tree-il
 258     ((<void>)
 259      '(void))
 260
 261     ((<call> proc args)
 262      `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 263
 264     ((<primcall> name args)
 265      `(primcall ,name ,@(map unparse-tree-il args)))
 266
 267     ((<conditional> test consequent alternate)
 268      `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
 269
 270     ((<primitive-ref> name)
 271      `(primitive ,name))
 272
 273     ((<lexical-ref> name gensym)
 274      `(lexical ,name ,gensym))
 275
 276     ((<lexical-set> name gensym exp)
 277      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 278
 279     ((<module-ref> mod name public?)
 280      `(,(if public? '@ '@@) ,mod ,name))
 281
 282     ((<module-set> mod name public? exp)
 283      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 284
 285     ((<toplevel-ref> name)
 286      `(toplevel ,name))
 287
 288     ((<toplevel-set> name exp)
 289      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 290
 291     ((<toplevel-define> name exp)
 292      `(define ,name ,(unparse-tree-il exp)))
 293
 294     ((<lambda> meta body)
 295      `(lambda ,meta ,(unparse-tree-il body)))
 296
 297     ((<lambda-case> req opt rest kw inits gensyms body alternate)
 298      `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
 299                     ,(unparse-tree-il body))
 300                    . ,(if alternate (list (unparse-tree-il alternate)) '())))
 301
 302     ((<const> exp)
 303      `(const ,exp))
 304
 305     ((<sequence> exps)
 306      `(begin ,@(map unparse-tree-il exps)))
 307
 308     ((<let> names gensyms vals body)
 309      `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 310
 311     ((<letrec> in-order? names gensyms vals body)
 312      `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
 313        ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 314
 315     ((<fix> names gensyms vals body)
 316      `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 317
 318     ((<let-values> exp body)
 319      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 320
 321     ((<dynwind> body winder unwinder)
 322      `(dynwind ,(unparse-tree-il body)
 323                ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
 324
 325     ((<dynlet> fluids vals body)
 326      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
 327               ,(unparse-tree-il body)))
 328
 329     ((<dynref> fluid)
 330      `(dynref ,(unparse-tree-il fluid)))
 331
 332     ((<dynset> fluid exp)
 333      `(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
 334
 335     ((<prompt> tag body handler)
 336      `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
 337
 338     ((<abort> tag args tail)
 339      `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
 340              ,(unparse-tree-il tail)))))
 341
 342 (define (tree-il->scheme e)
 343   (record-case e
 344     ((<void>)
 345      '(if #f #f))
 346
 347     ((<call> proc args)
 348      `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 349
 350     ((<primcall> name args)
 351      `(,name ,@(map tree-il->scheme args)))
 352
 353     ((<conditional> test consequent alternate)
 354      (if (void? alternate)
 355          `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
 356          `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate))))
 357
 358     ((<primitive-ref> name)
 359      name)
 360
 361     ((<lexical-ref> gensym)
 362      gensym)
 363
 364     ((<lexical-set> gensym exp)
 365      `(set! ,gensym ,(tree-il->scheme exp)))
 366
 367     ((<module-ref> mod name public?)
 368      `(,(if public? '@ '@@) ,mod ,name))
 369
 370     ((<module-set> mod name public? exp)
 371      `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
 372
 373     ((<toplevel-ref> name)
 374      name)
 375
 376     ((<toplevel-set> name exp)
 377      `(set! ,name ,(tree-il->scheme exp)))
 378
 379     ((<toplevel-define> name exp)
 380      `(define ,name ,(tree-il->scheme exp)))
 381
 382     ((<lambda> meta body)
 383      ;; fixme: put in docstring
 384      (tree-il->scheme body))
 385
 386     ((<lambda-case> req opt rest kw inits gensyms body alternate)
 387      (cond
 388       ((and (not opt) (not kw) (not alternate))
 389        `(lambda ,(if rest (apply cons* gensyms) gensyms)
 390           ,(tree-il->scheme body)))
 391       ((and (not opt) (not kw))
 392        (let ((alt-expansion (tree-il->scheme alternate))
 393              (formals (if rest (apply cons* gensyms) gensyms)))
 394          (case (car alt-expansion)
 395            ((lambda)
 396             `(case-lambda (,formals ,(tree-il->scheme body))
 397                           ,@(cdr alt-expansion)))
 398            ((lambda*)
 399             `(case-lambda* (,formals ,(tree-il->scheme body))
 400                            ,(cdr alt-expansion)))
 401            ((case-lambda)
 402             `(case-lambda (,formals ,(tree-il->scheme body))
 403                           ,@(cdr alt-expansion)))
 404            ((case-lambda*)
 405             `(case-lambda* (,formals ,(tree-il->scheme body))
 406                            ,@(cdr alt-expansion))))))
 407       (else
 408        (let* ((alt-expansion (and alternate (tree-il->scheme alternate)))
 409               (nreq (length req))
 410               (nopt (if opt (length opt) 0))
 411               (restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
 412               (reqargs (list-head gensyms nreq))
 413               (optargs (if opt
 414                            `(#:optional
 415                              ,@(map list
 416                                     (list-head (list-tail gensyms nreq) nopt)
 417                                     (map tree-il->scheme
 418                                          (list-head inits nopt))))
 419                            '()))
 420               (kwargs (if kw
 421                           `(#:key
 422                             ,@(map list
 423                                    (map caddr (cdr kw))
 424                                    (map tree-il->scheme
 425                                         (list-tail inits nopt))
 426                                    (map car (cdr kw)))
 427                             ,@(if (car kw)
 428                                   '(#:allow-other-keys)
 429                                   '()))
 430                           '()))
 431               (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
 432          (if (not alt-expansion)
 433              `(lambda* ,formals ,(tree-il->scheme body))
 434              (case (car alt-expansion)
 435                ((lambda lambda*)
 436                 `(case-lambda* (,formals ,(tree-il->scheme body))
 437                                ,(cdr alt-expansion)))
 438                ((case-lambda case-lambda*)
 439                 `(case-lambda* (,formals ,(tree-il->scheme body))
 440                                ,@(cdr alt-expansion)))))))))
 441
 442     ((<const> exp)
 443      (if (and (self-evaluating? exp) (not (vector? exp)))
 444          exp
 445          (list 'quote exp)))
 446
 447     ((<sequence> exps)
 448      `(begin ,@(map tree-il->scheme exps)))
 449
 450     ((<let> gensyms vals body)
 451      `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 452
 453     ((<letrec> in-order? gensyms vals body)
 454      `(,(if in-order? 'letrec* 'letrec)
 455        ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 456
 457     ((<fix> gensyms vals body)
 458      ;; not a typo, we really do translate back to letrec. use letrec* since it
 459      ;; doesn't matter, and the naive letrec* transformation does not require an
 460      ;; inner let.
 461      `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 462
 463     ((<let-values> exp body)
 464      `(call-with-values (lambda () ,(tree-il->scheme exp))
 465         ,(tree-il->scheme (make-lambda #f '() body))))
 466
 467     ((<dynwind> body winder unwinder)
 468      `(dynamic-wind ,(tree-il->scheme winder)
 469                     (lambda () ,(tree-il->scheme body))
 470                     ,(tree-il->scheme unwinder)))
 471
 472     ((<dynlet> fluids vals body)
 473      `(with-fluids ,(map list
 474                          (map tree-il->scheme fluids)
 475                          (map tree-il->scheme vals))
 476         ,(tree-il->scheme body)))
 477
 478     ((<dynref> fluid)
 479      `(fluid-ref ,(tree-il->scheme fluid)))
 480
 481     ((<dynset> fluid exp)
 482      `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
 483
 484     ((<prompt> tag body handler)
 485      `(call-with-prompt
 486        ,(tree-il->scheme tag)
 487        (lambda () ,(tree-il->scheme body))
 488        ,(tree-il->scheme handler)))
 489
 490
 491     ((<abort> tag args tail)
 492      `(apply abort-to-prompt
 493              ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
 494              ,(tree-il->scheme tail)))))
 495
 496 \f
 497 (define (tree-il-fold leaf down up seed tree)
 498   "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
 499 into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
 500 invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
 501 and SEED is the current result, intially seeded with SEED.
 502
 503 This is an implementation of `foldts' as described by Andy Wingo in
 504 ``Calls of fold to XML transformation''."
 505   (let loop ((tree   tree)
 506              (result seed))
 507     (if (or (null? tree) (pair? tree))
 508         (fold loop result tree)
 509         (record-case tree
 510           ((<lexical-set> exp)
 511            (up tree (loop exp (down tree result))))
 512           ((<module-set> exp)
 513            (up tree (loop exp (down tree result))))
 514           ((<toplevel-set> exp)
 515            (up tree (loop exp (down tree result))))
 516           ((<toplevel-define> exp)
 517            (up tree (loop exp (down tree result))))
 518           ((<conditional> test consequent alternate)
 519            (up tree (loop alternate
 520                           (loop consequent
 521                                 (loop test (down tree result))))))
 522           ((<call> proc args)
 523            (up tree (loop (cons proc args) (down tree result))))
 524           ((<primcall> name args)
 525            (up tree (loop args (down tree result))))
 526           ((<sequence> exps)
 527            (up tree (loop exps (down tree result))))
 528           ((<lambda> body)
 529            (up tree (loop body (down tree result))))
 530           ((<lambda-case> inits body alternate)
 531            (up tree (if alternate
 532                         (loop alternate
 533                               (loop body (loop inits (down tree result))))
 534                         (loop body (loop inits (down tree result))))))
 535           ((<let> vals body)
 536            (up tree (loop body
 537                           (loop vals
 538                                 (down tree result)))))
 539           ((<letrec> vals body)
 540            (up tree (loop body
 541                           (loop vals
 542                                 (down tree result)))))
 543           ((<fix> vals body)
 544            (up tree (loop body
 545                           (loop vals
 546                                 (down tree result)))))
 547           ((<let-values> exp body)
 548            (up tree (loop body (loop exp (down tree result)))))
 549           ((<dynwind> body winder unwinder)
 550            (up tree (loop unwinder
 551                           (loop winder
 552                                 (loop body (down tree result))))))
 553           ((<dynlet> fluids vals body)
 554            (up tree (loop body
 555                           (loop vals
 556                                 (loop fluids (down tree result))))))
 557           ((<dynref> fluid)
 558            (up tree (loop fluid (down tree result))))
 559           ((<dynset> fluid exp)
 560            (up tree (loop exp (loop fluid (down tree result)))))
 561           ((<prompt> tag body handler)
 562            (up tree
 563                (loop tag (loop body (loop handler
 564                                           (down tree result))))))
 565           ((<abort> tag args tail)
 566            (up tree (loop tail (loop args (loop tag (down tree result))))))
 567           (else
 568            (leaf tree result))))))
 569
 570
 571 (define-syntax make-tree-il-folder
 572   (syntax-rules ()
 573     ((_ seed ...)
 574      (lambda (tree down up seed ...)
 575        (define (fold-values proc exps seed ...)
 576          (if (null? exps)
 577              (values seed ...)
 578              (let-values (((seed ...) (proc (car exps) seed ...)))
 579                (fold-values proc (cdr exps) seed ...))))
 580        (let foldts ((tree tree) (seed seed) ...)
 581          (let*-values
 582              (((seed ...) (down tree seed ...))
 583               ((seed ...)
 584                (record-case tree
 585                  ((<lexical-set> exp)
 586                   (foldts exp seed ...))
 587                  ((<module-set> exp)
 588                   (foldts exp seed ...))
 589                  ((<toplevel-set> exp)
 590                   (foldts exp seed ...))
 591                  ((<toplevel-define> exp)
 592                   (foldts exp seed ...))
 593                  ((<conditional> test consequent alternate)
 594                   (let*-values (((seed ...) (foldts test seed ...))
 595                                 ((seed ...) (foldts consequent seed ...)))
 596                     (foldts alternate seed ...)))
 597                  ((<call> proc args)
 598                   (let-values (((seed ...) (foldts proc seed ...)))
 599                     (fold-values foldts args seed ...)))
 600                  ((<primcall> name args)
 601                   (fold-values foldts args seed ...))
 602                  ((<sequence> exps)
 603                   (fold-values foldts exps seed ...))
 604                  ((<lambda> body)
 605                   (foldts body seed ...))
 606                  ((<lambda-case> inits body alternate)
 607                   (let-values (((seed ...) (fold-values foldts inits seed ...)))
 608                     (if alternate
 609                         (let-values (((seed ...) (foldts body seed ...)))
 610                           (foldts alternate seed ...))
 611                         (foldts body seed ...))))
 612                  ((<let> vals body)
 613                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 614                     (foldts body seed ...)))
 615                  ((<letrec> vals body)
 616                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 617                     (foldts body seed ...)))
 618                  ((<fix> vals body)
 619                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 620                     (foldts body seed ...)))
 621                  ((<let-values> exp body)
 622                   (let*-values (((seed ...) (foldts exp seed ...)))
 623                     (foldts body seed ...)))
 624                  ((<dynwind> body winder unwinder)
 625                   (let*-values (((seed ...) (foldts body seed ...))
 626                                 ((seed ...) (foldts winder seed ...)))
 627                     (foldts unwinder seed ...)))
 628                  ((<dynlet> fluids vals body)
 629                   (let*-values (((seed ...) (fold-values foldts fluids seed ...))
 630                                 ((seed ...) (fold-values foldts vals seed ...)))
 631                     (foldts body seed ...)))
 632                  ((<dynref> fluid)
 633                   (foldts fluid seed ...))
 634                  ((<dynset> fluid exp)
 635                   (let*-values (((seed ...) (foldts fluid seed ...)))
 636                     (foldts exp seed ...)))
 637                  ((<prompt> tag body handler)
 638                   (let*-values (((seed ...) (foldts tag seed ...))
 639                                 ((seed ...) (foldts body seed ...)))
 640                     (foldts handler seed ...)))
 641                  ((<abort> tag args tail)
 642                   (let*-values (((seed ...) (foldts tag seed ...))
 643                                 ((seed ...) (fold-values foldts args seed ...)))
 644                     (foldts tail seed ...)))
 645                  (else
 646                   (values seed ...)))))
 647            (up tree seed ...)))))))
 648
 649 (define (post-order! f x)
 650   (let lp ((x x))
 651     (record-case x
 652       ((<call> proc args)
 653        (set! (call-proc x) (lp proc))
 654        (set! (call-args x) (map lp args)))
 655
 656       ((<primcall> name args)
 657        (set! (primcall-args x) (map lp args)))
 658
 659       ((<conditional> test consequent alternate)
 660        (set! (conditional-test x) (lp test))
 661        (set! (conditional-consequent x) (lp consequent))
 662        (set! (conditional-alternate x) (lp alternate)))
 663
 664       ((<lexical-set> name gensym exp)
 665        (set! (lexical-set-exp x) (lp exp)))
 666
 667       ((<module-set> mod name public? exp)
 668        (set! (module-set-exp x) (lp exp)))
 669
 670       ((<toplevel-set> name exp)
 671        (set! (toplevel-set-exp x) (lp exp)))
 672
 673       ((<toplevel-define> name exp)
 674        (set! (toplevel-define-exp x) (lp exp)))
 675
 676       ((<lambda> body)
 677        (set! (lambda-body x) (lp body)))
 678
 679       ((<lambda-case> inits body alternate)
 680        (set! inits (map lp inits))
 681        (set! (lambda-case-body x) (lp body))
 682        (if alternate
 683            (set! (lambda-case-alternate x) (lp alternate))))
 684
 685       ((<sequence> exps)
 686        (set! (sequence-exps x) (map lp exps)))
 687
 688       ((<let> gensyms vals body)
 689        (set! (let-vals x) (map lp vals))
 690        (set! (let-body x) (lp body)))
 691
 692       ((<letrec> gensyms vals body)
 693        (set! (letrec-vals x) (map lp vals))
 694        (set! (letrec-body x) (lp body)))
 695
 696       ((<fix> gensyms vals body)
 697        (set! (fix-vals x) (map lp vals))
 698        (set! (fix-body x) (lp body)))
 699
 700       ((<let-values> exp body)
 701        (set! (let-values-exp x) (lp exp))
 702        (set! (let-values-body x) (lp body)))
 703
 704       ((<dynwind> body winder unwinder)
 705        (set! (dynwind-body x) (lp body))
 706        (set! (dynwind-winder x) (lp winder))
 707        (set! (dynwind-unwinder x) (lp unwinder)))
 708
 709       ((<dynlet> fluids vals body)
 710        (set! (dynlet-fluids x) (map lp fluids))
 711        (set! (dynlet-vals x) (map lp vals))
 712        (set! (dynlet-body x) (lp body)))
 713
 714       ((<dynref> fluid)
 715        (set! (dynref-fluid x) (lp fluid)))
 716
 717       ((<dynset> fluid exp)
 718        (set! (dynset-fluid x) (lp fluid))
 719        (set! (dynset-exp x) (lp exp)))
 720
 721       ((<prompt> tag body handler)
 722        (set! (prompt-tag x) (lp tag))
 723        (set! (prompt-body x) (lp body))
 724        (set! (prompt-handler x) (lp handler)))
 725
 726       ((<abort> tag args tail)
 727        (set! (abort-tag x) (lp tag))
 728        (set! (abort-args x) (map lp args))
 729        (set! (abort-tail x) (lp tail)))
 730
 731       (else #f))
 732
 733     (or (f x) x)))
 734
 735 (define (pre-order! f x)
 736   (let lp ((x x))
 737     (let ((x (or (f x) x)))
 738       (record-case x
 739         ((<call> proc args)
 740          (set! (call-proc x) (lp proc))
 741          (set! (call-args x) (map lp args)))
 742
 743         ((<primcall> name args)
 744          (set! (primcall-args x) (map lp args)))
 745
 746         ((<conditional> test consequent alternate)
 747          (set! (conditional-test x) (lp test))
 748          (set! (conditional-consequent x) (lp consequent))
 749          (set! (conditional-alternate x) (lp alternate)))
 750
 751         ((<lexical-set> exp)
 752          (set! (lexical-set-exp x) (lp exp)))
 753
 754         ((<module-set> exp)
 755          (set! (module-set-exp x) (lp exp)))
 756
 757         ((<toplevel-set> exp)
 758          (set! (toplevel-set-exp x) (lp exp)))
 759
 760         ((<toplevel-define> exp)
 761          (set! (toplevel-define-exp x) (lp exp)))
 762
 763         ((<lambda> body)
 764          (set! (lambda-body x) (lp body)))
 765
 766         ((<lambda-case> inits body alternate)
 767          (set! inits (map lp inits))
 768          (set! (lambda-case-body x) (lp body))
 769          (if alternate (set! (lambda-case-alternate x) (lp alternate))))
 770
 771         ((<sequence> exps)
 772          (set! (sequence-exps x) (map lp exps)))
 773
 774         ((<let> vals body)
 775          (set! (let-vals x) (map lp vals))
 776          (set! (let-body x) (lp body)))
 777
 778         ((<letrec> vals body)
 779          (set! (letrec-vals x) (map lp vals))
 780          (set! (letrec-body x) (lp body)))
 781
 782         ((<fix> vals body)
 783          (set! (fix-vals x) (map lp vals))
 784          (set! (fix-body x) (lp body)))
 785
 786         ((<let-values> exp body)
 787          (set! (let-values-exp x) (lp exp))
 788          (set! (let-values-body x) (lp body)))
 789
 790         ((<dynwind> body winder unwinder)
 791          (set! (dynwind-body x) (lp body))
 792          (set! (dynwind-winder x) (lp winder))
 793          (set! (dynwind-unwinder x) (lp unwinder)))
 794
 795         ((<dynlet> fluids vals body)
 796          (set! (dynlet-fluids x) (map lp fluids))
 797          (set! (dynlet-vals x) (map lp vals))
 798          (set! (dynlet-body x) (lp body)))
 799
 800         ((<dynref> fluid)
 801          (set! (dynref-fluid x) (lp fluid)))
 802
 803         ((<dynset> fluid exp)
 804          (set! (dynset-fluid x) (lp fluid))
 805          (set! (dynset-exp x) (lp exp)))
 806
 807         ((<prompt> tag body handler)
 808          (set! (prompt-tag x) (lp tag))
 809          (set! (prompt-body x) (lp body))
 810          (set! (prompt-handler x) (lp handler)))
 811
 812         ((<abort> tag args tail)
 813          (set! (abort-tag x) (lp tag))
 814          (set! (abort-args x) (map lp args))
 815          (set! (abort-tail x) (lp tail)))
 816
 817         (else #f))
 818       x)))