March 2007 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/elephant
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27429/src/elephant Modified Files: serializer2.lisp Log Message: single-float fix for serializer --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/18 20:40:50 1.31 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/19 20:51:28 1.32 @@ -208,7 +208,6 @@ (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) (buffer-write-float frob bs))

1 0

[elephant-cvs] CVS elephant
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv22128 Modified Files: TODO config.sexp ele-bdb.asd elephant.asd Log Message: Path creation changes for win32 (need to remove cl-ppcre dependencies) --- /project/elephant/cvsroot/elephant/TODO 2007/03/19 19:41:35 1.72 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/19 20:35:30 1.73 @@ -11,17 +11,10 @@ TASKS TO GET TO BETA: -Bugs: -- Lispworks/Mac: error in finalize indexed class -- Lispworks/Mac: %oid missing in BDB-BTREE on close -- Lispworks/Mac: fix warning in ensure-class-using-class :around (eql nil) method -- Fix build for Win32 (Frank) - Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) Lisp Support: -- Validate Lispworks on Mac - Validate Lispworks on PC - Validate OpenMCL pre-1.1 on Mac OS X - Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? --- /project/elephant/cvsroot/elephant/config.sexp 2007/02/22 20:19:57 1.7 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/03/19 20:35:30 1.8 @@ -1,11 +1,38 @@ -((:berkeley-db-include-dir . "/opt/local/BerkeleyDB.4.5/") +#+(or sbcl allegro) +((:berkeley-db-include-dir . "/opt/local/include/db45/") (:berkeley-db-lib-dir . "/opt/local/lib/db45/") - (:berkeley-db-lib . "/opt/local/BerkeleyDB.4.5/lib/libDB-4.5.dylib") + (:berkeley-db-lib . "/opt/local/lib/db45/libdb-4.5.dylib") (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") (:pthread-lib . nil) (:clsql-lib . nil) (:compiler . :gcc)) +#+openmcl +((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.5/include/") + (:berkeley-db-lib-dir . "/usr/local/BerkeleyDB.4.5/lib/") + (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.5/lib/libdb-4.5.dylib") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :gcc)) + +#+(and lispworks (not windows)) +((:berkeley-db-include-dir . "/opt/local/include/db45/") + (:berkeley-db-lib-dir . "/opt/local/lib/db45/") + (:berkeley-db-lib . "/opt/local/lib/db45/libdb-4.5.dylib") + (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :gcc)) + +#+(or mswindows windows) +((:berkeley-db-include-dir . "C:/Programme/Oracle/Berkeley DB 4.5.20/include/") + (:berkeley-db-lib-dir . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/") + (:berkeley-db-lib . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/libdb45.dll") + (:berkeley-db-deadlock . "C:/Programme/Oracle/Berkeley DB 4.5.20/bin/db_deadlock.exe") + (:pthread-lib . nil) + (:clsql-lib . nil) + (:compiler . :cygwin)) + ;; Berkeley 4.5 is required, each system will have different settings for ;; these directories, use this as an indication of what each key means ;; --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/18 20:40:50 1.22 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/19 20:35:30 1.23 @@ -27,6 +27,18 @@ ;; Compile bdb lib and load libraries ;; +#+(or windows mswindows) +(defun path-for-cygwin (path) + "DOS pathname -> cygwin pathname. Replace backslashes with slashes and drive letter with directory. +\"C:\\dir\\\" -> \"/C/dir\" (drive C: must be mounted as /C/ in cgwin." + (let ((result (namestring path))) + (setf result (cl-ppcre:regex-replace "([A-Z]):" + result + #'(lambda (match &rest registers) + (format nil "/~a" (first registers))) + :simple-calls t)) + (setf result (cl-ppcre:regex-replace-all "\\" result "/")))) + (defclass bdb-c-source (elephant-c-source) ()) (defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) @@ -38,18 +50,18 @@ (subseq (pathname-name (make-pathname :defaults (get-config-option :berkeley-db-lib c)) ) 3)) - (defmethod compiler-options ((compiler (eql :cygwin)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c) - (call-next-method) - (list "-ldb45"))) + (list "-ldb45") + (call-next-method))) (defun library-directories (c) (let ((include (make-pathname :defaults (get-config-option :berkeley-db-include-dir c))) (lib (make-pathname :defaults (get-config-option :berkeley-db-lib-dir c)))) #+(or windows mswindows) - (list (format nil "-L\"~A\"" lib) (format nil "-I\"~A\"" include)) + (list (format nil "-L'~A'" (path-for-cygwin lib)) + (format nil "-I'~A'" (path-for-cygwin include))) #-(or windows mswindows) (list (format nil "-L~A" lib) (format nil "-I~A" include)))) --- /project/elephant/cvsroot/elephant/elephant.asd 2007/03/16 14:44:44 1.37 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/03/19 20:35:30 1.38 @@ -97,7 +97,8 @@ #+(or mswindows windows) (progn (let* ((pathname (component-pathname c)) - (directory (directory-namestring pathname)) + (directory #+lispworks (make-pathname :host (pathname-host pathname) :directory (pathname-directory pathname)) + #-lispworks (make-pathname :device (pathname-device pathname) :directory (pathname-directory pathname))) (stdout-lines) (stderr-lines) (exit-status)) (let ((command (format nil "~A ~{~A ~}" (c-compiler-path c)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv8886/tests Modified Files: mop-tests.lisp Log Message: Fixed lispworks MOP support; lispworks is green under Mac OS X --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2007/02/03 04:09:14 1.12 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2007/03/19 19:41:36 1.13 @@ -44,22 +44,27 @@ (slot2 :accessor slot2 :transient t) (slot3 :accessor slot3 :allocation :class :transient t)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'p-class)) (defclass nonp-class () ((slot1 :accessor slot1) (slot2 :accessor slot2) (slot3 :accessor slot3 :allocation :class))) + (finalize-inheritance (find-class 'nonp-class)) (defclass minus-p-class () ((slot1 :accessor slot1 :transient t) (slot2 :accessor slot2) (slot3 :accessor slot3)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'minus-p-class)) (defclass switch-transient () ((slot1 :accessor slot1 :transient t) (slot2 :accessor slot2)) (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'switch-transient)) (defclass make-persistent () ((slot2 :accessor slot2)) - (:metaclass persistent-metaclass))) + (:metaclass persistent-metaclass)) + (finalize-inheritance (find-class 'make-persistent))) t) (deftest bad-inheritence

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv8886/src/elephant Modified Files: classes.lisp classindex.lisp metaclasses.lisp package.lisp Log Message: Fixed lispworks MOP support; lispworks is green under Mac OS X --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/08 21:29:53 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/19 19:41:35 1.22 @@ -47,14 +47,14 @@ ;; METACLASS INITIALIZATION AND CHANGES ;; ================================================ -(defmethod ensure-class-using-class :around ((class (eql nil)) name &rest args &key index) +(defmethod ensure-class-using-class :around ((class null) name &rest args &key index) "Support the :index class option" (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args)))) (when (and index (subtypep (type-of result) 'persistent-metaclass)) (update-indexed-record result nil :class-indexed t)) result)) -(defmethod ensure-class-using-class :around ((class persistent-metaclass) name &rest args &key index) +(defmethod ensure-class-using-class ((class persistent-metaclass) name &rest args &key index) "Support the :index class option on redefinition" (let ((result (apply #'call-next-method class name (remove-keywords '(:index) args)))) (when index @@ -222,28 +222,28 @@ (call-next-method))) -;; -;; SLOT ACCESS PROTOCOLS -;; +;; ============================================= +;; SHARED SLOT ACCESS PROTOCOL DEFINITIONS +;; ============================================= -(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-value-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name))) -(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod (setf slot-value-using-class) (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (if (indexed class) (indexed-slot-writer class instance slot-def new-value) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer (get-con instance) new-value instance name)))) -(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp (get-con instance) instance name))) -(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) +(defmethod slot-boundp-using-class ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) "Checks if the slot exists in the database." (loop for slot in (class-slots class) for matches-p = (eq (slot-definition-name slot) slot-name) @@ -253,7 +253,7 @@ (persistent-slot-boundp (get-con instance) instance slot-name) (call-next-method))))) -(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Removes the slot value from the database." (if (indexed class) (indexed-slot-makunbound class instance slot-def) @@ -268,12 +268,14 @@ ;; #+allegro -(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) +(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) (loop for slot in (class-slots class) - until (eq (slot-definition-name slot) slot-name) - finally (return (if (typep slot 'persistent-slot-definition) - (slot-makunbound-using-class class instance slot) - (call-next-method))))) + until (eq (slot-definition-name slot) slot-name) + finally (return (if (typep slot 'persistent-slot-definition) + (if (indexed class) + (indexed-slot-makunbound class instance slot) + (slot-makunbound-using-class class instance slot)) + (call-next-method))))) #+allegro @@ -346,3 +348,36 @@ (make-persistent-slot-boundp name))) slot-def) +;; +;; LISPWORKS +;; + +#+lispworks +(defmethod slot-value-using-class ((class persistent-metaclass) (instance persistent-object) slot) + (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name) + (find slot (class-slots class))))) + (if (typep slot-def 'persistent-slot-definition) + (persistent-slot-reader (get-con instance) instance (slot-definition-name slot-def)) + (call-next-method class instance (slot-definition-name slot-def))))) + +#+lispworks +(defmethod (setf slot-value-using-class) (new-value (class persistent-metaclass) (instance persistent-object) slot) + "Set the slot value in the database." + (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name) + (find slot (class-slots class))))) + (if (typep slot-def 'persistent-slot-definition) + (if (indexed class) + (indexed-slot-writer class instance slot-def new-value) + (persistent-slot-writer (get-con instance) new-value instance (slot-definition-name slot-def))) + (call-next-method new-value class instance (slot-definition-name slot-def))))) + +#+lispworks +(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) slot) + "Removes the slot value from the database." + (let ((slot-def (or (find slot (class-slots class) :key 'slot-definition-name) + (find slot (class-slots class))))) + (if (typep slot-def 'persistent-slot-definition) + (if (indexed class) + (indexed-slot-makunbound class instance slot-def) + (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) + (call-next-method class instance (slot-definition-name slot-def))))) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/18 20:40:50 1.28 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/19 19:41:35 1.29 @@ -205,7 +205,7 @@ (setf indexed-slot-names (union slots indexed-slot-names))))))) ;; Put class instance index into the class root & cache it in the class object (update-indexed-record class indexed-slot-names :class-indexed t) - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) (when (not found) (let ((class-idx (build-indexed-btree sc))) (setf (get-value (class-name class) croot) class-idx) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/08 21:29:53 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/19 19:41:35 1.11 @@ -24,7 +24,7 @@ (defclass persistent () ((%oid :accessor oid :initarg :from-oid) - (dbonnection-spec-pst :type (or list string) :accessor dbcn-spc-pst :initarg :dbconnection-spec-pst)) + (dbconnection-spec-pst :type (or list string) :accessor dbcn-spc-pst :initarg :dbconnection-spec-pst)) (:documentation "Abstract superclass for all persistent classes (common to user-defined classes and collections.)")) @@ -239,12 +239,17 @@ '(:instance :class :database)) (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) - #-lispworks :database - #+lispworks nil) + :database) + +#+lispworks +(defmethod (setf slot-definition-allocation) (allocation (slot-def persistent-slot-definition)) + (unless (eq allocation :database) + (error "Invalid allocation type ~A for slot-definition-allocation" allocation)) + allocation) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) -and chooses persistent or transient slot definitions." + and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient)) (indexed-p (getf initargs :index))) @@ -299,7 +304,7 @@ (declare (ignore slot-name)) (apply #'make-effective-slot-definition class (compute-effective-slot-definition-initargs - class direct-slot-definitions))) + class slot-name direct-slot-definitions))) #+openmcl (defmethod compute-effective-slot-definition-initargs ((class slots-class) @@ -336,7 +341,8 @@ (loop for slot-definition in slot-definitions always (transient slot-definition))) -(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) +(defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) #+lispworks slot-name slot-definitions) + #+lispworks (declare (ignore slot-name)) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) (setf initargs (append initargs '(:transient t))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/11 05:45:14 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/03/19 19:41:35 1.24 @@ -133,12 +133,13 @@ standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition - direct-slot-definition-class - effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction + direct-slot-definition-class + effective-slot-definition-class compute-effective-slot-definition + compute-effective-slot-definition-initargs class-slots slot-value-using-class slot-boundp-using-class @@ -149,9 +150,7 @@ finalize-inheritance ensure-class-using-class compute-slots - initialize-internal-slot-functions - compute-effective-slot-definition-initargs slot-definition-reader-function slot-definition-writer-function slot-definition-boundp-function @@ -276,18 +275,20 @@ #+lispworks (:import-from :clos class-finalized-p + finalize-inheritance compute-class-precedence-list validate-superclass ensure-class-using-class standard-slot-definition standard-direct-slot-definition standard-effective-slot-definition - direct-slot-definition-class - effective-slot-definition-class slot-definition-name slot-definition-initform slot-definition-initfunction + direct-slot-definition-class + effective-slot-definition-class compute-effective-slot-definition + compute-effective-slot-definition-initargs class-slots slot-value-using-class slot-boundp-using-class

