1.0.18.11: Add SB-EXT:*MUFFLED-WARNINGS*, to muffle warnings at runtime.

[sbcl.git] / src / pcl / slots.lisp

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 7fa3013..b6282b9 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -97,8 +97,8 @@
 
 (declaim (ftype (sfunction (t symbol) t) slot-value))
 (defun slot-value (object slot-name)
-  (let* ((class (check-obsolete-instance/class-of object))
-         (cell (find-slot-cell class slot-name))
+  (let* ((wrapper (valid-wrapper-of object))
+         (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
           (cond ((fixnump location)
@@ -107,16 +107,17 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-value
-                   (slot-value-using-class class object (cddr cell))))
                 ((not cell)
                  (return-from slot-value
-                   (values (slot-missing class object slot-name 'slot-value))))
+                   (values (slot-missing (wrapper-class* wrapper) object slot-name
+                                         'slot-value))))
+                ((not location)
+                 (return-from slot-value
+                   (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
                 (t
                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
     (if (eq +slot-unbound+ value)
-        (slot-unbound class object slot-name)
+        (slot-unbound (wrapper-class* wrapper) object slot-name)
         value)))
 
 (define-compiler-macro slot-value (&whole form object slot-name
@@ -127,8 +128,8 @@
       form))
 
 (defun set-slot-value (object slot-name new-value)
-  (let* ((class (check-obsolete-instance/class-of object))
-         (cell (find-slot-cell class slot-name))
+  (let* ((wrapper (valid-wrapper-of object))
+         (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (type-check-function (cadr cell)))
     (when type-check-function
@@ -140,10 +141,11 @@
                      new-value)))
           ((consp location)
            (setf (cdr location) new-value))
-          ((eq t location)
-           (setf (slot-value-using-class class object (cddr cell)) new-value))
           ((not cell)
-           (slot-missing class object slot-name 'setf new-value))
+           (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value))
+          ((not location)
+           (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
+                 new-value))
           (t
            (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
   new-value)
@@ -169,8 +171,8 @@
       form))
 
 (defun slot-boundp (object slot-name)
-  (let* ((class (check-obsolete-instance/class-of object))
-         (cell (find-slot-cell class slot-name))
+  (let* ((wrapper (valid-wrapper-of object))
+         (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
           (cond ((fixnump location)
@@ -179,12 +181,14 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-boundp
-                   (slot-boundp-using-class class object (cddr cell))))
                 ((not cell)
                  (return-from slot-boundp
-                   (and (slot-missing class object slot-name 'slot-boundp) t)))
+                   (and (slot-missing (wrapper-class* wrapper) object slot-name
+                                      'slot-boundp)
+                        t)))
+                ((not location)
+                 (return-from slot-boundp
+                   (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
                 (t
                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
     (not (eq +slot-unbound+ value))))
@@ -197,8 +201,8 @@
       form))
 
 (defun slot-makunbound (object slot-name)
-  (let* ((class (check-obsolete-instance/class-of object))
-         (cell (find-slot-cell class slot-name))
+  (let* ((wrapper (valid-wrapper-of object))
+         (cell (find-slot-cell wrapper slot-name))
          (location (car cell)))
     (cond ((fixnump location)
            (if (std-instance-p object)
@@ -207,10 +211,10 @@
                      +slot-unbound+)))
           ((consp location)
            (setf (cdr location) +slot-unbound+))
-          ((eq t location)
-           (slot-makunbound-using-class class object (cddr cell)))
           ((not cell)
-           (slot-missing class object slot-name 'slot-makunbound))
+           (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
+          ((not location)
+           (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
           (t
            (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
   object)
@@ -372,6 +376,8 @@
   (let* ((function (slot-definition-internal-reader-function slotd))
          (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+)
         (values (slot-unbound class object (slot-definition-name slotd)))
         value)))
@@ -459,3 +465,10 @@
   (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)))))