[elephant-cvs] CVS elephant/src/elephant

[rread]

Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv22716/src/elephant

Modified Files:
	classes.lisp classindex-utils.lisp classindex.lisp 
	elephant.lisp serializer.lisp 
Log Message:
Workaround for SBCL 0.9.9 weirdness and making the tests repeatably runnable.


--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2006/02/25 20:53:57	1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2006/03/01 18:57:34	1.8
@@ -130,6 +130,7 @@
 	;;   situation where we write the class or index page that we are currently reading 
 	;;   via a cursor without going through the cursor abstraction. There has to be a 
 	;;   better way to do this.
+
 	(when (and (indexed class) (not from-oid))
 	  (let ((class-index (find-class-index class)))
 	    (when class-index
--- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp	2006/02/19 04:53:00	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp	2006/03/01 18:57:34	1.2
@@ -139,5 +139,29 @@
     (disable-class-indexing name)
     (flush-instance-cache *store-controller*)
     (setf (find-class name) nil)))
-    
-
+  
+  
+;; Rob created this just for some debugging.
+;; It seesm theoretically possible that we could make
+;; a function that fully checks the consinstency of the index;
+;; that is, that the indexed classes indeed exist in the store.
+(defun dump-class-index (c)
+  (let ((idx (find-class-index c)))
+    (dump-btree
+     idx)
+    )
+)
+(defun report-indexed-classes (&key (class nil) (sc *store-controller*))
+  (format t "indexed-classes:~%")
+  (let ((bt (controller-class-root sc)))
+    (declare (type btree bt))
+    (dump-btree bt)
+    (if class 
+	(dump-class-index class)
+	(map-btree
+	 #'(lambda (k v) 
+	     (dump-class-index k)
+	     )
+	 bt))
+    )
+  )
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/02/25 20:53:57	1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/03/01 18:57:34	1.6
@@ -98,6 +98,9 @@
 (defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t))
   (find-class-index (find-class class-name) :sc sc :errorp errorp))
 
+(defmethod class-indexedp-by-name ((class-name symbol) &key (sc *store-controller*) (errorp t))
+  (get-value class-name (controller-class-root sc)))
+
 (defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*) (errorp t))
   (ensure-finalized class)
   (if (not (indexed class))
--- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp	2006/02/21 19:40:03	1.2
+++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp	2006/03/01 18:57:34	1.3
@@ -70,6 +70,8 @@
 	   #:add-class-slot-index #:remove-class-slot-index
 	   #:add-class-derived-index #:remove-class-derived-index
 	   #:describe-db-class-index
+	   #:report-indexed-classes
+	   #:class-indexedp-by-name
 
 	   ;; Low level cursor API
 	   #:make-inverted-cursor #:make-class-cursor
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2006/02/19 04:53:00	1.1
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2006/03/01 18:57:34	1.2
@@ -69,7 +69,7 @@
   (labels 
       ((%serialize (frob)
 	 (declare (optimize (speed 3) (safety 0)))
-	 (etypecase frob
+	 (typecase frob
 	   (fixnum
 	    (buffer-write-byte +fixnum+ bs)
 	    (buffer-write-int frob bs))
@@ -115,7 +115,17 @@
 	   (persistent
 	    (buffer-write-byte +persistent+ bs)
 	    (buffer-write-int (oid frob) bs)
-	    (%serialize (type-of frob)))
+	    ;; This circumlocution is necessitated by 
+	    ;; an apparent bug in SBCL 9.9 --- type-of sometimes
+	    ;; does NOT return the "proper name" of the class as the
+	    ;; CLHS says it should, but gives the class object itself,
+	    ;; which cannot be directly serialized....
+	    (let ((tp (type-of frob)))
+	      #+(or sbcl)
+	      (if (not (symbolp tp))
+		  (setf tp (class-name (class-of frob))))
+	      (%serialize tp))
+	      )
 	   #-(and :lispworks (or :win32 :linux))
 	   (single-float
 	    (buffer-write-byte +single-float+ bs)