[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Apr 29 02:10:55 UTC 2007
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 , at 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))))
More information about the Elephant-cvs
mailing list