module/oop/goops/save.scm

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