X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=2ae32b07a8f958ee362ec6d73841df1d65e4d96b;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=b1fcbb39da124acaacca7629dd48d2e171eb0bac;hpb=479ef26343b45753fc019b6535d3aa0ee54cb324;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index b1fcbb3..2ae32b0 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -28,9 +28,19 @@ (define-condition unbound-slot (cell-error) ((instance :reader unbound-slot-instance :initarg :instance)) (:report (lambda (condition stream) - (format stream "The slot ~S is unbound in the object ~S." - (cell-error-name condition) - (unbound-slot-instance condition))))) + (handler-case + (format stream "~@" + (cell-error-name condition) + (unbound-slot-instance condition)) + (serious-condition () + ;; In case of an error try again avoiding custom PRINT-OBJECT's. + (format stream "~&Error during printing.~%~@" + (cell-error-name condition) + (type-of (unbound-slot-instance condition)))))))) (defmethod wrapper-fetcher ((class standard-class)) 'std-instance-wrapper) @@ -41,239 +51,342 @@ (defmethod raw-instance-allocator ((class standard-class)) 'allocate-standard-instance) -;;; These four functions work on std-instances and fsc-instances. These are +;;; These three functions work on std-instances and fsc-instances. These are ;;; instances for which it is possible to change the wrapper and the slots. ;;; ;;; For these kinds of instances, most specified methods from the instance ;;; structure protocol are promoted to the implementation-specific class ;;; std-class. Many of these methods call these four functions. -(defun set-wrapper (inst new) - (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) new)) - (t - (error "unrecognized instance type")))) - -(defun swap-wrappers-and-slots (i1 i2) - (with-pcl-lock ;FIXME is this sufficient? - (cond ((std-instance-p i1) - (let ((w1 (std-instance-wrapper i1)) - (s1 (std-instance-slots i1))) - (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) - (setf (std-instance-slots i1) (std-instance-slots i2)) - (setf (std-instance-wrapper i2) w1) - (setf (std-instance-slots i2) s1))) - ((fsc-instance-p i1) - (let ((w1 (fsc-instance-wrapper i1)) - (s1 (fsc-instance-slots i1))) - (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) - (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) - (setf (fsc-instance-wrapper i2) w1) - (setf (fsc-instance-slots i2) s1))) - (t - (error "unrecognized instance type"))))) +(defun %swap-wrappers-and-slots (i1 i2) + (cond ((std-instance-p i1) + (let ((w1 (std-instance-wrapper i1)) + (s1 (std-instance-slots i1))) + (setf (std-instance-wrapper i1) (std-instance-wrapper i2)) + (setf (std-instance-slots i1) (std-instance-slots i2)) + (setf (std-instance-wrapper i2) w1) + (setf (std-instance-slots i2) s1))) + ((fsc-instance-p i1) + (let ((w1 (fsc-instance-wrapper i1)) + (s1 (fsc-instance-slots i1))) + (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2)) + (setf (fsc-instance-slots i1) (fsc-instance-slots i2)) + (setf (fsc-instance-wrapper i2) w1) + (setf (fsc-instance-slots i2) s1))) + (t + (error "unrecognized instance type")))) -(defun get-class-slot-value-1 (object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) - (if (eq (cdr entry) +slot-unbound+) - (slot-unbound (wrapper-class wrapper) object slot-name) - (cdr entry))))) - -(defun set-class-slot-value-1 (new-value object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) - object - slot-name - 'setf - new-value) - (setf (cdr entry) new-value)))) - -(defmethod class-slot-value ((class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (get-class-slot-value-1 prototype wrapper slot-name))) - -(defmethod (setf class-slot-value) (nv (class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (set-class-slot-value-1 nv prototype wrapper slot-name))) +;;;; STANDARD-INSTANCE-ACCESS + +(declaim (inline standard-instance-access + (setf standard-instance-access) + (cas stadard-instance-access) + funcallable-standard-instance-access + (setf funcallable-standard-instance-access) + (cas funcallable-standard-instance-access))) + +(defun standard-instance-access (instance location) + (clos-slots-ref (std-instance-slots instance) location)) + +(defun (setf standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (std-instance-slots instance) location) new-value)) + +(defun (cas standard-instance-access) (old-value new-value instance location) + ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? + (cas (svref (std-instance-slots instance) location) old-value new-value)) + +(defun funcallable-standard-instance-access (instance location) + (clos-slots-ref (fsc-instance-slots instance) location)) + +(defun (setf funcallable-standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value)) + +(defun (cas funcallable-standard-instance-access) (old-value new-value instance location) + ;; FIXME: Maybe get rid of CLOS-SLOTS-REF entirely? + (cas (svref (fsc-instance-slots instance) location) old-value new-value)) -(defun find-slot-definition (class slot-name) - (dolist (slot (class-slots class) nil) - (when (eql slot-name (slot-definition-name slot)) - (return slot)))) +;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND +(declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-value) - (slot-value-using-class class object slot-definition)))) - -(define-compiler-macro slot-value (&whole form object slot-name) - (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-value))))) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (funcallable-standard-instance-access object location))) + ((consp location) + (cdr location)) + ((not location) + (return-from slot-value + (funcall (slot-info-reader (cdr cell)) object))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (if (eq +slot-unbound+ value) + (slot-unbound (wrapper-class* wrapper) object slot-name) + value))) + +;;; This is used during the PCL build, but gets replaced by a deftransform +;;; in fixup.lisp. +(define-compiler-macro slot-value (&whole form object slot-name + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env))) `(accessor-slot-value ,object ,slot-name) form)) (defun set-slot-value (object slot-name new-value) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'setf new-value) - (setf (slot-value-using-class class object slot-definition) - new-value)))) - -(define-compiler-macro set-slot-value (&whole form object slot-name new-value) - (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from set-slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'setf new-value))))) + (location (car cell)) + (info (cdr cell)) + (typecheck (slot-info-typecheck info))) + (when typecheck + (funcall typecheck new-value)) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) new-value) + (setf (funcallable-standard-instance-access object location) + new-value))) + ((consp location) + (setf (cdr location) new-value)) + ((not location) + (funcall (slot-info-writer info) new-value object)) + (t + (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) + new-value) + +;;; A version of SET-SLOT-VALUE for use in safe code, where we want to +;;; check types when writing to slots: +;;; * Doesn't have an optimizing compiler-macro +;;; * Isn't special-cased in WALK-METHOD-LAMBDA +(defun safe-set-slot-value (object slot-name new-value) + (set-slot-value object slot-name new-value)) + +;;; This is used during the PCL build, but gets replaced by a deftransform +;;; in fixup.lisp. +(define-compiler-macro set-slot-value (&whole form object slot-name new-value + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env)) + ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe + ;; code, since it'll use the global automatically generated + ;; accessor, which won't do typechecking. (SLOT-OBJECT + ;; won't have been compiled with SAFETY 3, so SAFE-P will + ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION). + (not (safe-code-p env))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) -(defun slot-boundp (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-boundp) - (slot-boundp-using-class class object slot-definition)))) - -(setf (gdefinition 'slot-boundp-normal) #'slot-boundp) +(defun (cas slot-value) (old-value new-value object slot-name) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'cas (list old-value new-value)))))) + (location (car cell)) + (info (cdr cell)) + (typecheck (slot-info-typecheck info))) + (when typecheck + (funcall typecheck new-value)) + (let ((old (cond ((fixnump location) + (if (std-instance-p object) + (cas (standard-instance-access object location) old-value new-value) + (cas (funcallable-standard-instance-access object location) + old-value new-value))) + ((consp location) + (cas (cdr location) old-value new-value)) + ((not location) + ;; FIXME: (CAS SLOT-VALUE-USING-CLASS)... + (error "Cannot compare-and-swap slot ~S on: ~S" slot-name object)) + (t + (bug "Bogus slot-cell in (CAS SLOT-VALUE): ~S" cell))))) + (if (and (eq +slot-unbound+ old) + (neq old old-value)) + (slot-unbound (wrapper-class* wrapper) object slot-name) + old)))) -(define-compiler-macro slot-boundp (&whole form object slot-name) - (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) +(defun slot-boundp (object slot-name) + (let* ((wrapper (valid-wrapper-of object)) + (cell (or (find-slot-cell wrapper slot-name) + (return-from slot-boundp + (and (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-boundp) + t)))) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (funcallable-standard-instance-access object location))) + ((consp location) + (cdr location)) + ((not location) + (return-from slot-boundp + (funcall (slot-info-boundp (cdr cell)) object))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (not (eq +slot-unbound+ value)))) + +(define-compiler-macro slot-boundp (&whole form object slot-name + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env))) `(accessor-slot-boundp ,object ,slot-name) form)) (defun slot-makunbound (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell))) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) +slot-unbound+) + (setf (funcallable-standard-instance-access object location) + +slot-unbound+))) + ((consp location) + (setf (cdr location) +slot-unbound+)) + ((not cell) + (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound)) + ((not location) + (let ((class (wrapper-class* wrapper))) + (slot-makunbound-using-class class object (find-slot-definition class slot-name)))) + (t + (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) + object) (defun slot-exists-p (object slot-name) (let ((class (class-of object))) (not (null (find-slot-definition class slot-name))))) +(defvar *unbound-slot-value-marker* (make-unprintable-object "unbound slot")) + ;;; This isn't documented, but is used within PCL in a number of print ;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.) -(defun slot-value-or-default (object slot-name &optional (default "unbound")) +(defun slot-value-or-default (object slot-name &optional + (default *unbound-slot-value-marker*)) (if (slot-boundp object slot-name) (slot-value object slot-name) default)) - -(defun standard-instance-access (instance location) - (clos-slots-ref (std-instance-slots instance) location)) - -(defun funcallable-standard-instance-access (instance location) - (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (object standard-object) + (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (error "unrecognized instance type")))) - (cons - (cdr location)) - (t - (error "~@" - slotd 'slot-value-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-value-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-value-using-class))))) (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) - (new-value (class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + (new-value (class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) - (let ((location (slot-definition-location slotd))) + (let* ((info (slot-definition-info slotd)) + (location (slot-definition-location slotd)) + (typecheck (slot-info-typecheck info)) + (new-value (if typecheck + (funcall (the function typecheck) new-value) + new-value))) (typecase location (fixnum (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (error "unrecognized instance type")))) + (setf (clos-slots-ref (std-instance-slots object) location) + new-value)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + new-value)) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) (cons (setf (cdr location) new-value)) (t - (error "~@" - slotd '(setf slot-value-using-class)))))) + (instance-structure-protocol-error + slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) - (value (typecase location - (fixnum - (cond ((std-instance-p object) - (clos-slots-ref (std-instance-slots object) - location)) - ((fsc-instance-p object) - (clos-slots-ref (fsc-instance-slots object) - location)) - (t (error "unrecognized instance type")))) - (cons - (cdr location)) - (t - (error "~@" - slotd 'slot-boundp-using-class))))) + (value + (typecase location + (fixnum + (cond ((std-instance-p object) + (clos-slots-ref (std-instance-slots object) + location)) + ((fsc-instance-p object) + (clos-slots-ref (fsc-instance-slots object) + location)) + (t (bug "unrecognized instance type in ~S" + 'slot-boundp-using-class)))) + (cons + (cdr location)) + (t + (instance-structure-protocol-error slotd + 'slot-boundp-using-class))))) (not (eq value +slot-unbound+)))) (defmethod slot-makunbound-using-class - ((class std-class) - (object std-object) - (slotd standard-effective-slot-definition)) + ((class std-class) + (object standard-object) + (slotd standard-effective-slot-definition)) (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - +slot-unbound+)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - +slot-unbound+)) - (t (error "unrecognized instance type")))) + (setf (clos-slots-ref (std-instance-slots object) location) + +slot-unbound+)) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + +slot-unbound+)) + (t (bug "unrecognized instance type in ~S" + 'slot-makunbound-using-class)))) (cons (setf (cdr location) +slot-unbound+)) (t - (error "~@" - slotd 'slot-makunbound-using-class)))) + (instance-structure-protocol-error slotd + 'slot-makunbound-using-class)))) object) (defmethod slot-value-using-class ((class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-reader-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-reader (slot-definition-info slotd)))) (funcall fun object))) (defmethod (setf slot-value-using-class) @@ -281,91 +394,126 @@ (class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-writer-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-writer (slot-definition-info slotd)))) (funcall fun new-value object))) (defmethod slot-boundp-using-class ((class condition-class) (object condition) (slotd condition-effective-slot-definition)) - (let ((fun (slot-definition-boundp-function slotd))) - (declare (type function fun)) + (let ((fun (slot-info-boundp (slot-definition-info slotd)))) (funcall fun object))) (defmethod slot-makunbound-using-class ((class condition-class) object slot) (error "attempt to unbind slot ~S in condition object ~S." - slot object)) + slot object)) (defmethod slot-value-using-class ((class structure-class) (object structure-object) (slotd structure-effective-slot-definition)) (let* ((function (slot-definition-internal-reader-function slotd)) - (value (funcall function object))) + (value (funcall function object))) (declare (type function function)) + ;; FIXME: Is this really necessary? Structure slots should surely + ;; never be unbound! (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) - value))) + (values (slot-unbound class object (slot-definition-name slotd))) + value))) (defmethod (setf slot-value-using-class) (new-value (class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + (object structure-object) + (slotd structure-effective-slot-definition)) (let ((function (slot-definition-internal-writer-function slotd))) (declare (type function function)) (funcall function new-value object))) (defmethod slot-boundp-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) t) (defmethod slot-makunbound-using-class - ((class structure-class) - (object structure-object) - (slotd structure-effective-slot-definition)) + ((class structure-class) + (object structure-object) + (slotd structure-effective-slot-definition)) (error "Structure slots can't be unbound.")) (defmethod slot-missing - ((class t) instance slot-name operation &optional new-value) + ((class t) instance slot-name operation &optional new-value) (error "~@" - (ecase operation - (slot-value "read the slot's value (slot-value)") - (setf (format nil - "set the slot's value to ~S (SETF of SLOT-VALUE)" - new-value)) - (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") - (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) - slot-name - instance)) + (ecase operation + (slot-value "read the slot's value (slot-value)") + (setf (format nil + "set the slot's value to ~S (SETF of SLOT-VALUE)" + new-value)) + (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") + (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) + slot-name + instance)) (defmethod slot-unbound ((class t) instance slot-name) - (error 'unbound-slot :name slot-name :instance instance)) + (restart-case + (error 'unbound-slot :name slot-name :instance instance) + (use-value (v) + :report "Return a value as the slot-value." + :interactive read-evaluated-form + v) + (store-value (v) + :report "Store and return a value as the slot-value." + :interactive read-evaluated-form + (setf (slot-value instance slot-name) v)))) (defun slot-unbound-internal (instance position) - (slot-unbound (class-of instance) instance - (etypecase position - (fixnum - (nth position - (wrapper-instance-slots-layout (wrapper-of instance)))) - (cons - (car position))))) + (values + (slot-unbound + (class-of instance) + instance + (etypecase position + (fixnum + ;; In the vast majority of cases location corresponds to the position + ;; in list. The only exceptions are when there are non-local slots + ;; before the one we want. + (let* ((slots (wrapper-slots (wrapper-of instance))) + (guess (nth position slots))) + (if (eql position (slot-definition-location guess)) + (slot-definition-name guess) + (slot-definition-name + (car (member position (class-slots instance) :key #'slot-definition-location)))))) + (cons + (car position)))))) +;;; FIXME: AMOP says that allocate-instance imples finalize-inheritance +;;; if the class is not yet finalized, but we don't seem to be taking +;;; care of this for non-standard-classes. (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) - (unless (class-finalized-p class) (finalize-inheritance class)) + (unless (class-finalized-p class) + (finalize-inheritance class)) (allocate-standard-instance (class-wrapper class))) (defmethod allocate-instance ((class structure-class) &rest initargs) (declare (ignore initargs)) (let ((constructor (class-defstruct-constructor class))) (if constructor - (funcall constructor) - (error "can't allocate an instance of class ~S" (class-name class))))) + (funcall constructor) + (error "Don't know how to allocate ~S" class)))) (defmethod allocate-instance ((class condition-class) &rest initargs) (declare (ignore initargs)) - (make-condition (class-name class))) + (allocate-condition (class-name class))) + +(defmethod allocate-instance ((class built-in-class) &rest initargs) + (declare (ignore initargs)) + (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP + +;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. +(defmethod class-slots :before ((class slot-class)) + (unless (class-finalized-p class) + (error 'simple-reference-error + :format-control "~S called on ~S, which is not yet finalized." + :format-arguments (list 'class-slots class) + :references (list '(:amop :generic-function class-slots)))))