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@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@common-lisp.net + * default-backend.lisp: Changed storing and restoring + of standard-object to not create unnecessary garbage. + 2005-09-09 Sean Ross sross@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@jhb.ucs.co.za" :maintainer "Sean Ross sdr@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))))