X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=2768a42bcb1c4f23655adf222522e1f98417e851;hb=7ce5108fd5ec5b599d4ae9e8aedc1a0d458af102;hp=2784334a5aec40d779073cc2782f5bb5c5c175e8;hpb=119d1c157e519573074720b7897a9fa918329ac5;p=sbcl.git

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 2784334..2768a42 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -41,39 +41,30 @@
 (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))
+(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 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")))))
 
 ;;;; STANDARD-INSTANCE-ACCESS
 
@@ -97,7 +88,7 @@
 
 (declaim (ftype (sfunction (t symbol) t) slot-value))
 (defun slot-value (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
@@ -107,13 +98,13 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-value
-                   (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
                 ((not cell)
                  (return-from 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)
@@ -128,7 +119,7 @@
       form))
 
 (defun set-slot-value (object slot-name new-value)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (type-check-function (cadr cell)))
@@ -141,11 +132,11 @@
                      new-value)))
           ((consp location)
            (setf (cdr location) new-value))
-          ((eq t location)
-           (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
-                 new-value))
           ((not cell)
            (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)
@@ -171,7 +162,7 @@
       form))
 
 (defun slot-boundp (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell))
          (value
@@ -181,14 +172,14 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-boundp
-                   (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
                 ((not cell)
                  (return-from slot-boundp
                    (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))))
@@ -201,7 +192,7 @@
       form))
 
 (defun slot-makunbound (object slot-name)
-  (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+  (let* ((wrapper (valid-wrapper-of object))
          (cell (find-slot-cell wrapper slot-name))
          (location (car cell)))
     (cond ((fixnump location)
@@ -211,10 +202,10 @@
                      +slot-unbound+)))
           ((consp location)
            (setf (cdr location) +slot-unbound+))
-          ((eq t location)
-           (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
           ((not cell)
            (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)
@@ -453,7 +444,7 @@
   (let ((constructor (class-defstruct-constructor class)))
     (if constructor
         (funcall constructor)
-        (allocate-standard-instance (class-wrapper class)))))
+        (error "Don't know how to allocate ~S" class))))
 
 ;;; FIXME: It would be nicer to have allocate-instance return
 ;;; uninitialized objects for conditions as well.
@@ -465,3 +456,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)))))