Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;; installed-scm-file |
2 | ||
7c38399f | 3 | ;;;; Copyright (C) 2000,2001,2002 Free Software Foundation, Inc. |
14f1d9fe | 4 | ;;;; |
73be1d9e MV |
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. | |
14f1d9fe | 9 | ;;;; |
73be1d9e | 10 | ;;;; This library is distributed in the hope that it will be useful, |
14f1d9fe | 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;;; Lesser General Public License for more details. | |
14f1d9fe | 14 | ;;;; |
73be1d9e MV |
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
14f1d9fe MD |
18 | ;;;; |
19 | \f | |
20 | ||
21 | (define-module (oop goops save) | |
22 | :use-module (oop goops internal) | |
23 | :use-module (oop goops util) | |
1a179b03 MD |
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)) | |
14f1d9fe MD |
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 | ||
71d540f7 | 89 | (define-method (immediate? (o <top>)) #f) |
14f1d9fe | 90 | |
71d540f7 MD |
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) | |
14f1d9fe MD |
97 | |
98 | ;;; enumerate! OBJECT ENVIRONMENT | |
99 | ;;; | |
100 | ;;; Return #t if object is a literal. | |
101 | ;;; | |
71d540f7 | 102 | (define-method (enumerate! (o <top>) env) #t) |
14f1d9fe | 103 | |
71d540f7 | 104 | (define-method (write-readably (o <top>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 136 | (define-method (enumerate! (o <string>) env) #f) |
14f1d9fe MD |
137 | |
138 | ;;; | |
139 | ;;; Vectors | |
140 | ;;; | |
141 | ||
71d540f7 | 142 | (define-method (enumerate! (o <vector>) env) |
14f1d9fe MD |
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 | ||
71d540f7 | 151 | (define-method (write-readably (o <vector>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 186 | (define-method (enumerate! (o <array>) env) |
14f1d9fe MD |
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 | ||
71d540f7 | 250 | (define-method (write-readably (o <array>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 289 | (define-method (enumerate! (o <pair>) env) |
14f1d9fe MD |
290 | (let ((literal? (enumerate-component! (car o) env))) |
291 | (and (enumerate-component! (cdr o) env) | |
292 | literal?))) | |
293 | ||
71d540f7 | 294 | (define-method (write-readably (o <pair>) file env) |
14f1d9fe MD |
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 ") | |
0b7edf57 | 308 | (else "(cons* ")) |
14f1d9fe MD |
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 | |
7c38399f | 381 | (procedure->memoizing-macro |
14f1d9fe MD |
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 | ||
71d540f7 | 391 | (define-method (enumerate! (o <object>) env) |
14f1d9fe MD |
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 | ||
71d540f7 | 399 | (define-method (write-readably (o <object>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 445 | (define-method (enumerate! (o <class>) env) #f) |
14f1d9fe | 446 | |
71d540f7 | 447 | (define-method (write-readably (o <class>) file env) |
14f1d9fe MD |
448 | (display (class-name o) file)) |
449 | ||
450 | ;;; | |
451 | ;;; Generics | |
452 | ;;; | |
453 | ||
454 | ;;; Currently, we don't support reading in generic functions | |
455 | ;;; | |
456 | ||
71d540f7 | 457 | (define-method (enumerate! (o <generic>) env) #f) |
14f1d9fe | 458 | |
71d540f7 | 459 | (define-method (write-readably (o <generic>) file env) |
14f1d9fe MD |
460 | (display (generic-function-name o) file)) |
461 | ||
462 | ;;; | |
463 | ;;; Method | |
464 | ;;; | |
465 | ||
466 | ;;; Currently, we don't support reading in methods | |
467 | ;;; | |
468 | ||
71d540f7 | 469 | (define-method (enumerate! (o <method>) env) #f) |
14f1d9fe | 470 | |
71d540f7 | 471 | (define-method (write-readably (o <method>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 821 | (define-method (save-objects (alist <pair>) (file <string>) . rest) |
14f1d9fe MD |
822 | (let ((port (open-output-file file))) |
823 | (apply save-objects alist port rest) | |
824 | (close-port port) | |
825 | *unspecified*)) | |
826 | ||
71d540f7 | 827 | (define-method (save-objects (alist <pair>) (file <output-port>) . rest) |
14f1d9fe MD |
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 | ||
71d540f7 | 854 | (define-method (load-objects (file <string>)) |
14f1d9fe MD |
855 | (let* ((port (open-input-file file)) |
856 | (objects (load-objects port))) | |
857 | (close-port port) | |
858 | objects)) | |
859 | ||
71d540f7 | 860 | (define-method (load-objects (file <input-port>)) |
14f1d9fe MD |
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 | |
3b505adf | 870 | (eval sexp m) |
14f1d9fe MD |
871 | (loop (read file))))))) |
872 | (module-map (lambda (name var) | |
873 | (cons name (variable-ref var))) | |
874 | m))) |