[rucksack-cvs] CVS rucksack

[alemmens]

Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv24110

Modified Files:
	do.txt done.txt rucksack.asd serialize.lisp 
Log Message:
Version 0.1.6 - Added serializing/deserializing of structures.  Only
works on SBCL.  (Thanks to Levente Mészáros.)


--- /project/rucksack/cvsroot/rucksack/do.txt	2006/09/04 12:34:34	1.5
+++ /project/rucksack/cvsroot/rucksack/do.txt	2007/01/22 10:23:14	1.6
@@ -1,14 +1,10 @@
 DO: 
 
-- In SBCL, FINALIZE-INHERITANCE is not called when a class was redefined
-  and a new instance of the redefined class is created.  (In Lispworks,
-  it *is* called then.)
-
-- Make Rucksack crash proof.  (Use a copying GC?)
-
 - There's still a btree bug that's detected (very rarely) by the
   stress test.  Fix it.
 
+- Make Rucksack crash proof.  (Use a copying GC?)
+
 - Check that btrees actually signal an error for duplicate keys.
   Handle those errors correctly for slot indexes.
 
--- /project/rucksack/cvsroot/rucksack/done.txt	2006/11/30 10:45:34	1.6
+++ /project/rucksack/cvsroot/rucksack/done.txt	2007/01/22 10:23:14	1.7
@@ -1,3 +1,9 @@
+* 2007-01-21 - version 0.1.6
+
+- Added serializing/deserializing of structures.  Only works on SBCL.
+  (Thanks to Levente Mészáros.)
+
+
 * 2006-11-30
 
 - FLET MAP-INDEXES should be LABELS MAP-INDEXES (thanks to Cyrus Harmon)
--- /project/rucksack/cvsroot/rucksack/rucksack.asd	2007/01/20 18:17:55	1.7
+++ /project/rucksack/cvsroot/rucksack/rucksack.asd	2007/01/22 10:23:14	1.8
@@ -1,9 +1,9 @@
-;;; $Id: rucksack.asd,v 1.7 2007/01/20 18:17:55 alemmens Exp $
+;;; $Id: rucksack.asd,v 1.8 2007/01/22 10:23:14 alemmens Exp $
 
 (in-package :cl-user)
 
 (asdf:defsystem :rucksack
-  :version "0.1.5"
+  :version "0.1.6"
   :serial t
   :components ((:file "queue")
                (:file "package")
--- /project/rucksack/cvsroot/rucksack/serialize.lisp	2007/01/20 18:17:55	1.9
+++ /project/rucksack/cvsroot/rucksack/serialize.lisp	2007/01/22 10:23:14	1.10
@@ -1,4 +1,4 @@
-;; $Id: serialize.lisp,v 1.9 2007/01/20 18:17:55 alemmens Exp $
+;; $Id: serialize.lisp,v 1.10 2007/01/22 10:23:14 alemmens Exp $
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Serialize
@@ -170,6 +170,7 @@
 (defconstant +unbound-slot+             #x71)
 (defconstant +shared-object-definition+ #x72)
 (defconstant +shared-object-reference+  #x73)
+(defconstant +structure-object+         #x77)
 
 ;; Rest
 
@@ -1133,9 +1134,57 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Structures
 ;;;
-;;; Can't be serialized portably.  Let's forget about them here.
+;;; Can't be serialized portably.  The version below works for SBCL at the
+;;; moment, but using structures in Rucksack is risky: if a structure 
+;;; definition changes, Rucksack won't know about it and you'll probably
+;;; run into big problems.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+#+sbcl
+(defmethod serialize ((object structure-object) serializer)
+  (serialize-structure-object object serializer))
+
+(defun serialize-structure-object (object serializer)
+  ;; A structure object is serialized as:
+  ;; - structure name
+  ;; - number of slots
+  ;; - slot values
+  (serialize-marker +structure-object+ serializer)
+  (serialize (class-name (class-of object)) serializer)
+  (save-slots object serializer))
+
+(defmethod save-slots ((object structure-object) serializer)
+  (let ((slots (saved-slots object)))
+    (serialize (length slots) serializer)
+    (loop for slot-name in (saved-slots object)
+          do (serialize (slot-value object slot-name) serializer))))
+
+#+sbcl
+(defmethod deserialize-contents ((marker (eql +structure-object+)) serializer)
+  (let* ((class-name (deserialize serializer))
+         (object (allocate-instance (find-class class-name))))
+    (load-slots object serializer)))
+
+(defmethod load-slots ((object structure-object) stream)
+  (let ((nr-slots (deserialize stream))
+        (slots (saved-slots object)))
+    (unless (= nr-slots (length slots))
+      (error "Slot mismatch while deserializing a structure object of class ~S."
+             (class-of object)))
+    (loop for slot-name in (saved-slots object)
+          do (let ((marker (read-next-marker stream)))
+               (setf (slot-value object slot-name)
+                     (deserialize-contents marker stream))))
+    object))
+
+(defmethod scan-contents ((marker (eql +structure-object+)) serializer gc)
+  ;; Skip class name
+  (scan serializer gc)
+  ;; Scan all slots
+  (let ((nr-slots (deserialize serializer)))
+    (loop repeat nr-slots
+      do (scan serializer gc))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Arrays
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;