[elephant-cvs] CVS update: elephant/src/classes.lisp

[blee at common-lisp.net]

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