Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv32223/src
Modified Files: classes.lisp Log Message: merged in andrew's fixes: class slots, inheritence. added slot-boundp, slot-makunbound.
Date: Mon Aug 30 23:14:25 2004 Author: blee
Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.5 elephant/src/classes.lisp:1.6 --- elephant/src/classes.lisp:1.5 Sun Aug 29 22:36:18 2004 +++ elephant/src/classes.lisp Mon Aug 30 23:14:25 2004 @@ -40,7 +40,6 @@ ;;; Suite 330, Boston, MA 02111-1307 USA ;;;
-;; TODO: slot-bound-p (check the database)
(in-package "ELEPHANT")
@@ -67,6 +66,29 @@ (apply #'call-next-method class :direct-superclasses (cons (find-class 'persistent-object) direct-superclasses) args) (call-next-method))))
+(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) + (let* ((class (class-of instance)) + (persistent-slot-names (persistent-slot-names class))) + (flet ((persistent-slot-p (item) + (member item persistent-slot-names :test #'eq))) + (let ((transient-slot-inits + (if (eq slot-names t) + (transient-slot-names class) + (remove-if #'persistent-slot-p slot-names))) + (persistent-slot-inits + (if (eq slot-names t) persistent-slot-names + (remove-if-not #'persistent-slot-p slot-names)))) + (loop for slot-def in (class-slots class) + when (member (slot-definition-name slot-def) + persistent-slot-inits) + unless (slot-boundp-using-class class instance slot-def) + do + (let ((initfun (slot-definition-initfunction slot-def))) + (when initfun + (setf (slot-value-using-class class instance slot-def) + (funcall initfun))))) + (apply #'call-next-method instance transient-slot-inits initargs))))) + (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) (declare (ignore class)) (let ((name (slot-definition-name slot-def))) @@ -77,3 +99,19 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name)))
+(defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-boundp instance name))) + +(defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) + (declare (ignore class)) + (buffer-write-int (oid instance) *key-buf*) + (let* ((key-length (serialize (slot-definition-name slot-def) *key-buf*)) + (buf (db-delete-buffered + (controller-db *store-controller*) + (buffer-stream-buffer *key-buf*) + key-length + :transaction *current-transaction* + :auto-commit *auto-commit*))))) + \ No newline at end of file