From 81e608991b9f616a412564b26186fa29933d814c Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 21 Jul 2007 01:55:42 +0000 Subject: [PATCH] 1.0.7.36: FIND-SLOT-DEFINITION to return NIL when called with non-slot-classes * Add a default method to CLASS-SLOT-VECTOR that returns #(NIL), restoring the pre-1.0.7.26 behaviour of calling SLOT-MISSING when trying to access slots in non-SLOT-CLASS instances. * Add a slightly dubious test-case. --- src/pcl/slots-boot.lisp | 2 +- src/pcl/std-class.lisp | 5 +++++ tests/clos.impure.lisp | 21 +++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 28 insertions(+), 2 deletions(-) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 752b1901a..9f416cf8d 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -551,7 +551,7 @@ ;;; empty vector separately: it just returns a NIL. (defun find-slot-definition (class slot-name) - (declare (symbol slot-name) (inline getf)) + (declare (symbol slot-name)) (let* ((vector (class-slot-vector class)) (index (rem (sxhash slot-name) (length vector)))) (declare (simple-vector vector) (index index) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index b63d660a3..cdffa526e 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1557,6 +1557,11 @@ (def class-direct-default-initargs) (def class-default-initargs)) +(defmethod class-slot-vector (class) + ;; Default method to cause FIND-SLOT-DEFINITION return NIL for all + ;; non SLOT-CLASS classes. + #(nil)) + (defmethod validate-superclass ((c class) (s built-in-class)) (or (eq s *the-class-t*) (eq s *the-class-stream*) ;; FIXME: bad things happen if someone tries to mix in both diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 47ad9247f..d9155ef82 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1545,5 +1545,26 @@ (assert (equal '(:foo 13) (apply #'test-long-form-with-&rest :foo (make-list 13)))) +;;;; slot-missing for non-standard classes on SLOT-VALUE +;;;; +;;;; FIXME: This is arguably not right, actually: CLHS seems to say +;;;; we should just signal an error at least for built-in classes, but +;;;; for a while we were hitting NO-APPLICABLE-METHOD, which is definitely +;;;; wrong -- so test this for now at least. + +(defvar *magic-symbol* (gensym "MAGIC")) + +(set *magic-symbol* 42) + +(defmethod slot-missing (class instance (slot-name (eql *magic-symbol*)) op + &optional new) + (if (eq 'setf op) + (setf (symbol-value *magic-symbol*) new) + (symbol-value *magic-symbol*))) + +(assert (eql 42 (slot-value (cons t t) *magic-symbol*))) +(assert (eql 13 (setf (slot-value 123 *magic-symbol*) 13))) +(assert (eql 13 (slot-value 'foobar *magic-symbol*))) + ;;;; success diff --git a/version.lisp-expr b/version.lisp-expr index fe8d58b1c..8895fc4a6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.7.35" +"1.0.7.36" -- 2.11.4.GIT