module/oop/goops/save.scm

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