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