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