oop/goops/save.scm

   1 ;;; installed-scm-file
   2
   3 ;;;;    Copyright (C) 2000, 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation; either version 2, or (at your option)
   8 ;;;; any later version.
   9 ;;;;
  10 ;;;; This program is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 \f
  21
  22 (define-module (oop goops save)
  23   :use-module (oop goops internal)
  24   :use-module (oop goops util)
  25   )
  26
  27 (export save-objects load-objects restore make-unbound
  28         enumerate! enumerate-component!
  29         write-readably write-component write-component-procedure
  30         literal? readable make-readable)
  31
  32 ;;;
  33 ;;; save-objects ALIST PORT [EXCLUDED] [USES]
  34 ;;;
  35 ;;; ALIST ::= ((NAME . OBJECT) ...)
  36 ;;;
  37 ;;; Save OBJECT ... to PORT so that when the data is read and evaluated
  38 ;;; OBJECT ... are re-created under names NAME ... .
  39 ;;; Exclude any references to objects in the list EXCLUDED.
  40 ;;; Add a (use-modules . USES) line to the top of the saved text.
  41 ;;;
  42 ;;; In some instances, when `save-object' doesn't know how to produce
  43 ;;; readable syntax for an object, you can explicitly register read
  44 ;;; syntax for an object using the special form `readable'.
  45 ;;;
  46 ;;; Example:
  47 ;;;
  48 ;;;   The function `foo' produces an object of obscure structure.
  49 ;;;   Only `foo' can construct such objects.  Because of this, an
  50 ;;;   object such as
  51 ;;;
  52 ;;;     (define x (vector 1 (foo)))
  53 ;;;
  54 ;;;   cannot be saved by `save-objects'.  But if you instead write
  55 ;;;
  56 ;;;     (define x (vector 1 (readable (foo))))
  57 ;;;
  58 ;;;   `save-objects' will happily produce the necessary read syntax.
  59 ;;;
  60 ;;; To add new read syntax, hang methods on `enumerate!' and
  61 ;;; `write-readably'.
  62 ;;;
  63 ;;; enumerate! OBJECT ENV
  64 ;;;   Should call `enumerate-component!' (which takes same args) on
  65 ;;;   each component object.  Should return #t if the composite object
  66 ;;;   can be written as a literal.  (`enumerate-component!' returns #t
  67 ;;;   if the component is a literal.
  68 ;;;
  69 ;;; write-readably OBJECT PORT ENV
  70 ;;;   Should write a readable representation of OBJECT to PORT.
  71 ;;;   Should use `write-component' to print each component object.
  72 ;;;   Use `literal?' to decide if a component is a literal.
  73 ;;;
  74 ;;; Utilities:
  75 ;;;
  76 ;;; enumerate-component! OBJECT ENV
  77 ;;;
  78 ;;; write-component OBJECT PATCHER PORT ENV
  79 ;;;   PATCHER is an expression which, when evaluated, stores OBJECT
  80 ;;;   into its current location.
  81 ;;;
  82 ;;;   Example:
  83 ;;;
  84 ;;;     (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
  85 ;;;
  86 ;;;   write-component is a macro.
  87 ;;;
  88 ;;; literal? COMPONENT ENV
  89 ;;;
  90
  91 (define-method (immediate? (o <top>)) #f)
  92
  93 (define-method (immediate? (o <null>)) #t)
  94 (define-method (immediate? (o <number>)) #t)
  95 (define-method (immediate? (o <boolean>)) #t)
  96 (define-method (immediate? (o <symbol>)) #t)
  97 (define-method (immediate? (o <char>)) #t)
  98 (define-method (immediate? (o <keyword>)) #t)
  99
 100 ;;; enumerate! OBJECT ENVIRONMENT
 101 ;;;
 102 ;;; Return #t if object is a literal.
 103 ;;;
 104 (define-method (enumerate! (o <top>) env) #t)
 105
 106 (define-method (write-readably (o <top>) file env)
 107   ;;(goops-error "No read-syntax defined for object `~S'" o)
 108   (write o file) ;doesn't catch bugs, but is much more flexible
 109   )
 110
 111 ;;;
 112 ;;; Readables
 113 ;;;
 114
 115 (if (or (not (defined? 'readables))
 116         (not readables))
 117     (define readables (make-weak-key-hash-table 61)))
 118
 119 (define readable
 120   (procedure->memoizing-macro
 121     (lambda (exp env)
 122       `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
 123
 124 (define (make-readable obj expr)
 125   (hashq-set! readables obj expr)
 126   obj)
 127
 128 (define (readable-expression obj)
 129   `(readable ,(hashq-ref readables obj)))
 130
 131 (define (readable? obj)
 132   (hashq-get-handle readables obj))
 133
 134 ;;;
 135 ;;; Strings
 136 ;;;
 137
 138 (define-method (enumerate! (o <string>) env) #f)
 139
 140 ;;;
 141 ;;; Vectors
 142 ;;;
 143
 144 (define-method (enumerate! (o <vector>) env)
 145   (or (not (vector? o))
 146       (let ((literal? #t))
 147         (array-for-each (lambda (o)
 148                           (if (not (enumerate-component! o env))
 149                               (set! literal? #f)))
 150                         o)
 151         literal?)))
 152
 153 (define-method (write-readably (o <vector>) file env)
 154   (if (not (vector? o))
 155       (write o file)
 156       (let ((n (vector-length o)))
 157         (if (zero? n)
 158             (display "#()" file)
 159             (let ((not-literal? (not (literal? o env))))
 160               (display (if not-literal?
 161                            "(vector "
 162                            "#(")
 163                        file)
 164               (if (and not-literal?
 165                        (literal? (vector-ref o 0) env))
 166                   (display #\' file))
 167               (write-component (vector-ref o 0)
 168                                `(vector-set! ,o 0 ,(vector-ref o 0))
 169                                file
 170                                env)
 171               (do ((i 1 (+ 1 i)))
 172                   ((= i n))
 173                 (display #\space file)
 174                 (if (and not-literal?
 175                          (literal? (vector-ref o i) env))
 176                     (display #\' file))
 177                 (write-component (vector-ref o i)
 178                                  `(vector-set! ,o ,i ,(vector-ref o i))
 179                                  file
 180                                  env))
 181               (display #\) file))))))
 182
 183
 184 ;;;
 185 ;;; Arrays
 186 ;;;
 187
 188 (define-method (enumerate! (o <array>) env)
 189   (enumerate-component! (shared-array-root o) env))
 190
 191 (define (make-mapper array)
 192   (let* ((dims (array-dimensions array))
 193          (n (array-rank array))
 194          (indices (reverse (if (<= n 11)
 195                                (list-tail '(t s r q p n m l k j i)  (- 11 n))
 196                                (let loop ((n n)
 197                                           (ls '()))
 198                                  (if (zero? n)
 199                                      ls
 200                                      (loop (- n 1)
 201                                            (cons (gensym "i") ls))))))))
 202     `(lambda ,indices
 203        (+ ,(shared-array-offset array)
 204           ,@(map (lambda (ind dim inc)
 205                    `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
 206                  indices
 207                  (array-dimensions array)
 208                  (shared-array-increments array))))))
 209
 210 (define (write-array prefix o not-literal? file env)
 211   (letrec ((inner (lambda (n indices)
 212                     (if (not (zero? n))
 213                         (let ((el (apply array-ref o
 214                                          (reverse (cons 0 indices)))))
 215                           (if (and not-literal?
 216                                    (literal? el env))
 217                               (display #\' file))
 218                           (write-component
 219                            el
 220                            `(array-set! ,o ,el ,@indices)
 221                            file
 222                            env)))
 223                     (do ((i 1 (+ 1 i)))
 224                         ((= i n))
 225                       (display #\space file)
 226                       (let ((el (apply array-ref o
 227                                          (reverse (cons i indices)))))
 228                           (if (and not-literal?
 229                                    (literal? el env))
 230                               (display #\' file))
 231                           (write-component
 232                            el
 233                            `(array-set! ,o ,el ,@indices)
 234                            file
 235                            env))))))
 236     (display prefix file)
 237     (let loop ((dims (array-dimensions o))
 238                (indices '()))
 239       (cond ((null? (cdr dims))
 240              (inner (car dims) indices))
 241             (else
 242              (let ((n (car dims)))
 243                (do ((i 0 (+ 1 i)))
 244                    ((= i n))
 245                  (if (> i 0)
 246                      (display #\space file))
 247                  (display prefix file)
 248                  (loop (cdr dims) (cons i indices))
 249                  (display #\) file))))))
 250     (display #\) file)))
 251
 252 (define-method (write-readably (o <array>) file env)
 253   (let ((root (shared-array-root o)))
 254     (cond ((literal? o env)
 255            (if (not (vector? root))
 256                (write o file)
 257                (begin
 258                  (display #\# file)
 259                  (display (array-rank o) file)
 260                  (write-array #\( o #f file env))))
 261           ((binding? root env)
 262            (display "(make-shared-array " file)
 263            (if (literal? root env)
 264                (display #\' file))
 265            (write-component root
 266                             (goops-error "write-readably(<array>): internal error")
 267                             file
 268                             env)
 269            (display #\space file)
 270            (display (make-mapper o) file)
 271            (for-each (lambda (dim)
 272                        (display #\space file)
 273                        (display dim file))
 274                      (array-dimensions o))
 275            (display #\) file))
 276           (else
 277            (display "(list->uniform-array " file)
 278            (display (array-rank o) file)
 279            (display " '() " file)
 280            (write-array "(list " o file env)))))
 281
 282 ;;;
 283 ;;; Pairs
 284 ;;;
 285
 286 ;;; These methods have more complex structure than is required for
 287 ;;; most objects, since they take over some of the logic of
 288 ;;; `write-component'.
 289 ;;;
 290
 291 (define-method (enumerate! (o <pair>) env)
 292   (let ((literal? (enumerate-component! (car o) env)))
 293     (and (enumerate-component! (cdr o) env)
 294          literal?)))
 295
 296 (define-method (write-readably (o <pair>) file env)
 297   (let ((proper? (let loop ((ls o))
 298                    (or (null? ls)
 299                        (and (pair? ls)
 300                             (not (binding? (cdr ls) env))
 301                             (loop (cdr ls))))))
 302         (1? (or (not (pair? (cdr o)))
 303                 (binding? (cdr o) env)))
 304         (not-literal? (not (literal? o env)))
 305         (infos '())
 306         (refs (ref-stack env)))
 307     (display (cond ((not not-literal?) #\()
 308                    (proper? "(list ")
 309                    (1? "(cons ")
 310                    (else "(cons* "))
 311              file)
 312     (if (and not-literal?
 313              (literal? (car o) env))
 314         (display #\' file))
 315     (write-component (car o) `(set-car! ,o ,(car o)) file env)
 316     (do ((ls (cdr o) (cdr ls))
 317          (prev o ls))
 318         ((or (not (pair? ls))
 319              (binding? ls env))
 320          (if (not (null? ls))
 321              (begin
 322                (if (not not-literal?)
 323                    (display " ." file))
 324                (display #\space file)
 325                (if (and not-literal?
 326                         (literal? ls env))
 327                    (display #\' file))
 328                (write-component ls `(set-cdr! ,prev ,ls) file env)))
 329          (display #\) file))
 330       (display #\space file)
 331       (set! infos (cons (object-info ls env) infos))
 332       (push-ref! ls env) ;*fixme* optimize
 333       (set! (visiting? (car infos)) #t)
 334       (if (and not-literal?
 335                (literal? (car ls) env))
 336           (display #\' file))
 337       (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
 338       )
 339     (for-each (lambda (info)
 340                 (set! (visiting? info) #f))
 341               infos)
 342     (set! (ref-stack env) refs)
 343     ))
 344
 345 ;;;
 346 ;;; Objects
 347 ;;;
 348
 349 ;;; Doesn't yet handle unbound slots
 350
 351 ;; Don't export this function!  This is all very temporary.
 352 ;;
 353 (define (get-set-for-each proc class)
 354   (for-each (lambda (slotdef g-n-s)
 355               (let ((g-n-s (cddr g-n-s)))
 356                 (cond ((integer? g-n-s)
 357                        (proc (standard-get g-n-s) (standard-set g-n-s)))
 358                       ((not (memq (slot-definition-allocation slotdef)
 359                                   '(#:class #:each-subclass)))
 360                        (proc (car g-n-s) (cadr g-n-s))))))
 361             (class-slots class)
 362             (slot-ref class 'getters-n-setters)))
 363
 364 (define (access-for-each proc class)
 365   (for-each (lambda (slotdef g-n-s)
 366               (let ((g-n-s (cddr g-n-s))
 367                     (a (slot-definition-accessor slotdef)))
 368                 (cond ((integer? g-n-s)
 369                        (proc (slot-definition-name slotdef)
 370                              (and a (generic-function-name a))
 371                              (standard-get g-n-s)
 372                              (standard-set g-n-s)))
 373                       ((not (memq (slot-definition-allocation slotdef)
 374                                   '(#:class #:each-subclass)))
 375                        (proc (slot-definition-name slotdef)
 376                              (and a (generic-function-name a))
 377                              (car g-n-s)
 378                              (cadr g-n-s))))))
 379             (class-slots class)
 380             (slot-ref class 'getters-n-setters)))
 381
 382 (define restore
 383   (procedure->macro
 384     (lambda (exp env)
 385       "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
 386       `(let ((o (,%allocate-instance ,(cadr exp) '())))
 387          (for-each (lambda (name val)
 388                      (,slot-set! o name val))
 389                    ',(caddr exp)
 390                    (list ,@(cdddr exp)))
 391          o))))
 392
 393 (define-method (enumerate! (o <object>) env)
 394   (get-set-for-each (lambda (get set)
 395                       (let ((val (get o)))
 396                         (if (not (unbound? val))
 397                             (enumerate-component! val env))))
 398                     (class-of o))
 399   #f)
 400
 401 (define-method (write-readably (o <object>) file env)
 402   (let ((class (class-of o)))
 403     (display "(restore " file)
 404     (display (class-name class) file)
 405     (display " (" file)
 406     (let ((slotdefs
 407            (filter (lambda (slotdef)
 408                      (not (or (memq (slot-definition-allocation slotdef)
 409                                     '(#:class #:each-subclass))
 410                               (and (slot-bound? o (slot-definition-name slotdef))
 411                                    (excluded?
 412                                     (slot-ref o (slot-definition-name slotdef))
 413                                     env)))))
 414                    (class-slots class))))
 415       (if (not (null? slotdefs))
 416           (begin
 417             (display (slot-definition-name (car slotdefs)) file)
 418             (for-each (lambda (slotdef)
 419                         (display #\space file)
 420                         (display (slot-definition-name slotdef) file))
 421                       (cdr slotdefs)))))
 422     (display #\) file)
 423     (access-for-each (lambda (name aname get set)
 424                        (display #\space file)
 425                        (let ((val (get o)))
 426                          (cond ((unbound? val)
 427                                 (display '(make-unbound) file))
 428                                ((excluded? val env))
 429                                (else
 430                                 (if (literal? val env)
 431                                     (display #\' file))
 432                                 (write-component val
 433                                                  (if aname
 434                                                      `(set! (,aname ,o) ,val)
 435                                                      `(slot-set! ,o ',name ,val))
 436                                                  file env)))))
 437                      class)
 438     (display #\) file)))
 439
 440 ;;;
 441 ;;; Classes
 442 ;;;
 443
 444 ;;; Currently, we don't support reading in class objects
 445 ;;;
 446
 447 (define-method (enumerate! (o <class>) env) #f)
 448
 449 (define-method (write-readably (o <class>) file env)
 450   (display (class-name o) file))
 451
 452 ;;;
 453 ;;; Generics
 454 ;;;
 455
 456 ;;; Currently, we don't support reading in generic functions
 457 ;;;
 458
 459 (define-method (enumerate! (o <generic>) env) #f)
 460
 461 (define-method (write-readably (o <generic>) file env)
 462   (display (generic-function-name o) file))
 463
 464 ;;;
 465 ;;; Method
 466 ;;;
 467
 468 ;;; Currently, we don't support reading in methods
 469 ;;;
 470
 471 (define-method (enumerate! (o <method>) env) #f)
 472
 473 (define-method (write-readably (o <method>) file env)
 474   (goops-error "No read-syntax for <method> defined"))
 475
 476 ;;;
 477 ;;; Environments
 478 ;;;
 479
 480 (define-class <environment> ()
 481   (object-info    #:accessor object-info
 482                   #:init-form (make-hash-table 61))
 483   (excluded       #:accessor excluded
 484                   #:init-form (make-hash-table 61))
 485   (pass-2?        #:accessor pass-2?
 486                   #:init-value #f)
 487   (ref-stack      #:accessor ref-stack
 488                   #:init-value '())
 489   (objects        #:accessor objects
 490                   #:init-value '())
 491   (pre-defines    #:accessor pre-defines
 492                   #:init-value '())
 493   (locals         #:accessor locals
 494                   #:init-value '())
 495   (stand-ins      #:accessor stand-ins
 496                   #:init-value '())
 497   (post-defines   #:accessor post-defines
 498                   #:init-value '())
 499   (patchers       #:accessor patchers
 500                   #:init-value '())
 501   (multiple-bound #:accessor multiple-bound
 502                   #:init-value '())
 503   )
 504
 505 (define-method (initialize (env <environment>) initargs)
 506   (next-method)
 507   (cond ((get-keyword #:excluded initargs #f)
 508          => (lambda (excludees)
 509               (for-each (lambda (e)
 510                           (hashq-create-handle! (excluded env) e #f))
 511                         excludees)))))
 512
 513 (define-method (object-info o env)
 514   (hashq-ref (object-info env) o))
 515
 516 (define-method ((setter object-info) o env x)
 517   (hashq-set! (object-info env) o x))
 518
 519 (define (excluded? o env)
 520   (hashq-get-handle (excluded env) o))
 521
 522 (define (add-patcher! patcher env)
 523   (set! (patchers env) (cons patcher (patchers env))))
 524
 525 (define (push-ref! o env)
 526   (set! (ref-stack env) (cons o (ref-stack env))))
 527
 528 (define (pop-ref! env)
 529   (set! (ref-stack env) (cdr (ref-stack env))))
 530
 531 (define (container env)
 532   (car (ref-stack env)))
 533
 534 (define-class <object-info> ()
 535   (visiting  #:accessor visiting
 536              #:init-value #f)
 537   (binding   #:accessor binding
 538              #:init-value #f)
 539   (literal?  #:accessor literal?
 540              #:init-value #f)
 541   )
 542
 543 (define visiting? visiting)
 544
 545 (define-method (binding (info <boolean>))
 546   #f)
 547
 548 (define-method (binding o env)
 549   (binding (object-info o env)))
 550
 551 (define binding? binding)
 552
 553 (define-method (literal? (info <boolean>))
 554   #t)
 555
 556 ;;; Note that this method is intended to be used only during the
 557 ;;; writing pass
 558 ;;;
 559 (define-method (literal? o env)
 560   (or (immediate? o)
 561       (excluded? o env)
 562       (let ((info (object-info o env)))
 563         ;; write-component sets all bindings first to #:defining,
 564         ;; then to #:defined
 565         (and (or (not (binding? info))
 566                  ;; we might be using `literal?' in a write-readably method
 567                  ;; to query about the object being defined
 568                  (and (eq? (visiting info) #:defining)
 569                       (null? (cdr (ref-stack env)))))
 570              (literal? info)))))
 571
 572 ;;;
 573 ;;; Enumeration
 574 ;;;
 575
 576 ;;; Enumeration has two passes.
 577 ;;;
 578 ;;; Pass 1: Detect common substructure, circular references and order
 579 ;;;
 580 ;;; Pass 2: Detect literals
 581
 582 (define (enumerate-component! o env)
 583   (cond ((immediate? o) #t)
 584         ((readable? o) #f)
 585         ((excluded? o env) #t)
 586         ((pass-2? env)
 587          (let ((info (object-info o env)))
 588            (if (binding? info)
 589                ;; if circular reference, we print as a literal
 590                ;; (note that during pass-2, circular references are
 591                ;;  forward references, i.e. *not* yet marked with #:pass-2
 592                (not (eq? (visiting? info) #:pass-2))
 593                (and (enumerate! o env)
 594                     (begin
 595                       (set! (literal? info) #t)
 596                       #t)))))
 597         ((object-info o env)
 598          => (lambda (info)
 599               (set! (binding info) #t)
 600               (if (visiting? info)
 601                   ;; circular reference--mark container
 602                   (set! (binding (object-info (container env) env)) #t))))
 603         (else
 604          (let ((info (make <object-info>)))
 605            (set! (object-info o env) info)
 606            (push-ref! o env)
 607            (set! (visiting? info) #t)
 608            (enumerate! o env)
 609            (set! (visiting? info) #f)
 610            (pop-ref! env)
 611            (set! (objects env) (cons o (objects env)))))))
 612
 613 (define (write-component-procedure o file env)
 614   "Return #f if circular reference"
 615   (cond ((immediate? o) (write o file) #t)
 616         ((readable? o) (write (readable-expression o) file) #t)
 617         ((excluded? o env) (display #f file) #t)
 618         (else
 619          (let ((info (object-info o env)))
 620            (cond ((not (binding? info)) (write-readably o file env) #t)
 621                  ((not (eq? (visiting info) #:defined)) #f) ;forward reference
 622                  (else (display (binding info) file) #t))))))
 623
 624 ;;; write-component OBJECT PATCHER FILE ENV
 625 ;;;
 626 (define write-component
 627   (procedure->memoizing-macro
 628     (lambda (exp env)
 629       `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
 630            (begin
 631              (display #f ,(cadddr exp))
 632              (add-patcher! ,(caddr exp) env))))))
 633
 634 ;;;
 635 ;;; Main engine
 636 ;;;
 637
 638 (define binding-name car)
 639 (define binding-object cdr)
 640
 641 (define (pass-1! alist env)
 642   ;; Determine object order and necessary bindings
 643   (for-each (lambda (binding)
 644               (enumerate-component! (binding-object binding) env))
 645             alist))
 646
 647 (define (make-local i)
 648   (string->symbol (string-append "%o" (number->string i))))
 649
 650 (define (name-bindings! alist env)
 651   ;; Name top-level bindings
 652   (for-each (lambda (b)
 653               (let ((o (binding-object b)))
 654                 (if (not (or (immediate? o)
 655                              (readable? o)
 656                              (excluded? o env)))
 657                     (let ((info (object-info o env)))
 658                       (if (symbol? (binding info))
 659                           ;; already bound to a variable
 660                           (set! (multiple-bound env)
 661                                 (acons (binding info)
 662                                        (binding-name b)
 663                                        (multiple-bound env)))
 664                           (set! (binding info)
 665                                 (binding-name b)))))))
 666             alist)
 667   ;; Name rest of bindings and create stand-in and definition lists
 668   (let post-loop ((ls (objects env))
 669                   (post-defs '()))
 670     (cond ((or (null? ls)
 671                (eq? (binding (car ls) env) #t))
 672            (set! (post-defines env) post-defs)
 673            (set! (objects env) ls))
 674           ((not (binding (car ls) env))
 675            (post-loop (cdr ls) post-defs))
 676           (else
 677            (post-loop (cdr ls) (cons (car ls) post-defs)))))
 678   (let pre-loop ((ls (reverse (objects env)))
 679                  (i 0)
 680                  (pre-defs '())
 681                  (locs '())
 682                  (sins '()))
 683     (if (null? ls)
 684         (begin
 685           (set! (pre-defines env) (reverse pre-defs))
 686           (set! (locals env) (reverse locs))
 687           (set! (stand-ins env) (reverse sins)))
 688         (let ((info (object-info (car ls) env)))
 689           (cond ((not (binding? info))
 690                  (pre-loop (cdr ls) i pre-defs locs sins))
 691                 ((boolean? (binding info))
 692                  ;; local
 693                  (set! (binding info) (make-local i))
 694                  (pre-loop (cdr ls)
 695                            (+ 1 i)
 696                            pre-defs
 697                            (cons (car ls) locs)
 698                            sins))
 699                 ((null? locs)
 700                  (pre-loop (cdr ls)
 701                            i
 702                            (cons (car ls) pre-defs)
 703                            locs
 704                            sins))
 705                 (else
 706                  (let ((real-name (binding info)))
 707                    (set! (binding info) (make-local i))
 708                    (pre-loop (cdr ls)
 709                              (+ 1 i)
 710                              pre-defs
 711                              (cons (car ls) locs)
 712                              (acons (binding info) real-name sins)))))))))
 713
 714 (define (pass-2! env)
 715   (set! (pass-2? env) #t)
 716   (for-each (lambda (o)
 717               (let ((info (object-info o env)))
 718                 (set! (literal? info) (enumerate! o env))
 719                 (set! (visiting info) #:pass-2)))
 720             (append (pre-defines env)
 721                     (locals env)
 722                     (post-defines env))))
 723
 724 (define (write-define! name val literal? file)
 725   (display "(define " file)
 726   (display name file)
 727   (display #\space file)
 728   (if literal? (display #\' file))
 729   (write val file)
 730   (display ")\n" file))
 731
 732 (define (write-empty-defines! file env)
 733   (for-each (lambda (stand-in)
 734               (write-define! (cdr stand-in) #f #f file))
 735             (stand-ins env))
 736   (for-each (lambda (o)
 737               (write-define! (binding o env) #f #f file))
 738             (post-defines env)))
 739
 740 (define (write-definition! prefix o file env)
 741   (display prefix file)
 742   (let ((info (object-info o env)))
 743     (display (binding info) file)
 744     (display #\space file)
 745     (if (literal? info)
 746         (display #\' file))
 747     (push-ref! o env)
 748     (set! (visiting info) #:defining)
 749     (write-readably o file env)
 750     (set! (visiting info) #:defined)
 751     (pop-ref! env)
 752     (display #\) file)))
 753
 754 (define (write-let*-head! file env)
 755   (display "(let* (" file)
 756   (write-definition! "(" (car (locals env)) file env)
 757   (for-each (lambda (o)
 758               (write-definition! "\n       (" o file env))
 759             (cdr (locals env)))
 760   (display ")\n" file))
 761
 762 (define (write-rebindings! prefix bindings file env)
 763   (for-each (lambda (patch)
 764               (display prefix file)
 765               (display (cdr patch) file)
 766               (display #\space file)
 767               (display (car patch) file)
 768               (display ")\n" file))
 769             bindings))
 770
 771 (define (write-definitions! selector prefix file env)
 772   (for-each (lambda (o)
 773               (write-definition! prefix o file env)
 774               (newline file))
 775             (selector env)))
 776
 777 (define (write-patches! prefix file env)
 778   (for-each (lambda (patch)
 779               (display prefix file)
 780               (display (let name-objects ((patcher patch))
 781                          (cond ((binding patcher env)
 782                                 => (lambda (name)
 783                                      (cond ((assq name (stand-ins env))
 784                                             => cdr)
 785                                            (else name))))
 786                                ((pair? patcher)
 787                                 (cons (name-objects (car patcher))
 788                                       (name-objects (cdr patcher))))
 789                                (else patcher)))
 790                        file)
 791               (newline file))
 792             (reverse (patchers env))))
 793
 794 (define (write-immediates! alist file)
 795   (for-each (lambda (b)
 796               (if (immediate? (binding-object b))
 797                   (write-define! (binding-name b)
 798                                  (binding-object b)
 799                                  #t
 800                                  file)))
 801             alist))
 802
 803 (define (write-readables! alist file env)
 804   (let ((written '()))
 805     (for-each (lambda (b)
 806                 (cond ((not (readable? (binding-object b))))
 807                       ((assq (binding-object b) written)
 808                        => (lambda (p)
 809                             (set! (multiple-bound env)
 810                                   (acons (cdr p)
 811                                          (binding-name b)
 812                                          (multiple-bound env)))))
 813                       (else
 814                        (write-define! (binding-name b)
 815                                       (readable-expression (binding-object b))
 816                                       #f
 817                                       file)
 818                        (set! written (acons (binding-object b)
 819                                             (binding-name b)
 820                                             written)))))
 821               alist)))
 822
 823 (define-method (save-objects (alist <pair>) (file <string>) . rest)
 824   (let ((port (open-output-file file)))
 825     (apply save-objects alist port rest)
 826     (close-port port)
 827     *unspecified*))
 828
 829 (define-method (save-objects (alist <pair>) (file <output-port>) . rest)
 830   (let ((excluded (if (>= (length rest) 1) (car rest) '()))
 831         (uses     (if (>= (length rest) 2) (cadr rest) '())))
 832     (let ((env (make <environment> #:excluded excluded)))
 833       (pass-1! alist env)
 834       (name-bindings! alist env)
 835       (pass-2! env)
 836       (if (not (null? uses))
 837           (begin
 838             (write `(use-modules ,@uses) file)
 839             (newline file)))
 840       (write-immediates! alist file)
 841       (if (null? (locals env))
 842           (begin
 843             (write-definitions! post-defines "(define " file env)
 844             (write-patches! "" file env))
 845           (begin
 846             (write-definitions! pre-defines "(define " file env)
 847             (write-empty-defines! file env)
 848             (write-let*-head! file env)
 849             (write-rebindings! "  (set! " (stand-ins env) file env)
 850             (write-definitions! post-defines "  (set! " file env)
 851             (write-patches! "  " file env)
 852             (display "  )\n" file)))
 853       (write-readables! alist file env)
 854       (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))
 855
 856 (define-method (load-objects (file <string>))
 857   (let* ((port (open-input-file file))
 858          (objects (load-objects port)))
 859     (close-port port)
 860     objects))
 861
 862 (define-method (load-objects (file <input-port>))
 863   (let ((m (make-module)))
 864     (module-use! m the-scm-module)
 865     (module-use! m %module-public-interface)
 866     (save-module-excursion
 867      (lambda ()
 868        (set-current-module m)
 869        (let loop ((sexp (read file)))
 870          (if (not (eof-object? sexp))
 871              (begin
 872                (eval sexp m)
 873                (loop (read file)))))))
 874     (module-map (lambda (name var)
 875                   (cons name (variable-ref var)))
 876                 m)))