1 0

[elephant-cvs] CVS elephant
by ieslick 19 Mar '07

19 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv8886 Modified Files: TODO Log Message: Fixed lispworks MOP support; lispworks is green under Mac OS X --- /project/elephant/cvsroot/elephant/TODO 2007/03/16 14:44:44 1.71 +++ /project/elephant/cvsroot/elephant/TODO 2007/03/19 19:41:35 1.72 @@ -12,7 +12,10 @@ TASKS TO GET TO BETA: Bugs: -- Fix db open bug in SQlite +- Lispworks/Mac: error in finalize indexed class +- Lispworks/Mac: %oid missing in BDB-BTREE on close +- Lispworks/Mac: fix warning in ensure-class-using-class :around (eql nil) method +- Fix build for Win32 (Frank) Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 18 Mar '07

18 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv16838/tests Modified Files: testmigration.lisp Log Message: Fixed migrate-mult-pclass test bug --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/03/16 14:44:46 1.18 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/03/18 20:47:28 1.19 @@ -162,6 +162,11 @@ (defstruct simple-struct s1 s2) (deftest migrate-mult-pclass + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) + (progn + (format t "~%Single store mode: ignoring") + (values t t t t t t)) (progn (let* ((sc1 (open-store *test-spec-primary* :recover t :deadlock-detect t)) (sc2 (open-store *test-spec-secondary* :recover t :deadlock-detect t)) @@ -214,7 +219,7 @@ (eq (slot1 (simple-struct-s1 newstruct)) 5))))))) (close-store sc1) (close-store sc2) - (elephant::clear-migrate-duplicate-detection)))) + (elephant::clear-migrate-duplicate-detection))))) t t t t t t) (defpclass ipfoo ()

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 18 Mar '07

18 Mar '07

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

1 0

[elephant-cvs] CVS elephant
by ieslick 18 Mar '07

18 Mar '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv15998 Modified Files: ele-bdb.asd Log Message: Fixed lispworks serialization issues with floats & strings; fixed remove-derived-index bug that wouldn't properly delete --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/16 14:44:44 1.21 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/03/18 20:40:50 1.22 @@ -32,7 +32,13 @@ (defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c) (call-next-method) - #-(or linux) (list "-ldb-4.5"))) + #-(or linux) (list (format nil "-l~A" (get-db-name c))))) + +(defun get-db-name (c) + (subseq (pathname-name + (make-pathname :defaults (get-config-option :berkeley-db-lib c)) ) + 3)) + (defmethod compiler-options ((compiler (eql :cygwin)) (c bdb-c-source) &key &allow-other-keys) (append (library-directories c)

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 18 Mar '07

18 Mar '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv15998/src/db-bdb Modified Files: libberkeley-db.c Log Message: Fixed lispworks serialization issues with floats & strings; fixed remove-derived-index bug that wouldn't properly delete --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/02/04 04:34:56 1.8 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/03/18 20:40:50 1.9 @@ -1011,6 +1011,7 @@ #define S2_FIXNUM32 1 #define S2_FIXNUM64 2 #define S2_CHAR 3 +#define S2_SHORT_FLOAT 30 #define S2_SINGLE_FLOAT 4 #define S2_DOUBLE_FLOAT 5 #define S2_NEGATIVE_BIGNUM 6 @@ -1034,7 +1035,7 @@ #define S2_FILL_POINTER_P 0x40 #define S2_ADJUSTABLE_P 0x80 -#define type_numeric2(c) (((c)<9) || ((c)==14)) +#define type_numeric2(c) (((c)<9) || ((c)==14) || ((c)==30)) /****** Serialized BTree keys have the form: @@ -1149,6 +1150,8 @@ case S2_FIXNUM64: case S2_SYMBOL_ID: return (double)read_int(buf, 1); + case S2_SHORT_FLOAT: + return (double)read_float(buf, 1); case S2_SINGLE_FLOAT: return (double)read_float(buf, 1); case S2_DOUBLE_FLOAT:

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 16 Mar '07

16 Mar '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv1438/tests Modified Files: testmigration.lisp Log Message: Small changes for lispworks; mainly fixing pointer types --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/03/11 05:59:03 1.17 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/03/16 14:44:46 1.18 @@ -155,7 +155,7 @@ (close-store sc2)))) t) -(defclass simple-class () +(defclass migrate-simple-class () ((slot1 :accessor slot1 :initarg :slot1) (slot2 :accessor slot2 :initarg :slot2))) @@ -179,7 +179,7 @@ (array (make-array '(2 2) :initial-contents `((,i2 1) (,i2 2)))) (hash (make-hash-table)) - (object (make-instance 'simple-class :slot1 i4 :slot2 i4)) + (object (make-instance 'migrate-simple-class :slot1 i4 :slot2 i4)) (struct (make-simple-struct :s1 i5 :s2 i5))) (setf (gethash 1 hash) i3) (setf (gethash 2 hash) i3)

1 0