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*)))