From dcff832392202acbd0c71c5cb8e27ef887065ca0 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 9 Jul 2004 14:33:45 +0000 Subject: [PATCH] 0.8.12.27: I WIN! ... fix for multiple bugs with SLOT-DEFINITION-ALLOCATION not being :INSTANCE or :CLASS: ... step 1: don't assert that it must be; ... step 2: handle a NULL location when generating optimized accessors, returning a function that calls ERROR. ... add a slightly-reworked test from AMOP (mostly the rework is because at that stage in AMOP we're still in closette, not the full MOP) --- NEWS | 9 ++- src/pcl/slots-boot.lisp | 41 ++++++++++++-- src/pcl/std-class.lisp | 4 +- tests/mop-1.impure-cload.lisp | 125 +++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 169 insertions(+), 12 deletions(-) create mode 100644 tests/mop-1.impure-cload.lisp diff --git a/NEWS b/NEWS index 1fa748b..f3f4339 100644 --- a/NEWS +++ b/NEWS @@ -9,9 +9,6 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12: 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 @@ -28,6 +25,12 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12: * 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 diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 43bf09a..354e3e5 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -196,7 +196,14 @@ (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) @@ -214,7 +221,13 @@ 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) @@ -234,7 +247,11 @@ +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) @@ -328,7 +345,12 @@ (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) @@ -349,7 +371,11 @@ (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) @@ -370,7 +396,10 @@ (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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 382a235..fdc3ebb 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -1040,7 +1040,7 @@ (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 @@ -1102,7 +1102,7 @@ (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))) diff --git a/tests/mop-1.impure-cload.lisp b/tests/mop-1.impure-cload.lisp new file mode 100644 index 0000000..42f7453 --- /dev/null +++ b/tests/mop-1.impure-cload.lisp @@ -0,0 +1,125 @@ +;;;; 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))) + diff --git a/version.lisp-expr b/version.lisp-expr index 0de7ade..e738aa2 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".) -"0.8.12.26" +"0.8.12.27" -- 1.7.10.4