(lambda (dependent)
(apply #'update-dependent class dependent initargs))))
+(defmethod reinitialize-instance :after ((class condition-class) &key)
+ (let* ((name (class-name class))
+ (classoid (find-classoid name))
+ (slots (condition-classoid-slots classoid)))
+ ;; to balance the REMOVE-SLOT-ACCESSORS call in
+ ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS).
+ (dolist (slot slots)
+ (let ((slot-name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ ;; FIXME: see comment in SHARED-INITIALIZE :AFTER
+ ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18
+ (sb-kernel::install-condition-slot-reader reader name slot-name))
+ (dolist (writer (condition-slot-writers slot))
+ (sb-kernel::install-condition-slot-writer writer name slot-name))))))
+
(defmethod shared-initialize :after ((class condition-class) slot-names
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
;; override condition accessors with generic functions. We do this
;; differently.
+ ;;
+ ;; ??? What does the above comment mean and why is it a good idea?
+ ;; CMUCL (which still as of 2005-11-18 uses this code and has this
+ ;; comment) loses slot information in its condition classes:
+ ;; DIRECT-SLOTS is always NIL. We have the right information, so we
+ ;; remove slot accessors but never put them back. I've added a
+ ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
+ ;; was meant to happen? -- CSR, 2005-11-18
(update-pv-table-cache-info class))
(defmethod direct-slot-definition-class ((class condition-class)
(allocation nil)
(allocation-class nil)
(type t)
+ (documentation nil)
+ (documentationp nil)
(namep nil)
(initp nil)
(allocp nil))
(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)
: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)
(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 "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+ :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
+ "~@<Cannot ~S ~S objects into non-~S objects.~@:>"
+ :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)
(new-class funcallable-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 "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+ :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 standard-object)
;;;; 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*)
projects / sbcl.git / blobdiff