X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=9952a16d9d35c26b523746d4d80311bf913d1a3a;hb=1831934a29eb9361472e4f49efbcd5398392a6b0;hp=783cb88d873db0f1e355d3902a209ca0ae519294;hpb=feea06ce0acba516d739867b23341509e9c36d50;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 783cb88..9952a16 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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))) @@ -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) @@ -975,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. @@ -995,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) @@ -1033,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) @@ -1119,6 +1078,8 @@ (allocation nil) (allocation-class nil) (type t) + (documentation nil) + (documentationp nil) (namep nil) (initp nil) (allocp nil)) @@ -1133,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) @@ -1149,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) @@ -1471,9 +1437,37 @@ (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))) + (dolist (class cpl) + (macrolet + ((frob (class-name) + `(when (eq class (find-class ',class-name)) + (error 'metaobject-initialization-violation + :format-control "~@" + :format-arguments (list 'change-class ',class-name) + :references (list '(:amop :initialization ,class-name)))))) + (frob class) + (frob generic-function) + (frob method) + (frob slot-definition)))) + (change-class-internal instance new-class initargs)) + +(defmethod change-class ((instance forward-referenced-class) + (new-class standard-class) &rest initargs) + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl + (error 'metaobject-initialization-violation + :format-control + "~@" + :format-arguments + (list 'change-class 'forward-referenced-class 'class) + :references + (list '(:amop :generic-function ensure-class-using-class) + '(:amop :initialization class)))) + (when (eq class (find-class 'class)) + (return nil)))) (change-class-internal instance new-class initargs)) (defmethod change-class ((instance funcallable-standard-object) @@ -1509,15 +1503,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*)