X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=7fa30139fcf7056d0a866daada61c78fb2f25a7f;hb=157e21959c8023f146d6b03206aea6daa60e7b0d;hp=1b1326be3792057048474ac7b365d118987a8e77;hpb=903f4432362a1e7764dfed46d35894625cc085d8;p=sbcl.git

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 1b1326b..7fa3013 100644
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -75,62 +75,145 @@
          (t
           (error "unrecognized instance type")))))
 
-(defun find-slot-definition (class slot-name)
-  (dolist (slot (class-slots class) nil)
-    (when (eql slot-name (slot-definition-name slot))
-      (return slot))))
+;;;; STANDARD-INSTANCE-ACCESS
+
+(declaim (inline standard-instance-access (setf standard-instance-access)
+                 funcallable-standard-instance-access
+                 (setf 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 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))
+
+;;;; 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)
-        (values (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 (constant-form-value slot-name)))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (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))
+                ((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))))
+                (t
+                 (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+    (if (eq +slot-unbound+ value)
+        (slot-unbound class object slot-name)
+        value)))
+
+(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)
-        (progn (slot-missing class object slot-name 'setf new-value)
-               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 (constant-form-value slot-name)))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (location (car cell))
+         (type-check-function (cadr cell)))
+    (when type-check-function
+      (funcall (the function type-check-function) 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))
+          ((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))
+          (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))
+
+(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)
-        (not (not (slot-missing class object slot-name 'slot-boundp)))
-        (slot-boundp-using-class class object slot-definition))))
-
-(setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
-
-(define-compiler-macro slot-boundp (&whole form object slot-name)
-  (if (and (constantp slot-name)
-           (interned-symbol-p (constant-form-value slot-name)))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class slot-name))
+         (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))
+                ((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)))
+                (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))
-    object))
+  (let* ((class (check-obsolete-instance/class-of object))
+         (cell (find-slot-cell class 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+))
+          ((eq t location)
+           (slot-makunbound-using-class class object (cddr cell)))
+          ((not cell)
+           (slot-missing class object slot-name 'slot-makunbound))
+          (t
+           (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
+  object)
 
 (defun slot-exists-p (object slot-name)
   (let ((class (class-of object)))
@@ -145,16 +228,12 @@
   (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 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
@@ -181,28 +260,39 @@
            (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)))
-    (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))))))
+  (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)))))))
 
 (defmethod slot-boundp-using-class
            ((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
@@ -368,3 +458,4 @@
 (defmethod allocate-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))
   (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP
+