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             <abort> abort? make-abort abort-src abort-tag abort-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   (<abort> tag 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      ((abort ,tag ,type ,args)
 186       (make-abort 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     ((<abort> tag args)
 264      `(abort ,(unparse-tree-il tag) ,(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     ((<abort> tag args)
 356      `(@abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)))))
 357
 358 \f
 359 (define (tree-il-fold leaf down up seed tree)
 360   "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
 361 into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
 362 invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
 363 and SEED is the current result, intially seeded with SEED.
 364
 365 This is an implementation of `foldts' as described by Andy Wingo in
 366 ``Applications of fold to XML transformation''."
 367   (let loop ((tree   tree)
 368              (result seed))
 369     (if (or (null? tree) (pair? tree))
 370         (fold loop result tree)
 371         (record-case tree
 372           ((<lexical-set> exp)
 373            (up tree (loop exp (down tree result))))
 374           ((<module-set> exp)
 375            (up tree (loop exp (down tree result))))
 376           ((<toplevel-set> exp)
 377            (up tree (loop exp (down tree result))))
 378           ((<toplevel-define> exp)
 379            (up tree (loop exp (down tree result))))
 380           ((<conditional> test consequent alternate)
 381            (up tree (loop alternate
 382                           (loop consequent
 383                                 (loop test (down tree result))))))
 384           ((<application> proc args)
 385            (up tree (loop (cons proc args) (down tree result))))
 386           ((<sequence> exps)
 387            (up tree (loop exps (down tree result))))
 388           ((<lambda> body)
 389            (up tree (loop body (down tree result))))
 390           ((<lambda-case> inits body alternate)
 391            (up tree (if alternate
 392                         (loop alternate
 393                               (loop body (loop inits (down tree result))))
 394                         (loop body (loop inits (down tree result))))))
 395           ((<let> vals body)
 396            (up tree (loop body
 397                           (loop vals
 398                                 (down tree result)))))
 399           ((<letrec> vals body)
 400            (up tree (loop body
 401                           (loop vals
 402                                 (down tree result)))))
 403           ((<fix> vals body)
 404            (up tree (loop body
 405                           (loop vals
 406                                 (down tree result)))))
 407           ((<let-values> exp body)
 408            (up tree (loop body (loop exp (down tree result)))))
 409           ((<dynwind> body winder unwinder)
 410            (up tree (loop unwinder
 411                           (loop winder
 412                                 (loop body (down tree result))))))
 413           ((<dynlet> fluids vals body)
 414            (up tree (loop body
 415                           (loop vals
 416                                 (loop fluids (down tree result))))))
 417           ((<prompt> tag body handler)
 418            (up tree
 419                (loop tag (loop body (loop handler
 420                                           (down tree result))))))
 421           ((<abort> tag args)
 422            (up tree (loop tag (loop args (down tree result)))))
 423           (else
 424            (leaf tree result))))))
 425
 426
 427 (define-syntax make-tree-il-folder
 428   (syntax-rules ()
 429     ((_ seed ...)
 430      (lambda (tree down up seed ...)
 431        (define (fold-values proc exps seed ...)
 432          (if (null? exps)
 433              (values seed ...)
 434              (let-values (((seed ...) (proc (car exps) seed ...)))
 435                (fold-values proc (cdr exps) seed ...))))
 436        (let foldts ((tree tree) (seed seed) ...)
 437          (let*-values
 438              (((seed ...) (down tree seed ...))
 439               ((seed ...)
 440                (record-case tree
 441                  ((<lexical-set> exp)
 442                   (foldts exp seed ...))
 443                  ((<module-set> exp)
 444                   (foldts exp seed ...))
 445                  ((<toplevel-set> exp)
 446                   (foldts exp seed ...))
 447                  ((<toplevel-define> exp)
 448                   (foldts exp seed ...))
 449                  ((<conditional> test consequent alternate)
 450                   (let*-values (((seed ...) (foldts test seed ...))
 451                                 ((seed ...) (foldts consequent seed ...)))
 452                     (foldts alternate seed ...)))
 453                  ((<application> proc args)
 454                   (let-values (((seed ...) (foldts proc seed ...)))
 455                     (fold-values foldts args seed ...)))
 456                  ((<sequence> exps)
 457                   (fold-values foldts exps seed ...))
 458                  ((<lambda> body)
 459                   (foldts body seed ...))
 460                  ((<lambda-case> inits body alternate)
 461                   (let-values (((seed ...) (fold-values foldts inits seed ...)))
 462                     (if alternate
 463                         (let-values (((seed ...) (foldts body seed ...)))
 464                           (foldts alternate seed ...))
 465                         (foldts body seed ...))))
 466                  ((<let> vals body)
 467                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 468                     (foldts body seed ...)))
 469                  ((<letrec> vals body)
 470                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 471                     (foldts body seed ...)))
 472                  ((<fix> vals body)
 473                   (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 474                     (foldts body seed ...)))
 475                  ((<let-values> exp body)
 476                   (let*-values (((seed ...) (foldts exp seed ...)))
 477                     (foldts body seed ...)))
 478                  ((<dynwind> body winder unwinder)
 479                   (let*-values (((seed ...) (foldts body seed ...))
 480                                 ((seed ...) (foldts winder seed ...)))
 481                     (foldts unwinder seed ...)))
 482                  ((<dynlet> fluids vals body)
 483                   (let*-values (((seed ...) (fold-values foldts fluids seed ...))
 484                                 ((seed ...) (fold-values foldts vals seed ...)))
 485                     (foldts body seed ...)))
 486                  ((<prompt> tag body handler)
 487                   (let*-values (((seed ...) (foldts tag seed ...))
 488                                 ((seed ...) (foldts body seed ...)))
 489                     (foldts handler seed ...)))
 490                  ((<abort> tag args)
 491                   (let*-values (((seed ...) (foldts tag seed ...)))
 492                     (fold-values foldts args seed ...)))
 493                  (else
 494                   (values seed ...)))))
 495            (up tree seed ...)))))))
 496
 497 (define (post-order! f x)
 498   (let lp ((x x))
 499     (record-case x
 500       ((<application> proc args)
 501        (set! (application-proc x) (lp proc))
 502        (set! (application-args x) (map lp args)))
 503
 504       ((<conditional> test consequent alternate)
 505        (set! (conditional-test x) (lp test))
 506        (set! (conditional-consequent x) (lp consequent))
 507        (set! (conditional-alternate x) (lp alternate)))
 508
 509       ((<lexical-set> name gensym exp)
 510        (set! (lexical-set-exp x) (lp exp)))
 511
 512       ((<module-set> mod name public? exp)
 513        (set! (module-set-exp x) (lp exp)))
 514
 515       ((<toplevel-set> name exp)
 516        (set! (toplevel-set-exp x) (lp exp)))
 517
 518       ((<toplevel-define> name exp)
 519        (set! (toplevel-define-exp x) (lp exp)))
 520
 521       ((<lambda> body)
 522        (set! (lambda-body x) (lp body)))
 523
 524       ((<lambda-case> inits body alternate)
 525        (set! inits (map lp inits))
 526        (set! (lambda-case-body x) (lp body))
 527        (if alternate
 528            (set! (lambda-case-alternate x) (lp alternate))))
 529
 530       ((<sequence> exps)
 531        (set! (sequence-exps x) (map lp exps)))
 532
 533       ((<let> vars vals body)
 534        (set! (let-vals x) (map lp vals))
 535        (set! (let-body x) (lp body)))
 536
 537       ((<letrec> vars vals body)
 538        (set! (letrec-vals x) (map lp vals))
 539        (set! (letrec-body x) (lp body)))
 540
 541       ((<fix> vars vals body)
 542        (set! (fix-vals x) (map lp vals))
 543        (set! (fix-body x) (lp body)))
 544
 545       ((<let-values> exp body)
 546        (set! (let-values-exp x) (lp exp))
 547        (set! (let-values-body x) (lp body)))
 548
 549       ((<dynwind> body winder unwinder)
 550        (set! (dynwind-body x) (lp body))
 551        (set! (dynwind-winder x) (lp winder))
 552        (set! (dynwind-unwinder x) (lp unwinder)))
 553
 554       ((<dynlet> fluids vals body)
 555        (set! (dynlet-fluids x) (map lp fluids))
 556        (set! (dynlet-vals x) (map lp vals))
 557        (set! (dynlet-body x) (lp body)))
 558
 559       ((<prompt> tag body handler)
 560        (set! (prompt-tag x) (lp tag))
 561        (set! (prompt-body x) (lp body))
 562        (set! (prompt-handler x) (lp handler)))
 563
 564       ((<abort> tag args)
 565        (set! (abort-tag x) (lp tag))
 566        (set! (abort-args x) (map lp args)))
 567
 568       (else #f))
 569
 570     (or (f x) x)))
 571
 572 (define (pre-order! f x)
 573   (let lp ((x x))
 574     (let ((x (or (f x) x)))
 575       (record-case x
 576         ((<application> proc args)
 577          (set! (application-proc x) (lp proc))
 578          (set! (application-args x) (map lp args)))
 579
 580         ((<conditional> test consequent alternate)
 581          (set! (conditional-test x) (lp test))
 582          (set! (conditional-consequent x) (lp consequent))
 583          (set! (conditional-alternate x) (lp alternate)))
 584
 585         ((<lexical-set> exp)
 586          (set! (lexical-set-exp x) (lp exp)))
 587
 588         ((<module-set> exp)
 589          (set! (module-set-exp x) (lp exp)))
 590
 591         ((<toplevel-set> exp)
 592          (set! (toplevel-set-exp x) (lp exp)))
 593
 594         ((<toplevel-define> exp)
 595          (set! (toplevel-define-exp x) (lp exp)))
 596
 597         ((<lambda> body)
 598          (set! (lambda-body x) (lp body)))
 599
 600         ((<lambda-case> inits body alternate)
 601          (set! inits (map lp inits))
 602          (set! (lambda-case-body x) (lp body))
 603          (if alternate (set! (lambda-case-alternate x) (lp alternate))))
 604
 605         ((<sequence> exps)
 606          (set! (sequence-exps x) (map lp exps)))
 607
 608         ((<let> vals body)
 609          (set! (let-vals x) (map lp vals))
 610          (set! (let-body x) (lp body)))
 611
 612         ((<letrec> vals body)
 613          (set! (letrec-vals x) (map lp vals))
 614          (set! (letrec-body x) (lp body)))
 615
 616         ((<fix> vals body)
 617          (set! (fix-vals x) (map lp vals))
 618          (set! (fix-body x) (lp body)))
 619
 620         ((<let-values> exp body)
 621          (set! (let-values-exp x) (lp exp))
 622          (set! (let-values-body x) (lp body)))
 623
 624         ((<dynwind> body winder unwinder)
 625          (set! (dynwind-body x) (lp body))
 626          (set! (dynwind-winder x) (lp winder))
 627          (set! (dynwind-unwinder x) (lp unwinder)))
 628
 629         ((<dynlet> fluids vals body)
 630          (set! (dynlet-fluids x) (map lp fluids))
 631          (set! (dynlet-vals x) (map lp vals))
 632          (set! (dynlet-body x) (lp body)))
 633
 634         ((<prompt> tag body handler)
 635          (set! (prompt-tag x) (lp tag))
 636          (set! (prompt-body x) (lp body))
 637          (set! (prompt-handler x) (lp handler)))
 638
 639         ((<abort> tag args)
 640          (set! (abort-tag x) (lp tag))
 641          (set! (abort-args x) (map lp args)))
 642
 643         (else #f))
 644       x)))