an implementation-internal package.
* the SB-SPROF contrib now works on (most) non-x86 architectures.
It is known as of this release not to work on the Alpha, however.
- * fixed bug: initialization of condition class metaobjects no longer
- causes an instance of the condition to be created. (reported by Marco
- Baringer)
* fixed bug #167: errors signalled due to illegal syntax in method
bodies are now more legible.
* fixed bug #338: instances of EQL-SPECIFIER are now valid type
* fixed a bug: #\Space (and other whitespace characters) are no
longer considered to be macro characters in standard syntax by
GET-MACRO-CHARACTER.
+ * fixed bug: initialization of condition class metaobjects no longer
+ causes an instance of the condition to be created. (reported by
+ Marco Baringer)
+ * fixed bug: it is now possible to have slots such that
+ SB-MOP:SLOT-DEFINITION-ALLOCATION of the effective slot
+ description is neither :INSTANCE nor :CLASS.
changes in sbcl-0.8.12 relative to sbcl-0.8.11:
* minor incompatible change: the system no longer provides
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(values (slot-unbound (class-of instance) instance slot-name))
- value)))))
+ value))))
+ (null
+ (lambda (instance)
+ ;; maybe MOP-ERROR? You get here by making effective slot
+ ;; definitions with :ALLOCATION not :INSTANCE or :CLASS, and
+ ;; not defining any methods on SLOT-VALUE-USING-CLASS.
+ (error "~S called on ~S for the slot ~S (with no location information)"
+ 'slot-value instance slot-name))))
`(reader ,slot-name)))
(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
nv))))
(cons (lambda (nv instance)
(check-obsolete-instance instance)
- (setf (cdr index) nv))))
+ (setf (cdr index) nv)))
+ (null
+ (lambda (nv instance)
+ (declare (ignore nv))
+ ;; again, maybe MOP-ERROR (see above)
+ (error "~S called on ~S for the slot ~S (with no location information)"
+ '(setf slot-value) instance slot-name))))
`(writer ,slot-name)))
(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+slot-unbound+)))))
(cons (lambda (instance)
(check-obsolete-instance instance)
- (not (eq (cdr index) +slot-unbound+)))))
+ (not (eq (cdr index) +slot-unbound+))))
+ (null
+ (lambda (instance)
+ (error "~S called on ~S for the slot ~S (with no location information)"
+ 'slot-boundp instance slot-name))))
`(boundp ,slot-name)))
(defun make-optimized-structure-slot-value-using-class-method-function (function)
(let ((value (cdr index)))
(if (eq value +slot-unbound+)
(values (slot-unbound class instance slot-name))
- value))))))
+ value))))
+ (null
+ (lambda (class instance slotd)
+ ;; FIXME: MOP-ERROR
+ (error "Standard ~S method called on arguments ~S."
+ 'slot-value-using-class (list class instance slotd))))))
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slot-name index)
(cons (lambda (nv class instance slotd)
(declare (ignore class slotd))
(check-obsolete-instance instance)
- (setf (cdr index) nv)))))
+ (setf (cdr index) nv)))
+ (null (lambda (nv class instance slotd)
+ (error "Standard ~S method called on arguments ~S."
+ '(setf slot-value-using-class)
+ (list nv class instance slotd))))))
(defun make-optimized-std-slot-boundp-using-class-method-function
(fsc-p slot-name index)
(cons (lambda (class instance slotd)
(declare (ignore class slotd))
(check-obsolete-instance instance)
- (not (eq (cdr index) +slot-unbound+))))))
+ (not (eq (cdr index) +slot-unbound+))))
+ (null (lambda (class instance slotd)
+ (error "Standard ~S method called on arguments ~S."
+ 'slot-boundp-using-class (list class instance slotd))))))
(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
(macrolet ((emf-funcall (emf &rest args)
(location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
- (ecase (slot-definition-allocation eslotd)
+ (case (slot-definition-allocation eslotd)
(:instance
(incf location))
(:class
(instance-slots ())
(class-slots ()))
(dolist (slotd all-slotds)
- (ecase (slot-definition-allocation slotd)
+ (case (slot-definition-allocation slotd)
(:instance (push slotd instance-slots))
(:class (push slotd class-slots))))
(let ((layout (compute-layout instance-slots)))
--- /dev/null
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; 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.
+
+;;;; Note that the MOP is not in an entirely supported state.
+;;;; However, this seems a good a way as any of ensuring that we have
+;;;; no regressions.
+
+;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
+;;; fixups for running in the full MOP rather than closette: SLOTDs
+;;; instead of slot-names, and so on.
+
+(defpackage "TEST" (:use "CL" "SB-MOP"))
+(in-package "TEST")
+
+(defclass dynamic-slot-class (standard-class) ())
+
+(defmethod validate-superclass
+ ((class dynamic-slot-class) (super standard-class))
+ t)
+
+(defmethod compute-effective-slot-definition
+ ((class dynamic-slot-class) name direct-slots)
+ (let ((slot (call-next-method)))
+ (setf (slot-definition-allocation slot) :dynamic)
+ slot))
+
+(defun dynamic-slot-p (slot)
+ (eq (slot-definition-allocation slot) :dynamic))
+
+(let ((table (make-hash-table)))
+
+ (defun allocate-table-entry (instance)
+ (setf (gethash instance table) ()))
+
+ (defun read-dynamic-slot-value (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (error "slot ~S unbound in ~S" slot-name instance)
+ (cdr entry))))
+
+ (defun write-dynamic-slot-value (new-value instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (if (null entry)
+ (push `(,slot-name . ,new-value)
+ (gethash instance table))
+ (setf (cdr entry) new-value))
+ new-value))
+
+ (defun dynamic-slot-boundp (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (not (null entry))))
+
+ (defun dynamic-slot-makunbound (instance slot-name)
+ (let* ((alist (gethash instance table))
+ (entry (assoc slot-name alist)))
+ (unless (null entry)
+ (setf (gethash instance table) (delete entry alist))))
+ instance)
+
+)
+
+(defmethod allocate-instance ((class dynamic-slot-class) &key)
+ (let ((instance (call-next-method)))
+ (allocate-table-entry instance)
+ instance))
+
+(defmethod slot-value-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (read-dynamic-slot-value instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod slot-boundp-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (dynamic-slot-boundp instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defmethod slot-makunbound-using-class ((class dynamic-slot-class)
+ instance slotd)
+ (let ((slot (find slotd (class-slots class))))
+ (if slot
+ (dynamic-slot-makunbound instance (slot-definition-name slotd))
+ (call-next-method))))
+
+(defclass test-class-1 ()
+ ((slot1 :initarg :slot1)
+ (slot2 :initarg :slot2 :initform nil))
+ (:metaclass dynamic-slot-class))
+
+(defclass test-class-2 (test-class-1)
+ ((slot2 :initarg :slot2 :initform t)
+ (slot3 :initarg :slot3))
+ (:metaclass dynamic-slot-class))
+
+(defvar *one* (make-instance 'test-class-1))
+(defvar *two* (make-instance 'test-class-2 :slot3 1))
+
+(assert (not (slot-boundp *one* 'slot1)))
+(assert (null (slot-value *one* 'slot2)))
+(assert (eq t (slot-value *two* 'slot2)))
+(assert (= 1 (slot-value *two* 'slot3)))
+
;;; 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".)
-"0.8.12.26"
+"0.8.12.27"
projects / sbcl.git / commitdiff