/[cl-store]/cl-store/default-backend.lisp
ViewVC logotype

Contents of /cl-store/default-backend.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (show annotations)
Mon Sep 17 18:40:02 2007 UTC (6 years, 7 months ago) by sross
Branch: MAIN
CVS Tags: HEAD
Changes since 1.39: +27 -1 lines
faster (simple-array (unsigned-byte 8) (*)) storing. Thanks to Chris Dean
more lenient parsing of sbcl version. Thanks to Gustavo
1 7;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3
4 ;; The cl-store backend.
5 (in-package :cl-store)
6
7 (defbackend cl-store :magic-number 1395477571
8 :stream-type '(unsigned-byte 8)
9 :old-magic-numbers (1912923 1886611788 1347635532 1886611820 1414745155
10 1349740876 1884506444 1347643724 1349732684 1953713219
11 1416850499)
12 :extends (resolving-backend)
13 :fields ((restorers :accessor restorers
14 :initform (make-hash-table :size 100))))
15
16 (defun register-code (code name &optional (errorp nil))
17 (aif (and (gethash code (restorers (find-backend 'cl-store))) errorp)
18 (error "Code ~A is already defined for ~A." code name)
19 (setf (gethash code (restorers (find-backend 'cl-store)))
20 name))
21 code)
22
23
24 ;; Type code constants
25 (defparameter +referrer-code+ (register-code 1 'referrer))
26 (defparameter +special-float-code+ (register-code 2 'special-float))
27 (defparameter +unicode-string-code+ (register-code 3 'unicode-string))
28 (defparameter +integer-code+ (register-code 4 'integer))
29 (defparameter +simple-string-code+ (register-code 5 'simple-string))
30 (defparameter +float-code+ (register-code 6 'float))
31 (defparameter +ratio-code+ (register-code 7 'ratio))
32 (defparameter +character-code+ (register-code 8 'character))
33 (defparameter +complex-code+ (register-code 9 'complex))
34 (defparameter +symbol-code+ (register-code 10 'symbol))
35 (defparameter +cons-code+ (register-code 11 'cons))
36 (defparameter +pathname-code+ (register-code 12 'pathname))
37 (defparameter +hash-table-code+ (register-code 13 'hash-table))
38 (defparameter +standard-object-code+ (register-code 14 'standard-object))
39 (defparameter +condition-code+ (register-code 15 'condition))
40 (defparameter +structure-object-code+ (register-code 16 'structure-object))
41 (defparameter +standard-class-code+ (register-code 17 'standard-class))
42 (defparameter +built-in-class-code+ (register-code 18 'built-in-class))
43 (defparameter +array-code+ (register-code 19 'array))
44 (defparameter +simple-vector-code+ (register-code 20 'simple-vector))
45 (defparameter +package-code+ (register-code 21 'package))
46 (defparameter +simple-byte-vector-code+ (register-code 22 'simple-byte-vector))
47
48 ;; fast storing for 32 bit ints
49 (defparameter +32-bit-integer-code+ (register-code 24 '32-bit-integer))
50
51 (defparameter +function-code+ (register-code 26 'function nil))
52 (defparameter +gf-code+ (register-code 27 'generic-function nil))
53
54 ;; Used by SBCL and CMUCL.
55 (defparameter +structure-class-code+ (register-code 28 'structure-class nil))
56 (defparameter +struct-def-code+ (register-code 29 'struct-def nil))
57
58 (defparameter +gensym-code+ (register-code 30 'gensym nil))
59
60 (defparameter +unicode-base-string-code+ (register-code 34 'unicode-base-string nil))
61 (defparameter +simple-base-string-code+ (register-code 35 'simple-base-string nil))
62
63 ;; setups for type code mapping
64 (defun output-type-code (code stream)
65 (declare (type ub32 code))
66 (write-byte (ldb (byte 8 0) code) stream))
67
68 (declaim (inline read-type-code))
69 (defun read-type-code (stream)
70 (read-byte stream))
71
72 (defmethod referrerp ((backend cl-store) (reader t))
73 (declare (optimize speed (safety 0) (space 0) (debug 0)))
74 (eql reader 'referrer))
75
76 (defparameter *restorers* (restorers (find-backend 'cl-store)))
77
78 ;; get-next-reader needs to return a symbol which will be used by the
79 ;; backend to lookup the function that was defined by
80 ;; defrestore-cl-store to restore it, or nil if not found.
81 (defun lookup-code (code)
82 (declare (optimize speed (safety 0) (space 0) (debug 0)))
83 (gethash code *restorers*))
84
85 (defmethod get-next-reader ((backend cl-store) (stream stream))
86 (declare (optimize speed (safety 0) (space 0) (debug 0)))
87 (let ((type-code (read-type-code stream)))
88 (or (lookup-code type-code)
89 (error "Type code ~A is not registered." type-code))))
90
91
92 ;; referrer, Required for a resolving backend
93 (defmethod store-referrer ((backend cl-store) (ref t) (stream t))
94 (output-type-code +referrer-code+ stream)
95 (dump-int ref stream))
96
97 (defrestore-cl-store (referrer stream)
98 (make-referrer :val (undump-int stream)))
99
100
101
102 ;; integers
103 ;; The theory is that most numbers will fit in 32 bits
104 ;; so we we have a little optimization for it
105
106 ;; We need this for circularity stuff.
107 (defmethod int-or-char-p ((backend cl-store) (type symbol))
108 (declare (optimize speed (safety 0) (space 0) (debug 0)))
109 (or (eql type '32-bit-integer)
110 (eql type 'integer)
111 (eql type 'character)))
112
113 (defstore-cl-store (obj integer stream)
114 (declare (optimize speed (safety 1) (debug 0)))
115 (if (typep obj 'sb32)
116 (store-32-bit-integer obj stream)
117 (store-arbitrary-integer obj stream)))
118
119 (defun dump-int (obj stream)
120 (declare (optimize speed (safety 0) (debug 0)))
121 (etypecase obj
122 ((unsigned-byte 8) (write-byte 1 stream) (write-byte obj stream))
123 ((unsigned-byte 32) (write-byte 2 stream) (store-32-bit obj stream))))
124
125 (defun undump-int (stream)
126 (declare (optimize speed (safety 0) (debug 0)))
127 (ecase (read-byte stream)
128 (1 (read-byte stream))
129 (2 (read-32-bit stream nil))))
130
131 (defun store-32-bit-integer (obj stream)
132 (declare (optimize speed (safety 1) (debug 0)) (type sb32 obj))
133 (output-type-code +32-bit-integer-code+ stream)
134 (write-byte (if (minusp obj) 1 0) stream)
135 (dump-int (abs obj) stream))
136
137 (defrestore-cl-store (32-bit-integer stream)
138 (declare (optimize speed (safety 1) (debug 0)))
139 (funcall (if (zerop (the fixnum (read-byte stream))) #'+ #'-)
140 (undump-int stream)))
141
142
143 (defun num->bits (num )
144 (loop for val = (abs num) then (ash val -8 )
145 for count from 0
146 until (zerop val)
147 collect (logand val #XFF) into bits
148 finally (return (values bits count))))
149
150 (defun store-arbitrary-integer (obj stream)
151 (declare (type integer obj) (stream stream)
152 (optimize speed))
153 (output-type-code +integer-code+ stream)
154 (multiple-value-bind (bits count) (num->bits obj)
155 (store-object (if (minusp obj) (- count) count)
156 stream)
157 (dolist (x bits) (store-32-bit x stream))))
158
159
160 (defrestore-cl-store (integer buff)
161 (declare (optimize speed))
162 (let ((count (restore-object buff)))
163 (loop repeat (abs count)
164 with sum = 0
165 for pos from 0 by 8
166 for bit = (read-32-bit buff nil)
167 finally (return (if (minusp count) (- sum) sum))
168 :do
169 (incf sum (* bit (expt 2 pos))))))
170
171
172
173 (defun bits->num (bits)
174 (loop with sum = 0
175 for pos from 0 by 8
176 for bit in bits
177 finally (return sum)
178 :do (incf sum (* bit (expt 2 pos)))))
179
180
181
182 ;; Floats (*special-floats* are setup in the custom.lisp files)
183
184 (defconstant +short-float-inf+ 0)
185 (defconstant +short-float-neg-inf+ 1)
186 (defconstant +short-float-nan+ 2)
187
188 (defconstant +single-float-inf+ 3)
189 (defconstant +single-float-neg-inf+ 4)
190 (defconstant +single-float-nan+ 5)
191
192 (defconstant +double-float-inf+ 6)
193 (defconstant +double-float-neg-inf+ 7)
194 (defconstant +double-float-nan+ 8)
195
196 (defconstant +long-float-inf+ 9)
197 (defconstant +long-float-neg-inf+ 10)
198 (defconstant +long-float-nan+ 11)
199
200 (defvar *special-floats* nil)
201
202 ;; Implementations are to provide an implementation for the create-float-value
203 ;; function
204 (defun create-float-values (value &rest codes)
205 "Returns a alist of special float to float code mappings."
206 (declare (ignore value codes))
207 nil)
208
209 (defun setup-special-floats ()
210 (setf *special-floats*
211 (nconc (create-float-values most-negative-short-float +short-float-inf+
212 +short-float-neg-inf+ +short-float-nan+)
213 (create-float-values most-negative-single-float +single-float-inf+
214 +single-float-neg-inf+ +single-float-nan+)
215 (create-float-values most-negative-double-float +double-float-inf+
216 +double-float-neg-inf+ +double-float-nan+)
217 (create-float-values most-negative-long-float +long-float-inf+
218 +long-float-neg-inf+ +long-float-nan+))))
219
220 (defstore-cl-store (obj float stream)
221 (declare (optimize speed))
222 (block body
223 (let (significand exponent sign)
224 (handler-bind (((or simple-error arithmetic-error type-error)
225 #'(lambda (err)
226 (declare (ignore err))
227 (when-let (type (cdr (assoc obj *special-floats*)))
228 (output-type-code +special-float-code+ stream)
229 (write-byte type stream)
230 (return-from body)))))
231 (multiple-value-setq (significand exponent sign)
232 (integer-decode-float obj))
233 (output-type-code +float-code+ stream)
234 (write-byte (float-type obj) stream)
235 (store-object significand stream)
236 (store-object (float-radix obj) stream)
237 (store-object exponent stream)
238 (store-object sign stream)))))
239
240 (defrestore-cl-store (float stream)
241 (float (* (the float (get-float-type (read-byte stream)))
242 (* (the integer (restore-object stream))
243 (expt (the integer (restore-object stream))
244 (the integer (restore-object stream))))
245 (the integer (restore-object stream)))))
246
247 (defrestore-cl-store (special-float stream)
248 (or (car (rassoc (read-byte stream) *special-floats*))
249 (restore-error "Float ~S is not a valid special float.")))
250
251
252 ;; ratio
253 (defstore-cl-store (obj ratio stream)
254 (output-type-code +ratio-code+ stream)
255 (store-object (numerator obj) stream)
256 (store-object (denominator obj) stream))
257
258 (defrestore-cl-store (ratio stream)
259 (/ (the integer (restore-object stream))
260 (the integer (restore-object stream))))
261
262 ;; chars
263 (defstore-cl-store (obj character stream)
264 (output-type-code +character-code+ stream)
265 (store-object (char-code obj) stream))
266
267 (defrestore-cl-store (character stream)
268 (code-char (restore-object stream)))
269
270 ;; complex
271 (defstore-cl-store (obj complex stream)
272 (output-type-code +complex-code+ stream)
273 (store-object (realpart obj) stream)
274 (store-object (imagpart obj) stream))
275
276 (defrestore-cl-store (complex stream)
277 (complex (restore-object stream)
278 (restore-object stream)))
279
280 ;; symbols
281 (defstore-cl-store (obj symbol stream)
282 (declare (optimize speed))
283 (cond ((symbol-package obj)
284 (output-type-code +symbol-code+ stream)
285 (store-object (symbol-name obj) stream)
286 (store-object (package-name (symbol-package obj))
287 stream))
288 ;; Symbols with no home package
289 (t (output-type-code +gensym-code+ stream)
290 (store-object (symbol-name obj) stream))))
291
292 (defrestore-cl-store (symbol stream)
293 (values (intern (restore-object stream)
294 (restore-object stream))))
295
296 (defrestore-cl-store (gensym stream)
297 (make-symbol (restore-object stream)))
298
299
300 ;; Lists
301 (defun dump-list (list length last stream)
302 (declare (optimize speed (safety 1) (debug 0))
303 (type cons list))
304 (output-type-code +cons-code+ stream)
305 (store-object length stream)
306 (loop repeat length
307 for x on list do
308 (store-object (car x) stream))
309 (store-object last stream))
310
311 (defun restore-list (stream)
312 (declare (optimize speed (safety 1) (debug 0)))
313 (let* ((conses (restore-object stream))
314 (ret ())
315 (tail ret))
316 (dotimes (x conses)
317 (let ((obj (restore-object stream)))
318 ;; we can't use setting here since we wan't to
319 ;; be fairly efficient when adding objects to the
320 ;; end of the list.
321 (when (and *check-for-circs* (referrer-p obj))
322 (let ((x x))
323 (push (delay (setf (nth x ret)
324 (referred-value obj *restored-values*)))
325 *need-to-fix*)))
326 (if ret
327 (setf (cdr tail) (list obj)
328 tail (cdr tail))
329 (setf ret (list obj)
330 tail (last ret)))))
331 (let ((last1 (restore-object stream)))
332 ;; and check for the last possible circularity
333 (if (and *check-for-circs* (referrer-p last1))
334 (push (delay (setf (cdr tail)
335 (referred-value last1 *restored-values*)))
336 *need-to-fix*)
337 (setf (cdr tail) last1)))
338 ret))
339
340 (defstore-cl-store (list cons stream)
341 (multiple-value-bind (length last) (safe-length list)
342 (dump-list list length last stream)))
343
344 (defrestore-cl-store (cons stream)
345 (restore-list stream))
346
347
348 ;; pathnames
349 (defstore-cl-store (obj pathname stream)
350 (output-type-code +pathname-code+ stream)
351 (store-object (pathname-device obj) stream)
352 (store-object (pathname-directory obj) stream)
353 (store-object (pathname-name obj) stream)
354 (store-object (pathname-type obj) stream)
355 (store-object (pathname-version obj) stream))
356
357 (defrestore-cl-store (pathname stream)
358 (make-pathname
359 :device (restore-object stream)
360 :directory (restore-object stream)
361 :name (restore-object stream)
362 :type (restore-object stream)
363 :version (restore-object stream)))
364
365
366 ;; hash tables
367 (defstore-cl-store (obj hash-table stream)
368 (declare (optimize speed))
369 (output-type-code +hash-table-code+ stream)
370 (store-object (hash-table-rehash-size obj) stream)
371 (store-object (hash-table-rehash-threshold obj) stream)
372 (store-object (hash-table-size obj) stream)
373 (store-object (hash-table-test obj) stream)
374 (store-object (hash-table-count obj) stream)
375 (loop for key being the hash-keys of obj
376 using (hash-value value) do
377 (store-object key stream)
378 (store-object value stream)))
379
380 (defrestore-cl-store (hash-table stream)
381 (let ((rehash-size (restore-object stream))
382 (rehash-threshold (restore-object stream))
383 (size (restore-object stream))
384 (test (restore-object stream))
385 (count (restore-object stream)))
386 (declare (type integer count size))
387 (let ((hash (make-hash-table :test test
388 :rehash-size rehash-size
389 :rehash-threshold rehash-threshold
390 :size size)))
391 (resolving-object (x hash)
392 (loop repeat count do
393 ;; Unfortunately we can't use the normal setting here
394 ;; since there could be a circularity in the key
395 ;; and we need to make sure that both objects are
396 ;; removed from the stream at this point.
397 (setting-hash (restore-object stream)
398 (restore-object stream))))
399 hash)))
400
401 ;; The dumping of objects works by serializing the type of the object which
402 ;; is followed by applicable slot-name and value (depending on whether the
403 ;; slot is bound, it's allocation and *store-class-slots*). Once each slot
404 ;; is serialized a counter is incremented which is stored at the end.
405 ;; When restoring the object a new instance is allocated and then
406 ;; restore-type-object starts reading objects from the stream.
407 ;; If the restored object is a symbol the it names a slot and it's value
408 ;; is pulled out and set on the newly allocated object.
409 ;; If the restored object is an integer then this is the end marker
410 ;; for the object and the number of slots restored is checked against
411 ;; this counter.
412
413 ;; Object and Conditions
414 (defun store-type-object (obj stream)
415 (declare (optimize speed))
416 (let ((all-slots (serializable-slots obj))
417 (length 0))
418 (store-object (type-of obj) stream)
419 (dolist (slot all-slots)
420 (let ((slot-name (slot-definition-name slot)))
421 (when (and (slot-boundp obj slot-name)
422 (or *store-class-slots*
423 (not (eql (slot-definition-allocation slot)
424 :class))))
425 (store-object (slot-definition-name slot) stream)
426 (store-object (slot-value obj slot-name) stream)
427 (incf length))))
428 (store-object length stream)))
429
430 (defstore-cl-store (obj standard-object stream)
431 (output-type-code +standard-object-code+ stream)
432 (store-type-object obj stream))
433
434 (defstore-cl-store (obj condition stream)
435 (output-type-code +condition-code+ stream)
436 (store-type-object obj stream))
437
438 (defun restore-type-object (stream)
439 (declare (optimize speed))
440 (let* ((class (find-class (restore-object stream)))
441 (new-instance (allocate-instance class)))
442 (resolving-object (obj new-instance)
443 (loop for count from 0 do
444 (let ((slot-name (restore-object stream)))
445 (etypecase slot-name
446 (integer (assert (= count slot-name) (count slot-name)
447 "Number of slots restored does not match slots stored.")
448 (return))
449 (symbol
450 ;; slot-names are always symbols so we don't
451 ;; have to worry about circularities
452 (setting (slot-value obj slot-name) (restore-object stream)))))))
453 new-instance))
454
455 (defrestore-cl-store (standard-object stream)
456 (restore-type-object stream))
457
458 (defrestore-cl-store (condition stream)
459 (restore-type-object stream))
460
461
462 ;; classes
463 (defstore-cl-store (obj standard-class stream)
464 (output-type-code +standard-class-code+ stream)
465 (store-object (class-name obj) stream)
466 (store-object (mapcar #'get-slot-details (class-direct-slots obj))
467 stream)
468 (store-object (mapcar (if *store-class-superclasses*
469 #'identity
470 #'class-name)
471 (class-direct-superclasses obj))
472 stream)
473 (store-object (type-of obj) stream))
474
475 (defrestore-cl-store (standard-class stream)
476 (let* ((class (restore-object stream))
477 (slots (restore-object stream))
478 (supers (restore-object stream))
479 (meta (restore-object stream))
480 (keywords '(:direct-slots :direct-superclasses
481 :metaclass))
482 (final (loop for keyword in keywords
483 for slot in (list slots
484 (or supers (list 'standard-object))
485 meta)
486 nconc (list keyword slot))))
487 (cond ((find-class class nil)
488 (cond (*nuke-existing-classes*
489 (apply #'ensure-class class final)
490 #+(and clisp (not mop)) (add-methods-for-class class slots))
491 (t (find-class class))))
492 (t (apply #'ensure-class class final)
493 #+(and clisp (not mop)) (add-methods-for-class class slots)))))
494
495 ;; built in classes
496
497 (defstore-cl-store (obj built-in-class stream)
498 (output-type-code +built-in-class-code+ stream)
499 (store-object (class-name obj) stream))
500
501 #-ecl ;; for some reason this doesn't work with ecl
502 (defmethod internal-store-object ((backend cl-store) (obj (eql (find-class 'hash-table))) stream)
503 (output-type-code +built-in-class-code+ stream)
504 (store-object 'cl:hash-table stream))
505
506 (defrestore-cl-store (built-in-class stream)
507 (find-class (restore-object stream)))
508
509
510 ;; Arrays, vectors and strings.
511 (defstore-cl-store (obj array stream)
512 (declare (optimize speed (safety 1) (debug 0)))
513 (typecase obj
514 (simple-base-string (store-simple-base-string obj stream))
515 (simple-string (store-simple-string obj stream))
516 (simple-vector (store-simple-vector obj stream))
517 ((simple-array (unsigned-byte 8) (*)) (store-simple-byte-vector obj stream))
518 (t (store-array obj stream))))
519
520
521 (defun store-array (obj stream)
522 (declare (optimize speed (safety 0) (debug 0))
523 (type array obj))
524 (output-type-code +array-code+ stream)
525 (if (and (= (array-rank obj) 1)
526 (array-has-fill-pointer-p obj))
527 (store-object (fill-pointer obj) stream)
528 (store-object nil stream))
529 (store-object (array-element-type obj) stream)
530 (store-object (adjustable-array-p obj) stream)
531 (store-object (array-dimensions obj) stream)
532 (dolist (x (multiple-value-list (array-displacement obj)))
533 (store-object x stream))
534 (store-object (array-total-size obj) stream)
535 (loop for x from 0 below (array-total-size obj) do
536 (store-object (row-major-aref obj x) stream)))
537
538
539
540
541 (defrestore-cl-store (array stream)
542 (declare (optimize speed (safety 1) (debug 0)))
543 (let* ((fill-pointer (restore-object stream))
544 (element-type (restore-object stream))
545 (adjustable (restore-object stream))
546 (dimensions (restore-object stream))
547 (displaced-to (restore-object stream))
548 (displaced-offset (restore-object stream))
549 (size (restore-object stream))
550 (res (make-array dimensions
551 :element-type element-type
552 :adjustable adjustable
553 :fill-pointer fill-pointer)))
554 (declare (type cons dimensions) (type array-tot-size size))
555 (when displaced-to
556 (adjust-array res dimensions :displaced-to displaced-to
557 :displaced-index-offset displaced-offset))
558 (resolving-object (obj res)
559 (loop for x from 0 below size do
560 (let ((pos x))
561 (setting (row-major-aref obj pos) (restore-object stream)))))))
562
563 (defun store-simple-vector (obj stream)
564 (declare (optimize speed (safety 0) (debug 0))
565 (type simple-vector obj))
566 (output-type-code +simple-vector-code+ stream)
567 (store-object (length obj) stream)
568 (loop for x across obj do
569 (store-object x stream)))
570
571 (defrestore-cl-store (simple-vector stream)
572 (declare (optimize speed (safety 1) (debug 0)))
573 (let* ((size (restore-object stream))
574 (res (make-array size)))
575 (declare (type array-size size))
576 (resolving-object (obj res)
577 (dotimes (i size)
578 ;; we need to copy the index so that
579 ;; it's value at this time is preserved.
580 (let ((x i))
581 (setting (aref obj x) (restore-object stream)))))
582 res))
583
584 (defun store-simple-byte-vector (obj stream)
585 (declare (optimize speed (safety 0) (debug 0))
586 (type (simple-array (unsigned-byte 8) (*)) obj))
587 (output-type-code +simple-byte-vector-code+ stream)
588 (store-object (length obj) stream)
589 (loop for x across obj do
590 (write-byte x stream)))
591
592 (defrestore-cl-store (simple-byte-vector stream)
593 (declare (optimize speed (safety 1) (debug 0)))
594 (let* ((size (restore-object stream))
595 (res (make-array size :element-type '(unsigned-byte 8))))
596 (declare (type array-size size))
597 (resolving-object (obj res)
598 (dotimes (i size)
599 ;; we need to copy the index so that
600 ;; it's value at this time is preserved.
601 (let ((x i))
602 (setting (aref obj x) (read-byte stream)))))
603 res))
604
605 ;; Dumping (unsigned-byte 32) for each character seems
606 ;; like a bit much when most of them will be
607 ;; base-chars. So we try to cater for them.
608 (defvar *char-marker* (code-char 255)
609 "Largest character that can be represented in 8 bits")
610
611 (defun unicode-string-p (string)
612 "An implementation specific test for a unicode string."
613 (declare (optimize speed (safety 0) (debug 0))
614 (type simple-string string))
615 #+cmu nil ;; cmucl doesn't support unicode yet.
616 #+lispworks (not (typep string 'lw:8-bit-string))
617 #-(or cmu lispworks) (some #'(lambda (x) (char> x *char-marker*)) string))
618
619 (defun store-simple-string (obj stream)
620 (declare (type simple-string obj)
621 (optimize speed (safety 1) (debug 0)))
622 (cond ((unicode-string-p obj)
623 (output-type-code +unicode-string-code+ stream)
624 (dump-string #'dump-int obj stream))
625 (t (output-type-code +simple-string-code+ stream)
626 (dump-string #'write-byte obj stream))))
627
628 (defun store-simple-base-string (obj stream)
629 (declare (type simple-string obj)
630 (optimize speed (safety 1) (debug 0)))
631 (cond ((unicode-string-p obj)
632 (output-type-code +unicode-base-string-code+ stream)
633 (dump-string #'dump-int obj stream))
634 (t (output-type-code +simple-base-string-code+ stream)
635 (dump-string #'write-byte obj stream))))
636
637 (defun dump-string (dumper obj stream)
638 (declare (simple-string obj) (function dumper) (stream stream)
639 (optimize speed (safety 1) (debug 0)))
640 (dump-int (the array-size (length obj)) stream)
641 (loop for x across obj do (funcall dumper (char-code x) stream)))
642
643 (defrestore-cl-store (simple-string stream)
644 (declare (optimize speed))
645 (undump-string #'read-byte 'character stream))
646
647 (defrestore-cl-store (unicode-string stream)
648 (declare (optimize speed))
649 (undump-string #'undump-int 'character stream))
650
651 (defrestore-cl-store (simple-base-string stream)
652 (declare (optimize speed))
653 (undump-string #'read-byte 'base-char stream))
654
655 (defrestore-cl-store (unicode-base-string stream)
656 (declare (optimize speed))
657 (undump-string #'undump-int 'base-char stream))
658
659 (defun undump-string (reader type stream)
660 (declare (type function reader) (type stream stream)
661 (optimize speed (safety 1) (debug 0)))
662 (let* ((length (the array-size (undump-int stream)) )
663 (res (make-string length :element-type type)))
664 (declare (type simple-string res))
665 (dotimes (x length)
666 (setf (schar res x) (code-char (funcall reader stream))))
667 res))
668
669 ;; packages (from Thomas Stenhaug)
670 (defstore-cl-store (obj package stream)
671 (output-type-code +package-code+ stream)
672 (store-object (package-name obj) stream)
673 (store-object (package-nicknames obj) stream)
674 (store-object (mapcar (if *store-used-packages* #'identity #'package-name)
675 (package-use-list obj))
676 stream)
677 (store-object (internal-symbols obj) stream)
678 (store-object (package-shadowing-symbols obj) stream)
679 (store-object (external-symbols obj) stream))
680
681 (defun remove-remaining (times stream)
682 (declare (optimize speed) (type fixnum times))
683 (dotimes (x times)
684 (restore-object stream)))
685
686 (defrestore-cl-store (package stream)
687 (let* ((package-name (restore-object stream))
688 (existing-package (find-package package-name)))
689 (cond ((or (not existing-package)
690 (and existing-package *nuke-existing-packages*))
691 (restore-package package-name stream :force *nuke-existing-packages*))
692 (t (remove-remaining 5 stream)
693 existing-package))))
694
695 (defun internal-symbols (package)
696 (let ((acc (make-array 100 :adjustable t :fill-pointer 0))
697 (used (package-use-list package)))
698 (do-symbols (symbol package)
699 (unless (find (symbol-package symbol) used)
700 (vector-push-extend symbol acc)))
701 acc))
702
703 (defun external-symbols (package)
704 (let ((acc (make-array 100 :adjustable t :fill-pointer 0)))
705 (do-external-symbols (symbol package)
706 (vector-push-extend symbol acc))
707 acc))
708
709 (defun restore-package (package-name stream &key force)
710 (when (and force (find-package package-name))
711 (delete-package package-name))
712 (let ((package (make-package package-name
713 :nicknames (restore-object stream)
714 :use (restore-object stream))))
715 (loop for symbol across (restore-object stream) do
716 (import symbol package))
717 (shadow (restore-object stream) package)
718 (loop for symbol across (restore-object stream) do
719 (export symbol package))
720 package))
721
722 ;; Function storing hack.
723 ;; This just stores the function name if we can find it
724 ;; or signal a store-error.
725 (defun parse-name (name)
726 (let ((name (subseq name 21)))
727 (declare (type simple-string name))
728 (if (search name "SB!" :end1 3)
729 (replace name "SB-" :end1 3)
730 name)))
731
732 #+sbcl
733 (defvar *sbcl-readtable* (copy-readtable nil))
734 #+sbcl
735 (set-macro-character #\# #'(lambda (c s)
736 (declare (ignore c s))
737 (store-error "Invalid character in function name."))
738 nil
739 *sbcl-readtable*)
740
741 (defun get-function-name (obj)
742 (multiple-value-bind (l cp name) (function-lambda-expression obj)
743 (declare (ignore l cp))
744 (cond ((and name (or (symbolp name) (consp name))) name)
745 ;; Try to deal with sbcl's naming convention
746 ;; of built in functions (pre 0.9)
747 #+sbcl
748 ((and name (stringp name)
749 (search "top level local call " (the simple-string name)))
750 (let ((new-name (parse-name name))
751 (*readtable* *sbcl-readtable*))
752 (unless (string= new-name "")
753 (handler-case (read-from-string new-name)
754 (error (c)
755 (declare (ignore c))
756 (store-error "Unable to determine function name for ~A."
757 obj))))))
758 (t (store-error "Unable to determine function name for ~A."
759 obj)))))
760
761
762 (defstore-cl-store (obj function stream)
763 (output-type-code +function-code+ stream)
764 (store-object (get-function-name obj) stream))
765
766
767
768 (defrestore-cl-store (function stream)
769 (fdefinition (restore-object stream)))
770
771 ;; Generic function, just dumps the gf-name
772 (defstore-cl-store (obj generic-function stream)
773 (output-type-code +gf-code+ stream)
774 (aif (generic-function-name obj)
775 (store-object it stream)
776 (store-error "No generic function name for ~A." obj)))
777
778 (defrestore-cl-store (generic-function stream)
779 (fdefinition (restore-object stream)))
780
781
782 (setf *default-backend* (find-backend 'cl-store))
783
784 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5