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)