[elephant-cvs] CVS elephant/src/elephant

[ieslick]

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

Modified Files:
	classindex.lisp collections.lisp serializer2.lisp 
	unicode2.lisp 
Log Message:
Fixed lispworks serialization issues with floats & strings; fixed remove-derived-index bug that wouldn't properly delete

--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2007/03/08 21:29:53	1.27
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2007/03/18 20:40:50	1.28
@@ -302,22 +302,21 @@
 	(error "Duplicate derived index requested named ~A on class ~A" name (class-name class))
 	(progn
 	  (when update-class (register-derived-index class name))
-;;	  (with-transaction (:store-controller sc)
-	    (add-index class-idx
-		       :index-name (make-derived-name name)
-		       :key-form (make-derived-key-form derived-defun)
-		       :populate populate)))))
+	  (add-index class-idx
+		     :index-name (make-derived-name name)
+		     :key-form (make-derived-key-form derived-defun)
+		     :populate populate)))))
 
 (defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*))
   (remove-class-derived-index (find-class class) name :sc sc))
 	     
 (defmethod remove-class-derived-index ((class persistent-metaclass) name &key 
 				       (sc *store-controller*) (update-class t))
-  (if (find-inverted-index class name :null-on-fail t)
+  (if (find-inverted-index class (make-derived-name name) :null-on-fail t)
       (progn
 	(when update-class (unregister-derived-index class name))
 	(with-transaction (:store-controller sc)
-	  (remove-index (find-class-index class :sc sc) name))
+	  (remove-index (find-class-index class :sc sc) (make-derived-name name)))
 	t)
       (progn
 	(warn "Derived index ~A does not exist in ~A" name (class-name class))
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2007/03/11 03:31:09	1.13
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2007/03/18 20:40:50	1.14
@@ -404,7 +404,7 @@
 (defun print-btree-entry (k v) 
   (format t "key: ~A / value: ~A~%" k v))
 
-(defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil))
+(defun dump-btree (bt &key (print-fn #'print-btree-entry) (count nil))
   "Print the contents of a btree for easy inspection & debugging"
   (format t "DUMP ~A~%" bt)
   (let ((i 0))
--- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/02/26 19:12:18	1.30
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp	2007/03/18 20:40:50	1.31
@@ -81,6 +81,9 @@
 (defconstant +struct+               20)
 (defconstant +class+                21)
 
+;; Lispworks support
+(defconstant +short-float+          30)
+
 (defconstant +nil+                  #x3F)
 (defconstant +reserved-dbinfo+      #xF0)
 
@@ -201,6 +204,10 @@
 		    (setf tp (class-name (class-of frob))))
 		(%serialize tp))
 	      )
+	     #+lispworks
+	     (short-float
+	      (buffer-write-byte +short-float+ bs)
+	      (buffer-write-float (coerce frob 'single-float) bs))
 	     #-(and :lispworks (or :win32 :linux))
 	     (single-float
 	      (buffer-write-byte +single-float+ bs)
@@ -339,6 +346,7 @@
   `((,+fixnum32+ . "fixnum32")
     (,+fixnum64+ . "fixnum32")
     (,+char+ . "char")
+    (,+short-float+ . "short-float")
     (,+single-float+ . "single-float")
     (,+double-float+ . "double float")
     (,+negative-bignum+ . "neg bignum")
@@ -402,10 +410,19 @@
 	      (buffer-read-fixnum64 bs))
 	     ((= tag +nil+) nil)
 	     ((= tag +utf8-string+)
+	      #+lispworks
+	      (coerce (deserialize-string :utf8 bs) 'base-string)
+	      #-lispworks
 	      (deserialize-string :utf8 bs))
 	     ((= tag +utf16-string+)
+	      #+lispworks
+	      (coerce (deserialize-string :utf16le bs) 'lw:text-string)
+	      #-lispworks
 	      (deserialize-string :utf16le bs))
 	     ((= tag +utf32-string+)
+	      #+lispworks
+	      (coerce (deserialize-string :utf32le bs) 'sys:augmented-string)
+	      #-lispworks
 	      (deserialize-string :utf32le bs))
 	     ((= tag +symbol+)
 	      (let ((name (%deserialize bs))
@@ -415,6 +432,9 @@
 	      (get-cached-instance sc
 				   (buffer-read-fixnum32 bs)
 				   (%deserialize bs)))
+	     #+lispworks
+	     ((= tag +short-float+)
+	      (coerce (buffer-read-float bs) 'short-float))
 	     ((= tag +single-float+)
 	      (buffer-read-float bs))
 	     ((= tag +double-float+)
--- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/02/25 20:02:32	1.6
+++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp	2007/03/18 20:40:50	1.7
@@ -199,6 +199,10 @@
 
 (defgeneric deserialize-string (type bstream &optional temp-string))
 
+(defmethod deserialize-string :around ((type t) bstream &optional temp-string)
+  #+lispworks (coerce (call-next-method) 'lispworks:simple-text-string)
+  #-lispworks (call-next-method))
+
 (defmethod deserialize-string ((type (eql :utf8)) bstream &optional temp-string)
   (declare (type buffer-stream bstream))
   ;; Default char-code method