Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv12328/src/elephant
Modified Files: classes.lisp classindex.lisp collections.lisp unicode2.lisp Log Message: Fixes for lispworks in tests & deadlock detect; fixes for openmcl in pointer manipulation
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/04/27 13:32:16 1.33 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/04/29 02:10:54 1.34 @@ -273,18 +273,21 @@ "Ensures that object can be written as a reference into store sc" (eq (dbcn-spc-pst object) (controller-spec sc)))
-(define-condition cross-reference-error () +(define-condition cross-reference-error (error) ((object :accessor cross-reference-error-object :initarg :object) (home-controller :accessor cross-reference-error-home-controller :initarg :home-ctrl) (foreign-controller :accessor cross-reference-error-foreign-controller :initarg :foreign-ctrl)) (:documentation "An error condition raised when an object is being written into a data store other - than its home store")) + than its home store") + (:report (lambda (condition stream) + (format stream "Attempted to write object ~A with home store ~A into store ~A" + (cross-reference-error-object condition) + (cross-reference-error-home-controller condition) + (cross-reference-error-foreign-controller condition)))))
(defun signal-cross-reference-error (object sc) (cerror "Proceed to write incorrect reference" 'cross-reference-error - :format-control "Attempted to write object ~A with home store ~A into store ~A" - :format-arguments (list object (get-con object) sc) :object object :home-ctrl (get-con object) :foreign-ctrl sc)) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/28 03:07:38 1.41 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/29 02:10:54 1.42 @@ -84,18 +84,17 @@ (let ((class (find-class class-name nil))) (when class (indexed class))))
-(define-condition persistent-class-not-indexed (error) - ((class-obj :initarg :class :initarg nil :reader unindexed-class-obj))) - +(define-condition persistent-class-not-indexed () + ((class-obj :initarg :class :initarg nil :reader unindexed-class-obj)) + (:report (lambda (condition stream) + (format stream "Class ~A is not enabled for indexing" + (class-name (unindexed-class-obj condition)))))) + (defun signal-class-not-indexed (class) (cerror "Ignore and continue?" 'persistent-class-not-indexed - :format-control "Class ~A is not enabled for indexing" - :format-arguments (list (class-name class)) :class class))
-;; (define-condition - (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/collections.lisp 2007/04/28 17:18:33 1.29 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/04/29 02:10:54 1.30 @@ -74,13 +74,6 @@ (:documentation "Delete all key-value pairs from the btree and render it an invalid object in the data store"))
-(defmethod drop-btree ((bt btree)) - (ensure-transaction (:store-controller *store-controller*) - (with-btree-cursor (cur bt) - (loop for (exists? key) = (multiple-value-list (cursor-first cur)) - then (multiple-value-list (cursor-next cur)) - while exists? - do (remove-kv key bt)))))
;; ;; Btrees that support secondary indices @@ -380,7 +373,6 @@ different key.) Returns has-tuple / secondary key / value / primary key."))
- (defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." @@ -389,6 +381,14 @@ (progn ,@body) (cursor-close ,var))))
+(defmethod drop-btree ((bt btree)) + (ensure-transaction (:store-controller *store-controller*) + (with-btree-cursor (cur bt) + (loop for (exists? key) = (multiple-value-list (cursor-first cur)) + then (multiple-value-list (cursor-next cur)) + while exists? + do (remove-kv key bt))))) + ;; ======================================= ;; Generic Mapping Functions ;; ======================================= --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/04/12 02:47:33 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/04/29 02:10:55 1.9 @@ -83,13 +83,13 @@ (let ((code (char-code (schar string i)))) (declare (type fixnum code)) (when (> code #xFF) (fail)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code)))) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ i size)) code)))) (string (loop for i fixnum from 0 below characters do (let ((code (char-code (char string i)))) (declare (type fixnum code)) (when (> code #xFF) (fail)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code))))) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ i size)) code))))) (setf (buffer-stream-size bstream) needed) (succeed))))))
@@ -120,20 +120,20 @@ (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (when (> code #xFFFF) (fail)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 2) size)) ;; (coerce (ldb (byte 8 8) code) '(signed 8))) (ldb (byte 8 8) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size 1)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 2) size 1)) ;; (coerce (ldb (byte 8 0) code) '(signed 8)))))) (ldb (byte 8 0) code))))) (string (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (when (> code #xFFFF) (fail)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 2) size)) ;; (coerce (ldb (byte 8 8) code) '(signed 8))) (ldb (byte 8 8) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size 1)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 2) size 1)) ;; (coerce (ldb (byte 8 0) code) '(signed 8))))))) (ldb (byte 8 0) code)))))) (incf size (* characters 2)) @@ -158,25 +158,25 @@ (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (when (> code #x10FFFF) (error "Invalid unicode code type")) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 0)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 0)) (ldb (byte 8 24) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 1)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 1)) (ldb (byte 8 16) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 2)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 2)) (ldb (byte 8 8) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 3)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 3)) (ldb (byte 8 0) code))))) (string (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (when (> code #x10FFFF) (error "Invalid unicode code type")) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 0)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 0)) (ldb (byte 8 24) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 1)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 1)) (ldb (byte 8 16) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 2)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 2)) (ldb (byte 8 8) code)) - (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 4) size 3)) + (setf (uffi:deref-array buffer '(:array :unsigned-char) (+ (* i 4) size 3)) (ldb (byte 8 0) code)))))) (incf size (* characters 4)) t))))