From: Christophe Rhodes <csr21@cantab.net>
Date: Fri, 15 Nov 2013 09:25:51 +0000 (+0000)
Subject: partially rewrite accessor-values-internal
X-Git-Url: http://repo.macrolet.net/gitweb/?p=sbcl.git;a=commitdiff_plain;h=21744fadb8bcc5334d9481bb5f0ed71e2399e440

partially rewrite accessor-values-internal

It looks old and crufty, but the reason was to handle the admittedly
esoteric case of NIL as a slot name, which can happen in structure
classes.  Be more defensive against merrily finding slot definitions
that have nothing to do with the method in question.

This drive-by fixes lp#633911
---

diff --git a/NEWS b/NEWS
index bda318e..20ede92 100644
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,8 @@ changes relative to sbcl-1.1.13:
   * bug fix: OPEN reports a more meaningful error when an existing file is
     opened for output with :if-exists :new-version.  Thanks to Philip
     Munksgaard. (lp#455381)
+  * bug fix: DEFSTRUCTs with NIL as a slot name no longer cause strange
+    CLOS-related errors.  (lp#633911)
 
 changes in sbcl-1.1.13 relative to sbcl-1.1.12:
   * optimization: better distribution of SXHASH over small conses of related
diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index c463a91..bb5d890 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1187,6 +1187,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
     (accessor-values-internal accessor-type accessor-class methods)))
 
 (defun accessor-values-internal (accessor-type accessor-class methods)
+  (unless accessor-class
+    (return-from accessor-values-internal (values nil nil)))
   (dolist (meth methods)
     (when (if (consp meth)
               (early-method-qualifiers meth)
@@ -1194,31 +1196,26 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
       (return-from accessor-values-internal (values nil nil))))
   (let* ((meth (car methods))
          (early-p (not (eq **boot-state** 'complete)))
-         (slot-name (when accessor-class
-                      (if (consp meth)
-                          (and (early-method-standard-accessor-p meth)
-                               (early-method-standard-accessor-slot-name meth))
-                          (and (member *the-class-standard-object*
-                                       (if early-p
-                                           (early-class-precedence-list
-                                            accessor-class)
-                                           (class-precedence-list
-                                            accessor-class))
-                                       :test #'eq)
-                               (accessor-method-p meth)
-                               (accessor-method-slot-name meth)))))
-         (slotd (and accessor-class
-                     (if early-p
-                         (dolist (slot (early-class-slotds accessor-class) nil)
-                           (when (eql slot-name
-                                      (early-slot-definition-name slot))
-                             (return slot)))
-                         (find-slot-definition accessor-class slot-name)))))
+         (slot-name
+          (cond
+            ((and (consp meth)
+                  (early-method-standard-accessor-p meth))
+             (early-method-standard-accessor-slot-name meth))
+            ((and (atom meth)
+                  (member *the-class-standard-object*
+                          (if early-p
+                              (early-class-precedence-list accessor-class)
+                              (class-precedence-list accessor-class))))
+             (accessor-method-slot-name meth))
+            (t (return-from accessor-values-internal (values nil nil)))))
+         (slotd (if early-p
+                    (dolist (slot (early-class-slotds accessor-class) nil)
+                      (when (eql slot-name (early-slot-definition-name slot))
+                        (return slot)))
+                    (find-slot-definition accessor-class slot-name))))
     (when (and slotd
-               (or early-p
-                   (slot-accessor-std-p slotd accessor-type))
-               (or early-p
-                   (not (safe-p accessor-class))))
+               (or early-p (slot-accessor-std-p slotd accessor-type))
+               (or early-p (not (safe-p accessor-class))))
       (values (if early-p
                   (early-slot-definition-location slotd)
                   (slot-definition-location slotd))
diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp
index 215280a..01b2796 100644
--- a/tests/mop.impure.lisp
+++ b/tests/mop.impure.lisp
@@ -684,5 +684,10 @@
                           (lambda (y) nil)
                           #'definitely-a-funcallable-instance)
                          type-error)))
+
+(with-test (:name (defstruct :nil-slot-name :bug-633911))
+  (defstruct nil-slot-name nil)
+  (let ((fun (compile nil '(lambda (x) (slot-value x 'nil)))))
+    (assert (= 3 (funcall fun (make-nil-slot-name :nil 3))))))
 
 ;;;; success