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),
@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:
@end itemize
+@subsection Metaobject Protocol Extensions
+
In addition, SBCL supports extensions to the Metaobject protocol from
AMOP; at present, they are:
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
;; 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.
;;; this an interned symbol. That means that the fast check to see
;;; whether a slot is unbound is to say (EQ <val> '..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+))
--- /dev/null
+;;;; 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?)))))
;;; 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"
projects / sbcl.git / commitdiff