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