From 13d6fbc381746707d8896609384c3c85373e48c1 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Wed, 18 Dec 2002 16:29:07 +0000 Subject: [PATCH] Entomotomy Bug: slot-definition-allocation-not-amop-compliant Committed a slightly adjusted patch from Gerd Moellmann, which makes the GF slot-definition-allocation return :class for class slots, as specified by AMOP, instead of the class object, as it did previously. --- pcl/methods.lisp | 8 +------- pcl/std-class.lisp | 22 +++++++++++----------- pcl/vector.lisp | 4 ++-- 3 files changed, 14 insertions(+), 20 deletions(-) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 19680a93b..3021b1a82 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.19 2002/12/18 00:57:05 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.20 2002/12/18 16:29:06 pmai Exp $") ;;; (in-package :pcl) @@ -67,12 +67,6 @@ ;;; ;;; ;;; -(defmethod shared-initialize :after ((slotd standard-slot-definition) slot-names &key) - (declare (ignore slot-names)) - (with-slots (allocation class) - slotd - (setq allocation (if (eq allocation :class) class allocation)))) - (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key (allocation :instance)) (declare (ignore slot-names)) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 6c8b5994d..8422f661b 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.37 2002/10/29 16:20:45 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.38 2002/12/18 16:29:06 pmai Exp $") ;;; (in-package :pcl) @@ -475,7 +475,7 @@ (setf (plist-value class 'class-slot-cells) (let ((collected ())) (dolist (dslotd direct-slots (nreverse collected)) - (when (eq (slot-definition-allocation dslotd) class) + (when (eq (slot-definition-allocation dslotd) :class) (let ((initfunction (slot-definition-initfunction dslotd))) (push (cons (slot-definition-name dslotd) (if initfunction @@ -703,9 +703,9 @@ (let ((instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) - (let ((alloc (slot-definition-allocation eslotd))) - (cond ((eq alloc :instance) (push eslotd instance-slots)) - ((classp alloc) (push eslotd class-slots))))) + (ecase (slot-definition-allocation eslotd) + (:instance (push eslotd instance-slots)) + (:class (push eslotd class-slots)))) ;; ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. @@ -748,8 +748,8 @@ (defun compute-class-slots (eslotds) (loop for eslotd in eslotds for name = (slot-definition-name eslotd) - and allocation = (slot-definition-allocation eslotd) - collect (assoc name (class-slot-cells allocation)))) + and class = (slot-definition-class eslotd) + collect (assoc name (class-slot-cells class)))) (defun compute-layout (cpl instance-eslotds) (let* ((names (loop for eslotd in instance-eslotds @@ -851,9 +851,9 @@ (instance-slots ()) (class-slots ())) (dolist (eslotd eslotds) - (let ((alloc (slot-definition-allocation eslotd))) - (cond ((eq alloc :instance) (push eslotd instance-slots)) - ((classp alloc) (push eslotd class-slots))))) + (ecase (slot-definition-allocation eslotd) + (:instance (push eslotd instance-slots)) + (:class (push eslotd class-slots)))) (let ((nlayout (compute-layout cpl instance-slots))) (dolist (eslotd instance-slots) (setf (slot-definition-location eslotd) @@ -861,7 +861,7 @@ (dolist (eslotd class-slots) (setf (slot-definition-location eslotd) (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))))) + (class-slot-cells (slot-definition-class eslotd))))) (mapc #'initialize-internal-slot-functions eslotds) eslotds)) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index 9f26256c7..8238fd8c7 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.25 2002/12/18 00:57:05 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.26 2002/12/18 16:29:07 pmai Exp $") ;;; ;;; Permutation vectors. ;;; @@ -639,7 +639,7 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (classp (slot-definition-allocation slotd))))))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) -- GitLab