From sross at common-lisp.net  Tue Oct  4 08:10:30 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  4 Oct 2005 10:10:30 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	cl-store/circularities.lisp cl-store/cl-store.asd
	cl-store/default-backend.lisp cl-store/plumbing.lisp 
Message-ID: <20051004081030.D612988592@common-lisp.net>

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



From sross at common-lisp.net  Tue Oct  4 08:10:30 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  4 Oct 2005 10:10:30 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <20051004081030.9AB028855E@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/sbcl
In directory common-lisp.net:/tmp/cvs-serv8165/sbcl

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-10-04
Date: Tue Oct  4 10:10:29 2005
Author: sross

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.8 cl-store/sbcl/custom.lisp:1.9
--- cl-store/sbcl/custom.lisp:1.8	Thu May  5 14:58:57 2005
+++ cl-store/sbcl/custom.lisp	Tue Oct  4 10:10:29 2005
@@ -52,9 +52,10 @@
   (slot-value dd 'sb-kernel::name))
 
 (defvar *sbcl-struct-inherits*
-  (list (get-layout (find-class t))
-        (get-layout (find-class 'sb-kernel:instance))
-        (get-layout (find-class 'cl:structure-object))))
+  `(,(get-layout (find-class t))
+    ,@(when-let (class (find-class 'sb-kernel:instance nil))
+        (list (get-layout (find-class 'sb-kernel:instance))))
+    ,(get-layout (find-class 'cl:structure-object))))
 
 (defstruct (struct-def (:conc-name sdef-))
   (supers (required-arg :supers) :type list)



From sross at common-lisp.net  Tue Oct  4 08:14:02 2005
From: sross at common-lisp.net (Sean Ross)
Date: Tue,  4 Oct 2005 10:14:02 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/sbcl/custom.lisp 
Message-ID: <20051004081402.DAF918855E@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store/sbcl
In directory common-lisp.net:/tmp/cvs-serv8226/sbcl

Modified Files:
	custom.lisp 
Log Message:
Changelog 2005-10-04
Date: Tue Oct  4 10:14:02 2005
Author: sross

Index: cl-store/sbcl/custom.lisp
diff -u cl-store/sbcl/custom.lisp:1.9 cl-store/sbcl/custom.lisp:1.10
--- cl-store/sbcl/custom.lisp:1.9	Tue Oct  4 10:10:29 2005
+++ cl-store/sbcl/custom.lisp	Tue Oct  4 10:14:02 2005
@@ -54,7 +54,7 @@
 (defvar *sbcl-struct-inherits*
   `(,(get-layout (find-class t))
     ,@(when-let (class (find-class 'sb-kernel:instance nil))
-        (list (get-layout (find-class 'sb-kernel:instance))))
+        (list (get-layout class)))
     ,(get-layout (find-class 'cl:structure-object))))
 
 (defstruct (struct-def (:conc-name sdef-))



From sross at common-lisp.net  Thu Oct  6 07:50:24 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  6 Oct 2005 09:50:24 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/ChangeLog
	cl-store/backends.lisp 
Message-ID: <20051006075024.ED1878855F@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv13921

Modified Files:
	ChangeLog backends.lisp 
Log Message:
Changelog 2004-10-06
Date: Thu Oct  6 09:49:57 2005
Author: sross

Index: cl-store/ChangeLog
diff -u cl-store/ChangeLog:1.36 cl-store/ChangeLog:1.37
--- cl-store/ChangeLog:1.36	Tue Oct  4 10:10:26 2005
+++ cl-store/ChangeLog	Thu Oct  6 09:49:45 2005
@@ -1,3 +1,8 @@
+2005-10-06 Sean Ross <sross at common-lisp.net>
+	* backends.lisp: Fixed type definition for 
+	compatible-magic-numbers from integer to list.
+	Reported by Bryan O'Connor.
+	
 2005-10-04 Sean Ross <sross at common-lisp.net>
 	* sbcl/custom.lisp: sb-kernel:instance is no
 	longer a class (since 0.9.5.3 or so). Fixed


Index: cl-store/backends.lisp
diff -u cl-store/backends.lisp:1.11 cl-store/backends.lisp:1.12
--- cl-store/backends.lisp:1.11	Wed May 18 17:34:09 2005
+++ cl-store/backends.lisp	Thu Oct  6 09:49:46 2005
@@ -15,9 +15,9 @@
   ((name :accessor name :initform "Unknown" :initarg :name :type symbol)
    (magic-number :accessor magic-number :initarg :magic-number :type integer)
    (compatible-magic-numbers :accessor compatible-magic-numbers
-                             :initarg :compatible-magic-numbers :type integer)
+                             :initarg :compatible-magic-numbers :type list)
    (old-magic-numbers :accessor old-magic-numbers :initarg :old-magic-numbers
-                      :type cons)
+                      :type list)
    (stream-type :accessor stream-type :initarg :stream-type :type (or symbol cons)
                 :initform (required-arg :stream-type)))
   (:documentation "Core class which custom backends must extend"))



From sross at common-lisp.net  Thu Oct  6 07:53:04 2005
From: sross at common-lisp.net (Sean Ross)
Date: Thu,  6 Oct 2005 09:53:04 +0200 (CEST)
Subject: [cl-store-cvs] CVS update: cl-store/cl-store.asd 
Message-ID: <20051006075304.B39BB8855F@common-lisp.net>

Update of /project/cl-store/cvsroot/cl-store
In directory common-lisp.net:/tmp/cvs-serv13971

Modified Files:
	cl-store.asd 
Log Message:
Changelog 2004-10-06
Date: Thu Oct  6 09:53:04 2005
Author: sross

Index: cl-store/cl-store.asd
diff -u cl-store/cl-store.asd:1.33 cl-store/cl-store.asd:1.34
--- cl-store/cl-store.asd:1.33	Tue Oct  4 10:10:26 2005
+++ cl-store/cl-store.asd	Thu Oct  6 09:53:04 2005
@@ -40,7 +40,7 @@
   :name "CL-STORE"
   :author "Sean Ross <sdr at jhb.ucs.co.za>"
   :maintainer "Sean Ross <sdr at jhb.ucs.co.za>"
-  :version "0.6.3"
+  :version "0.6.4"
   :description "Serialization package"
   :long-description "Portable CL Package to serialize data"
   :licence "MIT"