From 838316d0ad9affb2a4284ece65798aed6313d7e7 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 13 Feb 2011 20:34:14 +0000 Subject: [PATCH] 1.0.45.32: export SB-PCL:+SLOT-UNBOUND+ Using STANDARD-INSTANCE-ACCESS with this provided is much nicer -- no need to muck around with SLOT-BOUNDP-USING-CLASS and such. Also add quick SIA tests and some dependant update abuse to tests. lp#718039 --- NEWS | 3 ++ doc/manual/beyond-ansi.texinfo | 13 ++++++ package-data-list.lisp-expr | 3 +- src/pcl/low.lisp | 23 +++++----- tests/mop-30.impure.lisp | 96 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 128 insertions(+), 12 deletions(-) create mode 100644 tests/mop-30.impure.lisp diff --git a/NEWS b/NEWS index 1120bec..51a1c8f 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ changes relative to sbcl-1.0.45: arguments (lp#710017) * enhancement: forward referenced functions no longer cause STYLE-WARNINGS when running under --script. (lp#677779) + * enhancement: SB-PCL:+SLOT-UNBOUND+ is exported, making it possible to + distinguish unbound instance slots when using STANDARD-INSTANCE-ACCESS + &co. (lp#718039) * optimization: ERROR and CERROR are approximately 5 times faster. * optimization: optimized constructors are used for MAKE-INSTANCE of classes with applicable non-standard (SETF SLOT-VALUE-USING-CLASS), diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo index 83197f6..224a1f7 100644 --- a/doc/manual/beyond-ansi.texinfo +++ b/doc/manual/beyond-ansi.texinfo @@ -69,6 +69,8 @@ Extensions}. @comment node-name, next, previous, up @section Metaobject Protocol +@subsection AMOP Compatibility of Metaobject Protocol + SBCL supports a metaobject protocol which is intended to be compatible with AMOP; present exceptions to this (as distinct from current bugs) are: @@ -217,6 +219,8 @@ states that any class found by @code{find-class}, no matter what its @end itemize +@subsection Metaobject Protocol Extensions + In addition, SBCL supports extensions to the Metaobject protocol from AMOP; at present, they are: @@ -256,6 +260,15 @@ specializer. The system-provided methods on those methods convert between classes and proper names and between lists of the form @code{(eql @var{x})} and interned eql specializer objects. +@item +@vindex @sbpcl{+slot-unbound+} +@findex @sbmop{standard-instance-access} +@findex @sbmop{funcallable-standard-instance-access} +distinguising unbound instance allocated slots from bound ones when +using @code{standard-instance-access} and +@code{funcallable-standard-instance-access} is possible by comparison +to the constant @code{+slot-unbound+}. + @end itemize @node Support For Unix diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index e99ff95..5f87966 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2100,7 +2100,8 @@ package is deprecated in favour of SB-MOP." ;; experimental SBCL-only (for now) symbols :export ("MAKE-METHOD-SPECIALIZERS-FORM" "PARSE-SPECIALIZER-USING-CLASS" - "UNPARSE-SPECIALIZER-USING-CLASS") + "UNPARSE-SPECIALIZER-USING-CLASS" + "+SLOT-UNBOUND+") ;; FIXME: After a little while, these reexports can probably go ;; away, as they're superseded by the use of SB-MOP as the ;; publically-accessible package. diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index 9de5763..db01419 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -173,17 +173,20 @@ ;;; this an interned symbol. That means that the fast check to see ;;; whether a slot is unbound is to say (EQ '..SLOT-UNBOUND..). ;;; That is considerably faster than looking at the value of a special -;;; variable. Be careful, there are places in the code which actually -;;; use ..SLOT-UNBOUND.. rather than this variable. So much for -;;; modularity.. +;;; variable. ;;; -;;; FIXME: Now that we're tightly integrated into SBCL, we could use -;;; the SBCL built-in unbound value token instead. Perhaps if we did -;;; so it would be a good idea to define collections of CLOS slots as -;;; a new type of heap object, instead of using bare SIMPLE-VECTOR, in -;;; order to avoid problems (in the debugger if nowhere else) with -;;; SIMPLE-VECTORs some of whose elements are unbound tokens. -(defconstant +slot-unbound+ '..slot-unbound..) +;;; It seems only reasonable to also export this for users, since +;;; otherwise dealing with STANDARD-INSTANCE-ACCESS becomes harder +;;; -- and slower -- than it needs to be. +(defconstant +slot-unbound+ '..slot-unbound.. + "SBCL specific extentions to MOP: if this value is read from an +instance using STANDARD-INSTANCE-ACCESS, the slot is unbound. +Similarly, an :INSTANCE allocated slot can be made unbound by +assigning this to it using (SETF STANDARD-INSTANCE-ACCESS). + +Value of +SLOT-UNBOUND+ is unspecified, and should not be relied to be +of any particular type, but it is guaranteed to be suitable for EQ +comparison.") (defmacro %allocate-static-slot-storage--class (no-of-slots) `(make-array ,no-of-slots :initial-element +slot-unbound+)) diff --git a/tests/mop-30.impure.lisp b/tests/mop-30.impure.lisp new file mode 100644 index 0000000..e0bd798 --- /dev/null +++ b/tests/mop-30.impure.lisp @@ -0,0 +1,96 @@ +;;;; Standard-instance-access tests and update-protocol abuse + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +(load "test-util.lisp") + +(defpackage :mop-test-30 + (:use :sb-pcl :sb-ext :cl :test-util)) + +(in-package :mop-test-30) + +(defclass foo () + ((bar :initarg :bar) + (quux :initarg :quux))) + +(defclass foomagic () + ()) + +(defun find-slot (name class) + (let ((class (find-class class))) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (find name (class-slots class) :key #'slot-definition-name))) + +(add-dependent (find-class 'foo) (find-class 'foomagic)) + +(defglobal **bar-loc** (slot-definition-location (find-slot 'bar 'foo))) +(defglobal **quux-loc** (slot-definition-location (find-slot 'quux 'foo))) + +(defmethod update-dependent ((meta (eql (find-class 'foo))) + (dep (eql (find-class 'foomagic))) + &key) + (setf **bar-loc** (slot-definition-location (find-slot 'bar 'foo)) + **quux-loc** (slot-definition-location (find-slot 'quux 'foo)))) + +(defun foo-bar/quux (foo) + (declare (type foo foo)) + (values (standard-instance-access foo **bar-loc**) + (standard-instance-access foo **quux-loc**))) + +(defun swap-bar/quux (foo) + (declare (type foo foo)) + (rotatef (standard-instance-access foo **bar-loc**) + (standard-instance-access foo **quux-loc**))) + +(with-test (:name :standard-instance-access) + (let ((bar (cons t t)) + (quux (cons nil nil))) + (multiple-value-bind (bar? quux?) + (foo-bar/quux (make-instance 'foo :bar bar :quux quux)) + (assert (eq bar bar?)) + (assert (eq quux quux?))))) + +(with-test (:name :standard-instance-access/setf) + (let* ((bar (cons t t)) + (quux (cons nil nil)) + (foo + (make-instance 'foo :bar bar :quux quux))) + (multiple-value-bind (bar? quux?) (foo-bar/quux foo) + (assert (eq bar bar?)) + (assert (eq quux quux?))) + (swap-bar/quux foo) + (multiple-value-bind (bar? quux?) (foo-bar/quux foo) + (assert (eq quux bar?)) + (assert (eq bar quux?))))) + +;;; Sneaky redefinition reorders slots! +(defclass foo () + ((quux :initarg :quux) + (bar :initarg :bar))) + +(with-test (:name :standard-instance-access/updated) + (let ((bar (cons t t)) + (quux (cons nil nil))) + (multiple-value-bind (bar? quux?) + (foo-bar/quux (make-instance 'foo :bar bar :quux quux)) + (assert (eq bar bar?)) + (assert (eq quux quux?))))) + +(with-test (:name :standard-instance-access/slot-unbound) + (let ((bar (cons t t))) + (multiple-value-bind (bar? quux?) + (foo-bar/quux (make-instance 'foo :bar bar)) + (assert (eq bar bar?)) + (assert (eq +slot-unbound+ quux?))))) diff --git a/version.lisp-expr b/version.lisp-expr index b57f14e..03b2e40 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,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.45.31" +"1.0.45.32" -- 1.7.10.4