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