[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-serv16566/src

Modified Files:
	classes.lisp 
Log Message:
openmcl, fixed shared-initialize, slot-mkunbound

Date: Thu Sep  2 09:09:57 2004
Author: blee

Index: elephant/src/classes.lisp
diff -u elephant/src/classes.lisp:1.6 elephant/src/classes.lisp:1.7
--- elephant/src/classes.lisp:1.6	Mon Aug 30 23:14:25 2004
+++ elephant/src/classes.lisp	Thu Sep  2 09:09:57 2004
@@ -67,26 +67,37 @@
 	(call-next-method))))
 
 (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys)
+  "This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used."
   (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)
+	     (if (eq slot-names t) ; t means all slots
 		 (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)))))
+	;; initialize the persistent slots
+	(flet ((initialize-from-initarg (slot-def)
+		 (loop for initarg in initargs
+		       with slot-initargs = (slot-definition-initargs slot-def)
+		       when (member initarg slot-initargs :test #'eq)
+		       do 
+		       (setf (slot-value-using-class class instance slot-def) 
+			     (getf initargs initarg))
+		       (return t))))
+	  (loop for slot-def in (class-slots class)
+		unless (initialize-from-initarg slot-def)
+		when (member (slot-definition-name slot-def) persistent-slot-names :test #'eq)
+		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))))))
+	;; let the implementation initialize the transient slots
 	(apply #'call-next-method instance transient-slot-inits initargs)))))
 
 (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition))
@@ -107,11 +118,11 @@
 (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*)))))
+  (let ((key-length (serialize (slot-definition-name slot-def) *key-buf*)))
+    (db-delete-buffered
+     (controller-db *store-controller*) 
+     (buffer-stream-buffer *key-buf*)
+     key-length
+     :transaction *current-transaction*
+     :auto-commit *auto-commit*)))