Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv17716/src/elephant
Modified Files: classes.lisp classindex.lisp collections.lisp metaclasses.lisp serializer2.lisp Log Message: Fixes submitted by Henrik; some OpenMCL changes
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/19 19:41:35 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/03/21 14:29:30 1.23 @@ -240,18 +240,19 @@
(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))) + (when instance + (let ((name (slot-definition-name slot-def))) + (persistent-slot-boundp (get-con instance) instance name))))
(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) - until matches-p - finally (return (if (and matches-p - (subtypep (type-of slot) 'persistent-slot-definition)) - (persistent-slot-boundp (get-con instance) instance slot-name) - (call-next-method))))) + for matches-p = (eq (slot-definition-name slot) slot-name) + until matches-p + finally (return (if (and matches-p + (subtypep (type-of slot) 'persistent-slot-definition)) + (persistent-slot-boundp (get-con instance) instance slot-name) + (call-next-method)))))
(defmethod slot-makunbound-using-class ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Removes the slot value from the database." --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/19 19:41:35 1.29 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/03/21 14:29:30 1.30 @@ -430,7 +430,7 @@
(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (declare (type (or fixnum null) start end) - (type string idx-name)) + (type symbol idx-name)) (let ((instances nil)) (declare (type list instances)) (flet ((collector (k v pk) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/18 20:40:50 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/03/21 14:29:30 1.15 @@ -348,17 +348,20 @@ (string (string<= a b)) (persistent (<= (oid a) (oid b)))))
-(defmethod map-index (fn (index btree-index) &rest args &key start end) +(defmethod map-index (fn (index btree-index) &rest args &key (start nil start-supplied-p) (end nil end-supplied-p)) "Like map-btree, but takes a function of three arguments key, value and primary key if you want to get at the primary key value, otherwise use map-btree" - (declare (dynamic-extent args)) + (declare (dynamic-extent args) + (ignorable args)) (let ((sc (get-con index))) (ensure-transaction (:store-controller sc) (with-btree-cursor (cur index) (labels ((next-range () (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) - (if (or (and exists? (not end)) - (and exists? (lisp-compare<= skey end))) + (if (and exists? + (or (not end-supplied-p) + (null end) + (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) @@ -373,12 +376,14 @@ (cursor-pset-range cur key) (next-range)))))) (declare (dynamic-extent next-range next-in-range)) - (multiple-value-bind (exists? skey val pkey) - (if start + (multiple-value-bind (exists? skey val pkey) + (if (and start-supplied-p (not (null start))) (cursor-pset-range cur start) (cursor-pfirst cur)) - (if (or (and exists? (not end)) - (and exists? (lisp-compare<= skey end))) + (if (and exists? + (or (not end-supplied-p) + (null end) + (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/19 19:41:35 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/03/21 14:29:30 1.12 @@ -304,7 +304,7 @@ (declare (ignore slot-name)) (apply #'make-effective-slot-definition class (compute-effective-slot-definition-initargs - class slot-name direct-slot-definitions))) + class direct-slot-definitions)))
#+openmcl (defmethod compute-effective-slot-definition-initargs ((class slots-class) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/19 20:51:28 1.32 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/03/21 14:29:31 1.33 @@ -168,7 +168,7 @@ (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) (progn - (assert (< #.most-positive-fixnum +2^63+)) + (assert (eq (< #.most-positive-fixnum +2^63+) t)) (if (< (abs frob) +2^31+) (progn (buffer-write-byte +fixnum32+ bs) @@ -343,7 +343,7 @@
(defparameter *tag-table* `((,+fixnum32+ . "fixnum32") - (,+fixnum64+ . "fixnum32") + (,+fixnum64+ . "fixnum64") (,+char+ . "char") (,+short-float+ . "short-float") (,+single-float+ . "single-float")