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