Commit | Line | Data |
---|---|---|
14f1d9fe MD |
1 | ;;; installed-scm-file |
2 | ||
7f420e49 | 3 | ;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013 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 | |
53befeb7 | 8 | ;;;; version 3 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 | |
92205699 | 17 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 | ||
b3501b80 | 113 | (define readables (make-weak-key-hash-table 61)) |
14f1d9fe | 114 | |
ae9ce4b7 AW |
115 | (define-macro (readable exp) |
116 | `(make-readable ,exp ',(copy-tree exp))) | |
14f1d9fe MD |
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 | ||
7f420e49 AW |
125 | ;; FIXME: if obj is nil or false, this can return a false value. OTOH |
126 | ;; usually this is only for non-immediates. | |
14f1d9fe | 127 | (define (readable? obj) |
7f420e49 | 128 | (hashq-ref readables obj)) |
14f1d9fe | 129 | |
a3df9ad9 AW |
130 | ;;; |
131 | ;;; Writer helpers | |
132 | ;;; | |
133 | ||
134 | (define (write-component-procedure o file env) | |
135 | "Return #f if circular reference" | |
136 | (cond ((immediate? o) (write o file) #t) | |
137 | ((readable? o) (write (readable-expression o) file) #t) | |
138 | ((excluded? o env) (display #f file) #t) | |
139 | (else | |
140 | (let ((info (object-info o env))) | |
141 | (cond ((not (binding? info)) (write-readably o file env) #t) | |
142 | ((not (eq? (visiting info) #:defined)) #f) ;forward reference | |
143 | (else (display (binding info) file) #t)))))) | |
144 | ||
145 | ;;; write-component OBJECT PATCHER FILE ENV | |
146 | ;;; | |
147 | (define-macro (write-component object patcher file env) | |
148 | `(or (write-component-procedure ,object ,file ,env) | |
149 | (begin | |
150 | (display #f ,file) | |
151 | (add-patcher! ,patcher ,env)))) | |
152 | ||
14f1d9fe MD |
153 | ;;; |
154 | ;;; Strings | |
155 | ;;; | |
156 | ||
71d540f7 | 157 | (define-method (enumerate! (o <string>) env) #f) |
14f1d9fe MD |
158 | |
159 | ;;; | |
160 | ;;; Vectors | |
161 | ;;; | |
162 | ||
71d540f7 | 163 | (define-method (enumerate! (o <vector>) env) |
14f1d9fe MD |
164 | (or (not (vector? o)) |
165 | (let ((literal? #t)) | |
166 | (array-for-each (lambda (o) | |
167 | (if (not (enumerate-component! o env)) | |
168 | (set! literal? #f))) | |
169 | o) | |
170 | literal?))) | |
171 | ||
71d540f7 | 172 | (define-method (write-readably (o <vector>) file env) |
14f1d9fe MD |
173 | (if (not (vector? o)) |
174 | (write o file) | |
175 | (let ((n (vector-length o))) | |
176 | (if (zero? n) | |
177 | (display "#()" file) | |
178 | (let ((not-literal? (not (literal? o env)))) | |
179 | (display (if not-literal? | |
180 | "(vector " | |
181 | "#(") | |
182 | file) | |
183 | (if (and not-literal? | |
184 | (literal? (vector-ref o 0) env)) | |
185 | (display #\' file)) | |
186 | (write-component (vector-ref o 0) | |
187 | `(vector-set! ,o 0 ,(vector-ref o 0)) | |
188 | file | |
189 | env) | |
190 | (do ((i 1 (+ 1 i))) | |
191 | ((= i n)) | |
192 | (display #\space file) | |
193 | (if (and not-literal? | |
194 | (literal? (vector-ref o i) env)) | |
195 | (display #\' file)) | |
196 | (write-component (vector-ref o i) | |
197 | `(vector-set! ,o ,i ,(vector-ref o i)) | |
198 | file | |
199 | env)) | |
200 | (display #\) file)))))) | |
201 | ||
202 | ||
203 | ;;; | |
204 | ;;; Arrays | |
205 | ;;; | |
206 | ||
71d540f7 | 207 | (define-method (enumerate! (o <array>) env) |
14f1d9fe MD |
208 | (enumerate-component! (shared-array-root o) env)) |
209 | ||
210 | (define (make-mapper array) | |
a2ca7252 | 211 | (let* ((n (array-rank array)) |
14f1d9fe MD |
212 | (indices (reverse (if (<= n 11) |
213 | (list-tail '(t s r q p n m l k j i) (- 11 n)) | |
214 | (let loop ((n n) | |
215 | (ls '())) | |
216 | (if (zero? n) | |
217 | ls | |
218 | (loop (- n 1) | |
219 | (cons (gensym "i") ls)))))))) | |
220 | `(lambda ,indices | |
221 | (+ ,(shared-array-offset array) | |
222 | ,@(map (lambda (ind dim inc) | |
223 | `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind))) | |
224 | indices | |
225 | (array-dimensions array) | |
226 | (shared-array-increments array)))))) | |
227 | ||
228 | (define (write-array prefix o not-literal? file env) | |
229 | (letrec ((inner (lambda (n indices) | |
230 | (if (not (zero? n)) | |
231 | (let ((el (apply array-ref o | |
232 | (reverse (cons 0 indices))))) | |
233 | (if (and not-literal? | |
234 | (literal? el env)) | |
235 | (display #\' file)) | |
236 | (write-component | |
237 | el | |
238 | `(array-set! ,o ,el ,@indices) | |
239 | file | |
240 | env))) | |
241 | (do ((i 1 (+ 1 i))) | |
242 | ((= i n)) | |
243 | (display #\space file) | |
244 | (let ((el (apply array-ref o | |
245 | (reverse (cons i indices))))) | |
246 | (if (and not-literal? | |
247 | (literal? el env)) | |
248 | (display #\' file)) | |
249 | (write-component | |
250 | el | |
251 | `(array-set! ,o ,el ,@indices) | |
252 | file | |
253 | env)))))) | |
254 | (display prefix file) | |
255 | (let loop ((dims (array-dimensions o)) | |
256 | (indices '())) | |
257 | (cond ((null? (cdr dims)) | |
258 | (inner (car dims) indices)) | |
259 | (else | |
260 | (let ((n (car dims))) | |
261 | (do ((i 0 (+ 1 i))) | |
262 | ((= i n)) | |
263 | (if (> i 0) | |
264 | (display #\space file)) | |
265 | (display prefix file) | |
266 | (loop (cdr dims) (cons i indices)) | |
267 | (display #\) file)))))) | |
268 | (display #\) file))) | |
269 | ||
71d540f7 | 270 | (define-method (write-readably (o <array>) file env) |
14f1d9fe MD |
271 | (let ((root (shared-array-root o))) |
272 | (cond ((literal? o env) | |
273 | (if (not (vector? root)) | |
274 | (write o file) | |
275 | (begin | |
276 | (display #\# file) | |
277 | (display (array-rank o) file) | |
278 | (write-array #\( o #f file env)))) | |
279 | ((binding? root env) | |
280 | (display "(make-shared-array " file) | |
281 | (if (literal? root env) | |
282 | (display #\' file)) | |
283 | (write-component root | |
284 | (goops-error "write-readably(<array>): internal error") | |
285 | file | |
286 | env) | |
287 | (display #\space file) | |
288 | (display (make-mapper o) file) | |
289 | (for-each (lambda (dim) | |
290 | (display #\space file) | |
291 | (display dim file)) | |
292 | (array-dimensions o)) | |
293 | (display #\) file)) | |
294 | (else | |
295 | (display "(list->uniform-array " file) | |
296 | (display (array-rank o) file) | |
297 | (display " '() " file) | |
5658035c | 298 | (write-array "(list " o #f file env))))) |
14f1d9fe MD |
299 | |
300 | ;;; | |
301 | ;;; Pairs | |
302 | ;;; | |
303 | ||
304 | ;;; These methods have more complex structure than is required for | |
305 | ;;; most objects, since they take over some of the logic of | |
306 | ;;; `write-component'. | |
307 | ;;; | |
308 | ||
71d540f7 | 309 | (define-method (enumerate! (o <pair>) env) |
14f1d9fe MD |
310 | (let ((literal? (enumerate-component! (car o) env))) |
311 | (and (enumerate-component! (cdr o) env) | |
312 | literal?))) | |
313 | ||
71d540f7 | 314 | (define-method (write-readably (o <pair>) file env) |
14f1d9fe MD |
315 | (let ((proper? (let loop ((ls o)) |
316 | (or (null? ls) | |
317 | (and (pair? ls) | |
318 | (not (binding? (cdr ls) env)) | |
319 | (loop (cdr ls)))))) | |
320 | (1? (or (not (pair? (cdr o))) | |
321 | (binding? (cdr o) env))) | |
322 | (not-literal? (not (literal? o env))) | |
323 | (infos '()) | |
324 | (refs (ref-stack env))) | |
325 | (display (cond ((not not-literal?) #\() | |
326 | (proper? "(list ") | |
327 | (1? "(cons ") | |
0b7edf57 | 328 | (else "(cons* ")) |
14f1d9fe MD |
329 | file) |
330 | (if (and not-literal? | |
331 | (literal? (car o) env)) | |
332 | (display #\' file)) | |
333 | (write-component (car o) `(set-car! ,o ,(car o)) file env) | |
334 | (do ((ls (cdr o) (cdr ls)) | |
335 | (prev o ls)) | |
336 | ((or (not (pair? ls)) | |
337 | (binding? ls env)) | |
338 | (if (not (null? ls)) | |
339 | (begin | |
340 | (if (not not-literal?) | |
341 | (display " ." file)) | |
342 | (display #\space file) | |
343 | (if (and not-literal? | |
344 | (literal? ls env)) | |
345 | (display #\' file)) | |
346 | (write-component ls `(set-cdr! ,prev ,ls) file env))) | |
347 | (display #\) file)) | |
348 | (display #\space file) | |
349 | (set! infos (cons (object-info ls env) infos)) | |
350 | (push-ref! ls env) ;*fixme* optimize | |
351 | (set! (visiting? (car infos)) #t) | |
352 | (if (and not-literal? | |
353 | (literal? (car ls) env)) | |
354 | (display #\' file)) | |
355 | (write-component (car ls) `(set-car! ,ls ,(car ls)) file env) | |
356 | ) | |
357 | (for-each (lambda (info) | |
358 | (set! (visiting? info) #f)) | |
359 | infos) | |
360 | (set! (ref-stack env) refs) | |
361 | )) | |
362 | ||
363 | ;;; | |
364 | ;;; Objects | |
365 | ;;; | |
366 | ||
367 | ;;; Doesn't yet handle unbound slots | |
368 | ||
369 | ;; Don't export this function! This is all very temporary. | |
370 | ;; | |
371 | (define (get-set-for-each proc class) | |
372 | (for-each (lambda (slotdef g-n-s) | |
373 | (let ((g-n-s (cddr g-n-s))) | |
374 | (cond ((integer? g-n-s) | |
375 | (proc (standard-get g-n-s) (standard-set g-n-s))) | |
376 | ((not (memq (slot-definition-allocation slotdef) | |
377 | '(#:class #:each-subclass))) | |
378 | (proc (car g-n-s) (cadr g-n-s)))))) | |
379 | (class-slots class) | |
380 | (slot-ref class 'getters-n-setters))) | |
381 | ||
382 | (define (access-for-each proc class) | |
383 | (for-each (lambda (slotdef g-n-s) | |
384 | (let ((g-n-s (cddr g-n-s)) | |
385 | (a (slot-definition-accessor slotdef))) | |
386 | (cond ((integer? g-n-s) | |
387 | (proc (slot-definition-name slotdef) | |
388 | (and a (generic-function-name a)) | |
389 | (standard-get g-n-s) | |
390 | (standard-set g-n-s))) | |
391 | ((not (memq (slot-definition-allocation slotdef) | |
392 | '(#:class #:each-subclass))) | |
393 | (proc (slot-definition-name slotdef) | |
394 | (and a (generic-function-name a)) | |
395 | (car g-n-s) | |
396 | (cadr g-n-s)))))) | |
397 | (class-slots class) | |
398 | (slot-ref class 'getters-n-setters))) | |
399 | ||
ae9ce4b7 AW |
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)) | |
14f1d9fe | 408 | |
71d540f7 | 409 | (define-method (enumerate! (o <object>) env) |
14f1d9fe MD |
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 | ||
71d540f7 | 417 | (define-method (write-readably (o <object>) file env) |
14f1d9fe MD |
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 | ||
71d540f7 | 463 | (define-method (enumerate! (o <class>) env) #f) |
14f1d9fe | 464 | |
71d540f7 | 465 | (define-method (write-readably (o <class>) file env) |
14f1d9fe MD |
466 | (display (class-name o) file)) |
467 | ||
468 | ;;; | |
469 | ;;; Generics | |
470 | ;;; | |
471 | ||
472 | ;;; Currently, we don't support reading in generic functions | |
473 | ;;; | |
474 | ||
71d540f7 | 475 | (define-method (enumerate! (o <generic>) env) #f) |
14f1d9fe | 476 | |
71d540f7 | 477 | (define-method (write-readably (o <generic>) file env) |
14f1d9fe MD |
478 | (display (generic-function-name o) file)) |
479 | ||
480 | ;;; | |
481 | ;;; Method | |
482 | ;;; | |
483 | ||
484 | ;;; Currently, we don't support reading in methods | |
485 | ;;; | |
486 | ||
71d540f7 | 487 | (define-method (enumerate! (o <method>) env) #f) |
14f1d9fe | 488 | |
71d540f7 | 489 | (define-method (write-readably (o <method>) file env) |
14f1d9fe MD |
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 | ||
14f1d9fe MD |
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 | ||
71d540f7 | 819 | (define-method (save-objects (alist <pair>) (file <string>) . rest) |
14f1d9fe MD |
820 | (let ((port (open-output-file file))) |
821 | (apply save-objects alist port rest) | |
822 | (close-port port) | |
823 | *unspecified*)) | |
824 | ||
71d540f7 | 825 | (define-method (save-objects (alist <pair>) (file <output-port>) . rest) |
14f1d9fe MD |
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 | ||
71d540f7 | 852 | (define-method (load-objects (file <string>)) |
14f1d9fe MD |
853 | (let* ((port (open-input-file file)) |
854 | (objects (load-objects port))) | |
855 | (close-port port) | |
856 | objects)) | |
857 | ||
69928c8a AW |
858 | (define iface (module-public-interface (current-module))) |
859 | ||
71d540f7 | 860 | (define-method (load-objects (file <input-port>)) |
14f1d9fe MD |
861 | (let ((m (make-module))) |
862 | (module-use! m the-scm-module) | |
69928c8a | 863 | (module-use! m iface) |
14f1d9fe MD |
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))) |