module/language/tree-il.scm

   1 ;;;;    Copyright (C) 2009, 2010 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-vars
  43                           lambda-case-body lambda-case-alternate
  44             <let> let? make-let let-src let-names let-vars let-vals let-body
  45             <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-body
  46             <fix> fix? make-fix fix-src fix-names fix-vars 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             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
  51             <control> control? make-control control-src control-tag control-type control-args
  52
  53             parse-tree-il
  54             unparse-tree-il
  55             tree-il->scheme
  56
  57             tree-il-fold
  58             make-tree-il-folder
  59             post-order!
  60             pre-order!))
  61
  62 (define-type (<tree-il> #:common-slots (src))
  63   (<void>)
  64   (<const> exp)
  65   (<primitive-ref> name)
  66   (<lexical-ref> name gensym)
  67   (<lexical-set> name gensym exp)
  68   (<module-ref> mod name public?)
  69   (<module-set> mod name public? exp)
  70   (<toplevel-ref> name)
  71   (<toplevel-set> name exp)
  72   (<toplevel-define> name exp)
  73   (<conditional> test consequent alternate)
  74   (<application> proc args)
  75   (<sequence> exps)
  76   (<lambda> meta body)
  77   (<lambda-case> req opt rest kw inits vars body alternate)
  78   (<let> names vars vals body)
  79   (<letrec> names vars vals body)
  80   (<fix> names vars vals body)
  81   (<let-values> exp body)
  82   (<dynwind> winder body unwinder)
  83   (<dynlet> fluids vals body)
  84   (<prompt> tag body handler)
  85   (<control> tag type args))
  86
  87 \f
  88
  89 (define (location x)
  90   (and (pair? x)
  91        (let ((props (source-properties x)))
  92          (and (pair? props) props))))
  93
  94 (define (parse-tree-il exp)
  95   (let ((loc (location exp))
  96         (retrans (lambda (x) (parse-tree-il x))))
  97     (pmatch exp
  98      ((void)
  99       (make-void loc))
 100
 101      ((apply ,proc . ,args)
 102       (make-application loc (retrans proc) (map retrans args)))
 103
 104      ((if ,test ,consequent ,alternate)
 105       (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
 106
 107      ((primitive ,name) (guard (symbol? name))
 108       (make-primitive-ref loc name))
 109
 110      ((lexical ,name) (guard (symbol? name))
 111       (make-lexical-ref loc name name))
 112
 113      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
 114       (make-lexical-ref loc name sym))
 115
 116      ((set! (lexical ,name) ,exp) (guard (symbol? name))
 117       (make-lexical-set loc name name (retrans exp)))
 118
 119      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
 120       (make-lexical-set loc name sym (retrans exp)))
 121
 122      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 123       (make-module-ref loc mod name #t))
 124
 125      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 126       (make-module-set loc mod name #t (retrans exp)))
 127
 128      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 129       (make-module-ref loc mod name #f))
 130
 131      ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 132       (make-module-set loc mod name #f (retrans exp)))
 133
 134      ((toplevel ,name) (guard (symbol? name))
 135       (make-toplevel-ref loc name))
 136
 137      ((set! (toplevel ,name) ,exp) (guard (symbol? name))
 138       (make-toplevel-set loc name (retrans exp)))
 139
 140      ((define ,name ,exp) (guard (symbol? name))
 141       (make-toplevel-define loc name (retrans exp)))
 142
 143      ((lambda ,meta ,body)
 144       (make-lambda loc meta (retrans body)))
 145
 146      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate)
 147       (make-lambda-case loc req opt rest kw
 148                         (map retrans inits) vars
 149                         (retrans body)
 150                         (and=> alternate retrans)))
 151
 152      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
 153       (make-lambda-case loc req opt rest kw
 154                         (map retrans inits) vars
 155                         (retrans body)
 156                         #f))
 157
 158      ((const ,exp)
 159       (make-const loc exp))
 160
 161      ((begin . ,exps)
 162       (make-sequence loc (map retrans exps)))
 163
 164      ((let ,names ,vars ,vals ,body)
 165       (make-let loc names vars (map retrans vals) (retrans body)))
 166
 167      ((letrec ,names ,vars ,vals ,body)
 168       (make-letrec loc names vars (map retrans vals) (retrans body)))
 169
 170      ((fix ,names ,vars ,vals ,body)
 171       (make-fix loc names vars (map retrans vals) (retrans body)))
 172
 173      ((let-values ,exp ,body)
 174       (make-let-values loc (retrans exp) (retrans body)))
 175
 176      ((dynwind ,winder ,body ,unwinder)
 177       (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
 178
 179      ((dynlet ,fluids ,vals ,body)
 180       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
 181
 182      ((prompt ,tag ,body ,handler)
 183       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
 184
 185      ((control ,tag ,type ,args)
 186       (make-control loc (retrans tag) type (map retrans args)))
 187
 188      (else
 189       (error "unrecognized tree-il" exp)))))
 190
 191 (define (unparse-tree-il tree-il)
 192   (record-case tree-il
 193     ((<void>)
 194      '(void))
 195
 196     ((<application> proc args)
 197      `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 198
 199     ((<conditional> test consequent alternate)
 200      `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
 201
 202     ((<primitive-ref> name)
 203      `(primitive ,name))
 204
 205     ((<lexical-ref> name gensym)
 206      `(lexical ,name ,gensym))
 207
 208     ((<lexical-set> name gensym exp)
 209      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 210
 211     ((<module-ref> mod name public?)
 212      `(,(if public? '@ '@@) ,mod ,name))
 213
 214     ((<module-set> mod name public? exp)
 215      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 216
 217     ((<toplevel-ref> name)
 218      `(toplevel ,name))
 219
 220     ((<toplevel-set> name exp)
 221      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 222
 223     ((<toplevel-define> name exp)
 224      `(define ,name ,(unparse-tree-il exp)))
 225
 226     ((<lambda> meta body)
 227      `(lambda ,meta ,(unparse-tree-il body)))
 228
 229     ((<lambda-case> req opt rest kw inits vars body alternate)
 230      `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
 231                     ,(unparse-tree-il body))
 232                    . ,(if alternate (list (unparse-tree-il alternate)) '())))
 233
 234     ((<const> exp)
 235      `(const ,exp))
 236
 237     ((<sequence> exps)
 238      `(begin ,@(map unparse-tree-il exps)))
 239
 240     ((<let> names vars vals body)
 241      `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 242
 243     ((<letrec> names vars vals body)
 244      `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 245
 246     ((<fix> names vars vals body)
 247      `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 248
 249     ((<let-values> exp body)
 250      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 251
 252     ((<dynwind> body winder unwinder)
 253      `(dynwind ,(unparse-tree-il body)
 254                ,(unparse-tree-il winder) ,(unparse-tree-il unwinder)))
 255
 256     ((<dynlet> fluids vals body)
 257      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
 258               ,(unparse-tree-il body)))
 259
 260     ((<prompt> tag body handler)
 261      `(prompt ,tag ,(unparse-tree-il body) ,(unparse-tree-il handler)))
 262
 263     ((<control> tag type args)
 264      `(control ,(unparse-tree-il tag) ,type ,(map unparse-tree-il args)))))
 265
 266 (define (tree-il->scheme e)
 267   (record-case e
 268     ((<void>)
 269      '(if #f #f))
 270
 271     ((<application> proc args)
 272      `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
 273
 274     ((<conditional> test consequent alternate)
 275      (if (void? alternate)
 276          `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
 277          `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate))))
 278
 279     ((<primitive-ref> name)
 280      name)
 281
 282     ((<lexical-ref> gensym)
 283      gensym)
 284
 285     ((<lexical-set> gensym exp)
 286      `(set! ,gensym ,(tree-il->scheme exp)))
 287
 288     ((<module-ref> mod name public?)
 289      `(,(if public? '@ '@@) ,mod ,name))
 290
 291     ((<module-set> mod name public? exp)
 292      `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
 293
 294     ((<toplevel-ref> name)
 295      name)
 296
 297     ((<toplevel-set> name exp)
 298      `(set! ,name ,(tree-il->scheme exp)))
 299
 300     ((<toplevel-define> name exp)
 301      `(define ,name ,(tree-il->scheme exp)))
 302
 303     ((<lambda> meta body)
 304      ;; fixme: put in docstring
 305      (if (and (lambda-case? body)
 306               (not (lambda-case-alternate body)))
 307          `(lambda ,@(car (tree-il->scheme body)))
 308          `(case-lambda ,@(tree-il->scheme body))))
 309
 310     ((<lambda-case> req opt rest kw inits vars body alternate)
 311      ;; FIXME! use parse-lambda-case?
 312      `((,(if rest (apply cons* vars) vars)
 313         ,(tree-il->scheme body))
 314        ,@(if alternate (tree-il->scheme alternate) '())))
 315
 316     ((<const> exp)
 317      (if (and (self-evaluating? exp) (not (vector? exp)))
 318          exp
 319          (list 'quote exp)))
 320
 321     ((<sequence> exps)
 322      `(begin ,@(map tree-il->scheme exps)))
 323
 324     ((<let> vars vals body)
 325      `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 326
 327     ((<letrec> vars vals body)
 328      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 329
 330     ((<fix> vars vals body)
 331      ;; not a typo, we really do translate back to letrec
 332      `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme body)))
 333
 334     ((<let-values> exp body)
 335      `(call-with-values (lambda () ,(tree-il->scheme exp))
 336         ,(tree-il->scheme (make-lambda #f '() body))))
 337
 338     ((<dynwind> body winder unwinder)
 339      `(dynamic-wind ,(tree-il->scheme winder)
 340                     (lambda () ,(tree-il->scheme body))
 341                     ,(tree-il->scheme unwinder)))
 342
 343     ((<dynlet> fluids vals body)
 344      `(with-fluids ,(map list
 345                          (map tree-il->scheme fluids)
 346                          (map tree-il->scheme vals))
 347         ,(tree-il->scheme body)))
 348
 349     ((<prompt> tag body handler)
 350      `((@ (ice-9 control) prompt)
 351        ,(tree-il->scheme tag) (lambda () ,(tree-il->scheme body))
 352        ,(tree-il->scheme handler)))
 353
 354
 355     ((<control> tag type args)
 356      (case type
 357        ((throw) `(throw ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))
 358        (else (error "bad control type" type))))))
 359
 360 \f
 361 (define (tree-il-fold leaf down up seed tree)
 362   "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
 363 into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
 364 invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
 365 and SEED is the current result, intially seeded with SEED.
 366
 367 This is an implementation of `foldts' as described by Andy Wingo in
 368 ``Applications of fold to XML transformation''."
 369   (let loop ((tree   tree)
 370              (result seed))
 371     (if (or (null? tree) (pair? tree))
 372         (fold loop result tree)
 373         (record-case tree
 374           ((<lexical-set> exp)
 375            (up tree (loop exp (down tree result))))
 376           ((<module-set> exp)
 377            (up tree (loop exp (down tree result))))
 378           ((<toplevel-set> exp)
 379            (up tree (loop exp (down tree result))))
 380           ((<toplevel-define> exp)
 381            (up tree (loop exp (down tree result))))
 382           ((<conditional> test consequent alternate)
 383            (up tree (loop alternate
 384                           (loop consequent
 385                                 (loop test (down tree result))))))
 386           ((<application> proc args)
 387            (up tree (loop (cons proc args) (down tree result))))
 388           ((<sequence> exps)
 389            (up tree (loop exps (down tree result))))
 390           ((<lambda> body)
 391            (up tree (loop body (down tree result))))
 392           ((<lambda-case> inits body alternate)
 393            (up tree (if alternate
 394                         (loop alternate
 395                               (loop body (loop inits (down tree result))))
 396                         (loop body (loop inits (down tree result))))))
 397           ((<let> vals body)
 398            (up tree (loop body
 399                           (loop vals
 400                                 (down tree result)))))
 401           ((<letrec> vals body)
 402            (up tree (loop body
 403                           (loop vals
 404                                 (down tree result)))))
 405           ((<fix> vals body)
 406            (up tree (loop body
 407                           (loop vals
 408                                 (down tree result)))))
 409           ((<let-values> exp body)
 410            (up tree (loop body (loop exp (down tree result)))))
 411           ((<dynwind> body winder unwinder)
 412            (up tree (loop unwinder
 413                           (loop winder
 414                                 (loop body (down tree result))))))
 415           ((<dynlet> fluids vals body)
 416            (up tree (loop body
 417                           (loop vals
 418                                 (loop fluids (down tree result))))))
 419           ((<prompt> tag body handler)
 420            (up tree
 421                (loop tag (loop body (loop handler
 422                                           (down tree result))))))
 423           ((<control> tag type args)
 424            (up tree (loop tag (loop args (down tree result)))))
 425           (else
 426            (leaf tree result))))))
 427
 428
 429 (define-syntax make-tree-il-folder
 430   (syntax-rules ()
 431     ((_ seed ...)
 432      (lambda (tree down up seed ...)
 433        (define (fold-values proc exps seed ...)
 434          (if (null? exps)
 435              (values seed ...)
 436              (let-values (((seed ...) (proc (car exps) seed ...)))
 437                (fold-values proc (cdr exps) seed ...))))
 438        (let foldts ((tree tree) (seed seed) ...)
 439          (let*-values
 440              (((seed ...) (down tree seed ...))
 441               ((seed ...)
 442                (record-case tree
 443                  ((<lexical-set> exp)
 444                   (foldts exp seed ...))
 445                  ((<module-set> exp)
 446                   (foldts exp seed ...))
 447                  ((<toplevel-set> exp)
 448                   (foldts exp seed ...))
 449                  ((<toplevel-define> exp)
 450                   (foldts exp seed ...))
 451                  ((<conditional> test consequent alternate)
 452                   (let*-values (((seed ...) (foldts test seed ...))
 453                                 ((seed ...) (foldts consequent seed ...)))
 454                     (foldts alternate seed ...)))
 455                  ((<application> proc args)
 456                   (let-values (((seed ...) (foldts proc seed ...)))
 457                     (fold-values foldts args seed ...)))
 458                  ((<sequence> exps)
 459                   (fold-values foldts exps seed ...))
 460                  ((<lambda> body)
 461                   (foldts body seed ...))
 462                  ((<lambda-case> inits body alternate)
 463                   (let-values (((seed ...) (fold-values foldts inits seed ...)))
 464                     (if alternate
 465                         (let-values (((seed ...) (foldts body seed ...)))
 466                           (foldts alternate seed ...))
 467                         (foldts body seed ...))))
 468                  ((<let> vals body)
 469                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 470                     (foldts body seed ...)))
 471                  ((<letrec> vals body)
 472                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 473                     (foldts body seed ...)))
 474                  ((<fix> vals body)
 475                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 476                     (foldts body seed ...)))
 477                  ((<let-values> exp body)
 478                   (let*-values (((seed ...) (foldts exp seed ...)))
 479                     (foldts body seed ...)))
 480                  ((<dynwind> body winder unwinder)
 481                   (let*-values (((seed ...) (foldts body seed ...))
 482                                 ((seed ...) (foldts winder seed ...)))
 483                     (foldts unwinder seed ...)))
 484                  ((<dynlet> fluids vals body)
 485                   (let*-values (((seed ...) (fold-values foldts fluids seed ...))
 486                                 ((seed ...) (fold-values foldts vals seed ...)))
 487                     (foldts body seed ...)))
 488                  ((<prompt> tag body handler)
 489                   (let*-values (((seed ...) (foldts tag seed ...))
 490                                 ((seed ...) (foldts body seed ...)))
 491                     (foldts handler seed ...)))
 492                  ((<control> tag args)
 493                   (let*-values (((seed ...) (foldts tag seed ...)))
 494                     (fold-values foldts args seed ...)))
 495                  (else
 496                   (values seed ...)))))
 497            (up tree seed ...)))))))
 498
 499 (define (post-order! f x)
 500   (let lp ((x x))
 501     (record-case x
 502       ((<application> proc args)
 503        (set! (application-proc x) (lp proc))
 504        (set! (application-args x) (map lp args)))
 505
 506       ((<conditional> test consequent alternate)
 507        (set! (conditional-test x) (lp test))
 508        (set! (conditional-consequent x) (lp consequent))
 509        (set! (conditional-alternate x) (lp alternate)))
 510
 511       ((<lexical-set> name gensym exp)
 512        (set! (lexical-set-exp x) (lp exp)))
 513
 514       ((<module-set> mod name public? exp)
 515        (set! (module-set-exp x) (lp exp)))
 516
 517       ((<toplevel-set> name exp)
 518        (set! (toplevel-set-exp x) (lp exp)))
 519
 520       ((<toplevel-define> name exp)
 521        (set! (toplevel-define-exp x) (lp exp)))
 522
 523       ((<lambda> body)
 524        (set! (lambda-body x) (lp body)))
 525
 526       ((<lambda-case> inits body alternate)
 527        (set! inits (map lp inits))
 528        (set! (lambda-case-body x) (lp body))
 529        (if alternate
 530            (set! (lambda-case-alternate x) (lp alternate))))
 531
 532       ((<sequence> exps)
 533        (set! (sequence-exps x) (map lp exps)))
 534
 535       ((<let> vars vals body)
 536        (set! (let-vals x) (map lp vals))
 537        (set! (let-body x) (lp body)))
 538
 539       ((<letrec> vars vals body)
 540        (set! (letrec-vals x) (map lp vals))
 541        (set! (letrec-body x) (lp body)))
 542
 543       ((<fix> vars vals body)
 544        (set! (fix-vals x) (map lp vals))
 545        (set! (fix-body x) (lp body)))
 546
 547       ((<let-values> exp body)
 548        (set! (let-values-exp x) (lp exp))
 549        (set! (let-values-body x) (lp body)))
 550
 551       ((<dynwind> body winder unwinder)
 552        (set! (dynwind-body x) (lp body))
 553        (set! (dynwind-winder x) (lp winder))
 554        (set! (dynwind-unwinder x) (lp unwinder)))
 555
 556       ((<dynlet> fluids vals body)
 557        (set! (dynlet-fluids x) (map lp fluids))
 558        (set! (dynlet-vals x) (map lp vals))
 559        (set! (dynlet-body x) (lp body)))
 560
 561       ((<prompt> tag body handler)
 562        (set! (prompt-tag x) (lp tag))
 563        (set! (prompt-body x) (lp body))
 564        (set! (prompt-handler x) (lp handler)))
 565
 566       ((<control> tag args)
 567        (set! (control-tag x) (lp tag))
 568        (set! (control-args x) (map lp args)))
 569
 570       (else #f))
 571
 572     (or (f x) x)))
 573
 574 (define (pre-order! f x)
 575   (let lp ((x x))
 576     (let ((x (or (f x) x)))
 577       (record-case x
 578         ((<application> proc args)
 579          (set! (application-proc x) (lp proc))
 580          (set! (application-args x) (map lp args)))
 581
 582         ((<conditional> test consequent alternate)
 583          (set! (conditional-test x) (lp test))
 584          (set! (conditional-consequent x) (lp consequent))
 585          (set! (conditional-alternate x) (lp alternate)))
 586
 587         ((<lexical-set> exp)
 588          (set! (lexical-set-exp x) (lp exp)))
 589
 590         ((<module-set> exp)
 591          (set! (module-set-exp x) (lp exp)))
 592
 593         ((<toplevel-set> exp)
 594          (set! (toplevel-set-exp x) (lp exp)))
 595
 596         ((<toplevel-define> exp)
 597          (set! (toplevel-define-exp x) (lp exp)))
 598
 599         ((<lambda> body)
 600          (set! (lambda-body x) (lp body)))
 601
 602         ((<lambda-case> inits body alternate)
 603          (set! inits (map lp inits))
 604          (set! (lambda-case-body x) (lp body))
 605          (if alternate (set! (lambda-case-alternate x) (lp alternate))))
 606
 607         ((<sequence> exps)
 608          (set! (sequence-exps x) (map lp exps)))
 609
 610         ((<let> vals body)
 611          (set! (let-vals x) (map lp vals))
 612          (set! (let-body x) (lp body)))
 613
 614         ((<letrec> vals body)
 615          (set! (letrec-vals x) (map lp vals))
 616          (set! (letrec-body x) (lp body)))
 617
 618         ((<fix> vals body)
 619          (set! (fix-vals x) (map lp vals))
 620          (set! (fix-body x) (lp body)))
 621
 622         ((<let-values> exp body)
 623          (set! (let-values-exp x) (lp exp))
 624          (set! (let-values-body x) (lp body)))
 625
 626         ((<dynwind> body winder unwinder)
 627          (set! (dynwind-body x) (lp body))
 628          (set! (dynwind-winder x) (lp winder))
 629          (set! (dynwind-unwinder x) (lp unwinder)))
 630
 631         ((<dynlet> fluids vals body)
 632          (set! (dynlet-fluids x) (map lp fluids))
 633          (set! (dynlet-vals x) (map lp vals))
 634          (set! (dynlet-body x) (lp body)))
 635
 636         ((<prompt> tag body handler)
 637          (set! (prompt-tag x) (lp tag))
 638          (set! (prompt-body x) (lp body))
 639          (set! (prompt-handler x) (lp handler)))
 640
 641         ((<control> tag args)
 642          (set! (control-tag x) (lp tag))
 643          (set! (control-args x) (map lp args)))
 644
 645         (else #f))
 646       x)))