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,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

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)

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)))

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)))
+

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"