X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=1919d3b188037aa17692058a055dc5db441aeac2;hb=f17e3d27d7ff599f9443d011d17017a2a858c81a;hp=4ca54159efe6a5d299b8beb41ce08808c1ac4b6f;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 4ca5415..1919d3b 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -89,7 +89,10 @@
 (declaim (ftype (sfunction (t symbol) t) slot-value))
 (defun slot-value (object slot-name)
   (let* ((wrapper (valid-wrapper-of object))
-         (cell (find-slot-cell wrapper slot-name))
+         (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)
@@ -98,19 +101,17 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((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))))
+                   (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)
@@ -120,11 +121,15 @@
 
 (defun set-slot-value (object slot-name new-value)
   (let* ((wrapper (valid-wrapper-of object))
-         (cell (find-slot-cell wrapper slot-name))
+         (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))
-         (type-check-function (cadr cell)))
-    (when type-check-function
-      (funcall (the function type-check-function) new-value))
+         (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)
@@ -132,11 +137,8 @@
                      new-value)))
           ((consp location)
            (setf (cdr location) 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))
+           (funcall (slot-info-writer info) new-value object))
           (t
            (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
   new-value)
@@ -148,6 +150,8 @@
 (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)
@@ -163,7 +167,11 @@
 
 (defun slot-boundp (object slot-name)
   (let* ((wrapper (valid-wrapper-of object))
-         (cell (find-slot-cell wrapper slot-name))
+         (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)
@@ -172,14 +180,9 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((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))))
+                   (funcall (slot-info-boundp (cdr cell)) object)))
                 (t
                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
     (not (eq +slot-unbound+ value))))
@@ -205,7 +208,8 @@
           ((not cell)
            (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
           ((not location)
-           (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
+           (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)
@@ -258,29 +262,27 @@
   ;; 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))
-        (type-check-function
-         (when (safe-p class)
-           (slot-definition-type-check-function slotd))))
-    (flet ((check (new-value)
-             (when type-check-function
-               (funcall (the function type-check-function) new-value))
-             new-value))
-      (typecase location
-        (fixnum
-         (cond ((std-instance-p object)
-                (setf (clos-slots-ref (std-instance-slots object) location)
-                      (check new-value)))
-               ((fsc-instance-p object)
-                (setf (clos-slots-ref (fsc-instance-slots object) location)
-                      (check new-value)))
-                (t (bug "unrecognized instance type in ~S"
-                        '(setf slot-value-using-class)))))
-        (cons
-         (setf (cdr location) (check new-value)))
-        (t
-         (instance-structure-protocol-error
-          slotd '(setf slot-value-using-class)))))))
+  (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 (bug "unrecognized instance type in ~S"
+                     '(setf slot-value-using-class)))))
+      (cons
+       (setf (cdr location) new-value))
+      (t
+       (instance-structure-protocol-error
+        slotd '(setf slot-value-using-class))))))
 
 (defmethod slot-boundp-using-class
            ((class std-class)
@@ -335,8 +337,7 @@
     ((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)
@@ -344,16 +345,14 @@
      (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)
@@ -426,7 +425,7 @@
     instance
     (etypecase position
       (fixnum
-       (nth position (wrapper-instance-slots-layout (wrapper-of instance))))
+       (car (nth position (wrapper-instance-slots-layout (wrapper-of instance)))))
       (cons
        (car position))))))
 
@@ -444,7 +443,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.