X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=651437a8a0dcdbafde7ada79736379d34ac5f9d7;hb=1ffd970d36b42c9d3448d412eb9bd91c55914643;hp=d5d906bdcd3ac39498d82b383d4b596e7bfb18a7;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d5d906b..651437a 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -123,7 +123,7 @@ (defmethod class-prototype :before (class) (unless (class-finalized-p class) - (error "~S not yet finalized, cannot allocate a prototype." class))) + (error "~@<~S is not finalized.~:@>" class))) ;;; KLUDGE: For some reason factoring the common body into a function ;;; breaks PCL bootstrapping, so just generate it with a macrolet for @@ -291,14 +291,13 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names) + readers writers slot-names source-location) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) + :definition-source source-location other))) res))) @@ -382,10 +381,10 @@ *the-class-standard-object*)))) (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." + (error "~@" superclass class (class-of superclass) (class-of class) 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) @@ -693,7 +692,7 @@ (unless (structure-type-p name) (eval defstruct-form)) (mapc (lambda (dslotd reader-name writer-name) (let* ((reader (gdefinition reader-name)) - (writer (when (gboundp writer-name) + (writer (when (fboundp writer-name) (gdefinition writer-name)))) (setf (slot-value dslotd 'internal-reader-function) reader) @@ -818,9 +817,32 @@ (update-initargs class (compute-default-initargs class)) (update-ctors 'finalize-inheritance :class class)) (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil))))) + +(define-condition cpl-protocol-violation (reference-condition error) + ((class :initarg :class :reader cpl-protocol-violation-class) + (cpl :initarg :cpl :reader cpl-protocol-violation-cpl)) + (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol"))) + (:report + (lambda (c s) + (format s "~@" + (class-name (class-of (cpl-protocol-violation-class c))) + (cpl-protocol-violation-class c) + (eq (class-of (cpl-protocol-violation-class c)) + *the-class-funcallable-standard-class*) + (find-class 'function) + (cpl-protocol-violation-cpl c))))) (defun update-cpl (class cpl) + (when (eq (class-of class) *the-class-standard-class*) + (when (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) + (when (eq (class-of class) *the-class-funcallable-standard-class*) + (unless (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) (dolist (c cpl t) @@ -952,7 +974,7 @@ ;;; the slots predictably, but maybe it would be good to compute some ;;; kind of optimal slot layout by looking at locations of slots in ;;; superclasses? -(defmethod compute-slots ((class std-class)) +(defun std-compute-slots (class) ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once ;; for each different slot name we find in our superclasses. Each ;; call receives the class and a list of the dslotds with that name. @@ -972,11 +994,12 @@ (nreverse name-dslotds-alist)))) (defmethod compute-slots ((class standard-class)) - (call-next-method)) + (std-compute-slots class)) +(defmethod compute-slots ((class funcallable-standard-class)) + (std-compute-slots class)) -(defmethod compute-slots :around ((class standard-class)) - (let ((eslotds (call-next-method)) - (location -1)) +(defun std-compute-slots-around (class eslotds) + (let ((location -1)) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) (case (slot-definition-allocation eslotd) @@ -1010,53 +1033,12 @@ (setf (slot-definition-class eslotd) class)) (initialize-internal-slot-functions eslotd)))) -(defmethod compute-slots ((class funcallable-standard-class)) - (call-next-method)) - +(defmethod compute-slots :around ((class standard-class)) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots :around ((class funcallable-standard-class)) - (labels ((instance-slot-names (slotds) - (let (collect) - (dolist (slotd slotds (nreverse collect)) - (when (eq (slot-definition-allocation slotd) :instance) - (push (slot-definition-name slotd) collect))))) - ;; This sorts slots so that slots of classes later in the CPL - ;; come before slots of other classes. This is crucial for - ;; funcallable instances because it ensures that the slots of - ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of - ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn - ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as - ;; a funcallable instance. - (compute-layout (eslotds) - (let ((first ()) - (names (instance-slot-names eslotds))) - (dolist (class - (reverse (class-precedence-list class)) - (nreverse (nconc names first))) - (dolist (ss (class-slots class)) - (let ((name (slot-definition-name ss))) - (when (member name names) - (push name first) - (setq names (delete name names))))))))) - (let ((all-slotds (call-next-method)) - (instance-slots ()) - (class-slots ())) - (dolist (slotd all-slotds) - (case (slot-definition-allocation slotd) - (:instance (push slotd instance-slots)) - (:class (push slotd class-slots)))) - (let ((layout (compute-layout instance-slots))) - (dolist (slotd instance-slots) - (setf (slot-definition-location slotd) - (position (slot-definition-name slotd) layout)) - (initialize-internal-slot-functions slotd))) - (dolist (slotd class-slots) - (let ((name (slot-definition-name slotd)) - (from-class (slot-definition-allocation-class slotd))) - (setf (slot-definition-location slotd) - (assoc name (class-slot-cells from-class))) - (aver (consp (slot-definition-location slotd))) - (initialize-internal-slot-functions slotd))) - all-slotds))) + (let ((eslotds (call-next-method))) + (std-compute-slots-around class eslotds))) (defmethod compute-slots ((class structure-class)) (mapcan (lambda (superclass) @@ -1096,6 +1078,8 @@ (allocation nil) (allocation-class nil) (type t) + (documentation nil) + (documentationp nil) (namep nil) (initp nil) (allocp nil)) @@ -1110,6 +1094,10 @@ (setq initform (slot-definition-initform slotd) initfunction (slot-definition-initfunction slotd) initp t))) + (unless documentationp + (when (%slot-definition-documentation slotd) + (setq documentation (%slot-definition-documentation slotd) + documentationp t))) (unless allocp (setq allocation (slot-definition-allocation slotd) allocation-class (slot-definition-class slotd) @@ -1126,7 +1114,8 @@ :allocation allocation :allocation-class allocation-class :type type - :class class))) + :class class + :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) @@ -1218,14 +1207,13 @@ (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) -(defmethod validate-superclass ((class class) (new-super class)) - (or (eq new-super *the-class-t*) - (eq (class-of class) (class-of new-super)))) - -(defmethod validate-superclass ((class standard-class) (new-super std-class)) - (let ((new-super-meta-class (class-of new-super))) - (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of class) new-super-meta-class)))) +(defmethod validate-superclass ((class class) (superclass class)) + (or (eq superclass *the-class-t*) + (eq (class-of class) (class-of superclass)) + (and (eq (class-of superclass) *the-class-standard-class*) + (eq (class-of class) *the-class-funcallable-standard-class*)) + (and (eq (class-of superclass) *the-class-funcallable-standard-class*) + (eq (class-of class) *the-class-standard-class*)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it @@ -1449,9 +1437,14 @@ (apply #'update-instance-for-different-class copy instance initargs) instance)) -(defmethod change-class ((instance standard-object) - (new-class standard-class) +(defmethod change-class ((instance standard-object) (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (when (member (find-class 'method) cpl) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class 'method) + :references (list '(:amop :initialization "Method"))))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) @@ -1487,15 +1480,24 @@ ;;;; But, there are other parts of the protocol we must follow and those ;;;; definitions appear here. -(defmethod shared-initialize :before - ((class built-in-class) slot-names &rest initargs) - (declare (ignore slot-names initargs)) - (error "attempt to initialize or reinitialize a built in class")) - -(defmethod class-direct-slots ((class built-in-class)) ()) -(defmethod class-slots ((class built-in-class)) ()) -(defmethod class-direct-default-initargs ((class built-in-class)) ()) -(defmethod class-default-initargs ((class built-in-class)) ()) +(macrolet ((def (name args control) + `(defmethod ,name ,args + (declare (ignore initargs)) + (error 'metaobject-initialization-violation + :format-control ,(format nil "~@<~A~@:>" control) + :format-arguments (list ',name) + :references (list '(:amop :initialization "Class")))))) + (def initialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.") + (def reinitialize-instance ((class built-in-class) &rest initargs) + "Cannot ~S an instance of BUILT-IN-CLASS.")) + +(macrolet ((def (name) + `(defmethod ,name ((class built-in-class)) nil))) + (def class-direct-slots) + (def class-slots) + (def class-direct-default-initargs) + (def class-default-initargs)) (defmethod validate-superclass ((c class) (s built-in-class)) (or (eq s *the-class-t*) (eq s *the-class-stream*)