Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv17181/src
Modified Files: metaclasses.lisp Log Message: openmcl
Date: Thu Sep 2 09:15:49 2004 Author: blee
Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.3 elephant/src/metaclasses.lisp:1.4 --- elephant/src/metaclasses.lisp:1.3 Mon Aug 30 23:15:12 2004 +++ elephant/src/metaclasses.lisp Thu Sep 2 09:15:48 2004 @@ -83,6 +83,7 @@ (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient))) + (when (consp transient-p) (setq transient-p (car transient-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) @@ -111,6 +112,7 @@
(defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) (let ((transient-p (getf initargs :transient))) + (when (consp transient-p) (setq transient-p (car transient-p))) (cond (transient-p (find-class 'transient-effective-slot-definition)) (t @@ -138,6 +140,43 @@ (let ((slot-definition (call-next-method))) (ensure-storage-exists class slot-definition slot-name) slot-definition)) + +#+openmcl +(defmethod compute-effective-slot-definition ((class persistent-metaclass) slot-name direct-slot-definitions) + (declare (ignore slot-name)) + (apply #'make-effective-slot-definition class + (compute-effective-slot-definition-initargs + class direct-slot-definitions))) + +#+openmcl +(defmethod compute-effective-slot-definition-initargs ((class slots-class) + direct-slots) + (let* ((name (loop for s in direct-slots + when s + do (return (slot-definition-name s)))) + (initer (dolist (s direct-slots) + (when (%slot-definition-initfunction s) + (return s)))) + (documentor (dolist (s direct-slots) + (when (%slot-definition-documentation s) + (return s)))) + (first (car direct-slots)) + (initargs (let* ((initargs nil)) + (dolist (dslot direct-slots initargs) + (dolist (dslot-arg (%slot-definition-initargs dslot)) + (pushnew dslot-arg initargs :test #'eq)))))) + (list + :name name + :allocation (%slot-definition-allocation first) + :documentation (when documentor (nth-value + 1 + (%slot-definition-documentation + documentor))) + :class (%slot-definition-class first) + :initargs initargs + :initfunction (if initer (%slot-definition-initfunction initer)) + :initform (if initer (%slot-definition-initform initer)) + :type (or (%slot-definition-type first) t))))
(defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs))