From adab5ee5e29994bd3824bea40f51d45fd454941c Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Sat, 26 Apr 2003 21:24:06 +0000 Subject: [PATCH] ANSI test CLASS-0211B.1. Initforms of shared slots inherited from superclasses. * src/pcl/std-class.lisp (update-shared-slot-values): New function. (update-class): Call it. (shared-initialize): Slightly rewritten. --- pcl/std-class.lisp | 40 +++++++++++++++++++++++++++++----------- 1 file changed, 29 insertions(+), 11 deletions(-) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 7afd3eea0..e3053a933 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.55 2003/04/26 17:35:08 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.56 2003/04/26 21:24:06 gerd Exp $") (in-package :pcl) @@ -507,16 +507,20 @@ direct-default-initargs) (setq direct-default-initargs (plist-value class 'direct-default-initargs))) - (setf (plist-value class 'class-slot-cells) - (let ((collected ())) - (dolist (dslotd direct-slots (nreverse collected)) - (when (eq (slot-definition-allocation dslotd) :class) - (let ((initfunction (slot-definition-initfunction dslotd))) - (push (cons (slot-definition-name dslotd) - (if initfunction - (funcall initfunction) - +slot-unbound+)) - collected)))))) + ;; + ;; Initialize shared slots. A class may inherit initforms for + ;; shared slots from superclasses. Such initializations are + ;; done in UPDATE-CLASS-SLOT-VALUES. + (ext:collect ((cells)) + (dolist (dslotd direct-slots) + (when (eq (slot-definition-allocation dslotd) :class) + (let ((initfn (slot-definition-initfunction dslotd))) + (cells (cons (slot-definition-name dslotd) + (if initfn + (funcall initfn) + +slot-unbound+)))))) + (setf (plist-value class 'class-slot-cells) (cells))) + ;; (setq predicate-name (if predicate-name-p (setf (slot-value class 'predicate-name) (car predicate-name)) @@ -784,12 +788,26 @@ (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) + (update-shared-slot-values class) (update-ctors 'finalize-inheritance :class class)) ;; (unless finalizep (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) +;;; +;;; Set values of shared slots from initforms inherited from +;;; superclasses, which can't be done before the cpl is known. +;;; +(defun update-shared-slot-values (class) + (dolist (slot (class-slots class)) + (when (eq (slot-definition-allocation slot) :class) + (let ((cell (assq (slot-definition-name slot) (class-slot-cells class)))) + (when cell + (let ((initfn (slot-definition-initfunction slot))) + (when initfn + (setf (cdr cell) (funcall initfn))))))))) + (defun update-cpl (class cpl) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) -- GitLab