X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=1c22ac9540a0abf519b14453069354dfcd20464a;hb=a260738d7a71680079d972b102b4e4db4e8dc3ae;hp=3a7da7bc392983b83669af81ccb9cb5460b36932;hpb=625946563072d5b9fb7e9bde905f8cbed219a329;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 3a7da7b..1c22ac9 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -320,7 +320,7 @@ :direct-superclasses supers :direct-slots slots :definition-source `((defclass ,name) - ,*load-truename*) + ,*load-pathname*) other))) ;; Defclass of a class with a forward-referenced superclass does not ;; have a wrapper. RES is the incomplete PCL class. The Lisp class @@ -375,6 +375,40 @@ *the-class-standard-class*) (t (class-of class))))) + ;; KLUDGE: It seemed to me initially that there ought to be a way + ;; of collecting all the erroneous problems in one go, rather than + ;; this way of solving the problem of signalling the errors that + ;; we are required to, which stops at the first bogus input. + ;; However, after playing around a little, I couldn't find that + ;; way, so I've left it as is, but if someone does come up with a + ;; better way... -- CSR, 2002-09-08 + (loop for (slot . more) on (getf initargs :direct-slots) + for slot-name = (getf slot :name) + if (some (lambda (s) (eq slot-name (getf s :name))) more) + ;; FIXME: It's quite possible that we ought to define an + ;; SB-INT:PROGRAM-ERROR function to signal these and other + ;; errors throughout the code base that are required to be + ;; of type PROGRAM-ERROR. + do (error 'simple-program-error + :format-control "More than one direct slot with name ~S." + :format-arguments (list slot-name)) + else + do (loop for (option value . more) on slot by #'cddr + when (and (member option + '(:allocation :type + :initform :documentation)) + (not (eq unsupplied + (getf more option unsupplied)))) + do (error 'simple-program-error + :format-control "Duplicate slot option ~S for slot ~S." + :format-arguments (list option slot-name)))) + (loop for (initarg . more) on (getf initargs :direct-default-initargs) + for name = (car initarg) + when (some (lambda (a) (eq (car a) name)) more) + do (error 'simple-program-error + :format-control "Duplicate initialization argument ~ + name ~S in :default-initargs of class ~A." + :format-arguments (list name class))) (loop (unless (remf initargs :metaclass) (return))) (loop (unless (remf initargs :direct-superclasses) (return))) (loop (unless (remf initargs :direct-slots) (return))) @@ -426,7 +460,7 @@ (setf (plist-value class 'class-slot-cells) (let (collect) (dolist (dslotd direct-slots) - (when (eq (slot-definition-allocation dslotd) class) + (when (eq :class (slot-definition-allocation dslotd)) (let ((initfunction (slot-definition-initfunction dslotd))) (push (cons (slot-definition-name dslotd) (if initfunction @@ -465,13 +499,6 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) -(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)) @@ -649,9 +676,24 @@ ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) + ;; Comment from Gerd Moellmann: + ;; + ;; Note that we can't simply delay the finalization when CLASS has + ;; no forward referenced superclasses because that causes bootstrap + ;; problems. + (when (and (not finalizep) + (not (class-finalized-p class)) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (return-from update-class)) (when (or finalizep (class-finalized-p class) (not (class-has-a-forward-referenced-superclass-p class))) (update-cpl class (compute-class-precedence-list class)) + ;; This invocation of UPDATE-SLOTS, in practice, finalizes the + ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE + ;; is called at finalization, so that MOP programmers can hook + ;; into the system as described in "Class Finalization Protocol" + ;; (section 5.5.2 of AMOP). (update-slots class (compute-slots class)) (update-gfs-of-class class) (update-inits class (compute-default-initargs class)) @@ -685,8 +727,9 @@ (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))))) + (case alloc + (: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. @@ -731,7 +774,7 @@ (let (collect) (dolist (eslotd eslotds) (push (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))) + (class-slot-cells (slot-definition-class eslotd))) collect)) (nreverse collect))) @@ -828,8 +871,9 @@ (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))))) + (case alloc + (: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) @@ -837,7 +881,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))