Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv8165
Modified Files:
ChangeLog circularities.lisp cl-store.asd default-backend.lisp
plumbing.lisp
Log Message:
Changelog 2005-10-04
Date: Tue Oct 4 10:10:26 2005
Author: sross
Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.35 cl-store/ChangeLog:1.36
--- cl-store/ChangeLog:1.35 Fri Sep 9 16:59:17 2005
+++ cl-store/ChangeLog Tue Oct 4 10:10:26 2005
@@ -1,3 +1,13 @@
+2005-10-04 Sean Ross <sross(a)common-lisp.net>
+ * sbcl/custom.lisp: sb-kernel:instance is no
+ longer a class (since 0.9.5.3 or so). Fixed
+ definition of *sbcl-struct-inherits* to work
+ with or without this class. Reported by Rafał Strzaliński.
+
+2005-09-20 Sean Ross <sross(a)common-lisp.net>
+ * default-backend.lisp: Changed storing and restoring
+ of standard-object to not create unnecessary garbage.
+
2005-09-09 Sean Ross <sross(a)common-lisp.net>
* default-backend.lisp: Altered list serialization to store
all types of lists (proper, dotted and circular) in N time,
Index: cl-store/circularities.lisp
diff -u cl-store/circularities.lisp:1.23 cl-store/circularities.lisp:1.24
--- cl-store/circularities.lisp:1.23 Thu Sep 1 12:24:55 2005
+++ cl-store/circularities.lisp Tue Oct 4 10:10:26 2005
@@ -170,7 +170,7 @@
(make-hash-table :test #'eq
:size *restore-hash-size*))))
(check-magic-number backend place)
- (multiple-value-prog1
+ (prog1
(backend-restore-object backend place)
(dolist (fn *need-to-fix*)
(force fn)))))
@@ -192,7 +192,7 @@
(defun handle-restore (place backend)
(declare (optimize speed (safety 1) (debug 0)))
- (multiple-value-bind (reader) (get-next-reader backend place)
+ (let ((reader (get-next-reader backend place)))
(declare (type symbol reader))
(cond ((referrerp backend reader)
(incf *restore-counter*)
Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.32 cl-store/cl-store.asd:1.33
--- cl-store/cl-store.asd:1.32 Fri Sep 9 16:59:17 2005
+++ cl-store/cl-store.asd Tue Oct 4 10:10:26 2005
@@ -40,7 +40,7 @@
:name "CL-STORE"
:author "Sean Ross <sdr(a)jhb.ucs.co.za>"
:maintainer "Sean Ross <sdr(a)jhb.ucs.co.za>"
- :version "0.6.1"
+ :version "0.6.3"
:description "Serialization package"
:long-description "Portable CL Package to serialize data"
:licence "MIT"
Index: cl-store/default-backend.lisp
diff -u cl-store/default-backend.lisp:1.31 cl-store/default-backend.lisp:1.32
--- cl-store/default-backend.lisp:1.31 Fri Sep 9 16:59:17 2005
+++ cl-store/default-backend.lisp Tue Oct 4 10:10:26 2005
@@ -21,7 +21,6 @@
code)
-
;; Type code constants
(defvar +referrer-code+ (register-code 1 'referrer nil))
(defvar +unicode-string-code+ (register-code 3 'unicode-string nil))
@@ -78,6 +77,7 @@
(read-byte stream))
(defmethod referrerp ((backend cl-store) (reader t))
+ (declare (optimize speed (safety 0) (space 0) (debug 0)))
(eql reader 'referrer))
(defvar *restorers* (restorers (find-backend 'cl-store)))
@@ -86,10 +86,11 @@
;; backend to lookup the function that was defined by
;; defrestore-cl-store to restore it, or nil if not found.
(defun lookup-code (code)
+ (declare (optimize speed (safety 0) (space 0) (debug 0)))
(gethash code *restorers*))
(defmethod get-next-reader ((backend cl-store) (stream stream))
- (declare (optimize speed))
+ (declare (optimize speed (safety 0) (space 0) (debug 0)))
(let ((type-code (read-type-code stream)))
(or (lookup-code type-code)
(error "Type code ~A is not registered." type-code))))
@@ -104,13 +105,19 @@
(make-referrer :val (undump-int stream)))
+
;; integers
;; The theory is that most numbers will fit in 32 bits
;; so we we have a little optimization for it
;; We need this for circularity stuff.
(defmethod int-or-char-p ((backend cl-store) (type symbol))
- (find type '(integer character 32-bit-integer)))
+ (declare (optimize speed (safety 0) (space 0) (debug 0)))
+ (or (eql type '32-bit-integer)
+ (eql type 'integer)
+ (eql type 'character)))
+
+; (find type '(integer character 32-bit-integer)))
(defstore-cl-store (obj integer stream)
(declare (optimize speed (safety 1) (debug 0)))
@@ -238,6 +245,7 @@
(/ (the integer (restore-object stream))
(the integer (restore-object stream))))
+
;; chars
(defstore-cl-store (obj character stream)
(output-type-code +character-code+ stream)
@@ -377,25 +385,34 @@
(restore-object stream))))
hash)))
+;; The dumping of objects works by serializing the type of the object which
+;; is followed by applicable slot-name and value (depending on whether the
+;; slot is bound, it's allocation and *store-class-slots*). Once each slot
+;; is serialized a counter is incremented which is stored at the end.
+;; When restoring the object a new instance is allocated and then
+;; restore-type-object starts reading objects from the stream.
+;; If the restored object is a symbol the it names a slot and it's value
+;; is pulled out and set on the newly allocated object.
+;; If the restored object is an integer then this is the end marker
+;; for the object and the number of slots restored is checked against
+;; this counter.
+
;; Object and Conditions
(defun store-type-object (obj stream)
(declare (optimize speed))
- (let* ((all-slots (remove-if-not (lambda (x)
- (slot-boundp obj (slot-definition-name x)))
- (serializable-slots obj)))
- (slots (if *store-class-slots*
- all-slots
- (delete-if #'(lambda (x) (eql (slot-definition-allocation x)
- :class))
- all-slots))))
- (declare (type list slots))
+ (let ((all-slots (serializable-slots obj))
+ (length 0))
(store-object (type-of obj) stream)
- (store-object (length slots) stream)
- (dolist (slot slots)
+ (dolist (slot all-slots)
(let ((slot-name (slot-definition-name slot)))
- (store-object slot-name stream)
- (store-object (slot-value obj slot-name) stream)))))
-
+ (when (and (slot-boundp obj slot-name)
+ (or *store-class-slots*
+ (not (eql (slot-definition-allocation slot)
+ :class))))
+ (store-object (slot-definition-name slot) stream)
+ (store-object (slot-value obj slot-name) stream)
+ (incf length))))
+ (store-object length stream)))
(defstore-cl-store (obj standard-object stream)
(output-type-code +standard-object-code+ stream)
@@ -408,15 +425,18 @@
(defun restore-type-object (stream)
(declare (optimize speed))
(let* ((class (find-class (restore-object stream)))
- (length (restore-object stream))
(new-instance (allocate-instance class)))
- (declare (type integer length))
- (loop repeat length do
- (let ((slot-name (restore-object stream)))
- ;; slot-names are always symbols so we don't
- ;; have to worry about circularities
- (resolving-object (obj new-instance)
- (setting (slot-value obj slot-name) (restore-object stream)))))
+ (resolving-object (obj new-instance)
+ (loop for count from 0 do
+ (let ((slot-name (restore-object stream)))
+ (etypecase slot-name
+ (integer (assert (= count slot-name) (count slot-name)
+ "Number of slots restored does not match slots stored.")
+ (return))
+ (symbol
+ ;; slot-names are always symbols so we don't
+ ;; have to worry about circularities
+ (setting (slot-value obj slot-name) (restore-object stream)))))))
new-instance))
(defrestore-cl-store (standard-object stream)
Index: cl-store/plumbing.lisp
diff -u cl-store/plumbing.lisp:1.17 cl-store/plumbing.lisp:1.18
--- cl-store/plumbing.lisp:1.17 Thu Sep 1 12:24:55 2005
+++ cl-store/plumbing.lisp Tue Oct 4 10:10:26 2005
@@ -62,7 +62,7 @@
(defun store-to-file (obj place backend)
(declare (type backend backend)
(optimize speed))
- (let* ((element-type (stream-type backend)))
+ (let ((element-type (stream-type backend)))
(with-open-file (s place :element-type element-type
:direction :output :if-exists :supersede)
(backend-store backend s obj))))
@@ -163,7 +163,7 @@
(defun restore-from-file (place backend)
(declare (optimize speed))
- (let* ((element-type (stream-type backend)))
+ (let ((element-type (stream-type backend)))
(with-open-file (s place :element-type element-type :direction :input)
(backend-restore backend s))))
