guile18/oop/goops/save.scm

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