X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=100407d0beacafc4fdb4466ac2274a15077d0e00;hb=2fb5b174f6acb88a85c86aa4cd753ddefaccc987;hp=42b2ec08049b360f89ba0ba072ad4da9b6fb7b88;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 42b2ec0..100407d 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -892,6 +892,28 @@
 (slot-boundp *obsoleted* 'a)
 (assert (= *obsoleted-counter* 1))
 
+;;; yet another MAKE-INSTANCES-OBSOLETE test, this time from Nikodemus
+;;; Siivola.  Not all methods for accessing slots are created equal...
+(defclass yet-another-obsoletion-super () ((obs :accessor obs-of :initform 0)))
+(defclass yet-another-obsoletion-sub (yet-another-obsoletion-super) ())
+(defmethod shared-initialize :after ((i yet-another-obsoletion-super)
+                                     slots &rest init)
+  (incf (obs-of i)))
+
+(defvar *yao-super* (make-instance 'yet-another-obsoletion-super))
+(defvar *yao-sub* (make-instance 'yet-another-obsoletion-sub))
+
+(assert (= (obs-of *yao-super*) 1))
+(assert (= (obs-of *yao-sub*) 1))
+(make-instances-obsolete 'yet-another-obsoletion-super)
+(assert (= (obs-of *yao-sub*) 2))
+(assert (= (obs-of *yao-super*) 2))
+(make-instances-obsolete 'yet-another-obsoletion-super)
+(assert (= (obs-of *yao-super*) 3))
+(assert (= (obs-of *yao-sub*) 3))
+(assert (= (slot-value *yao-super* 'obs) 3))
+(assert (= (slot-value *yao-sub* 'obs) 3))
+
 ;;; shared -> local slot transfers of inherited slots, reported by
 ;;; Bruno Haible
 (let (i)
@@ -1201,4 +1223,12 @@
 (with-test (:name (:ctor :unnamed-after/symbol))
   (assert (raises-error? (ctor-unnamed-literal-class2/symbol))))
 
+;;; classes with slot types shouldn't break if the types don't name
+;;; classes (bug #391)
+(defclass slot-type-superclass () ((slot :type fixnum)))
+(defclass slot-type-subclass (slot-type-superclass)
+  ((slot :type (integer 1 5))))
+(let ((instance (make-instance 'slot-type-subclass)))
+  (setf (slot-value instance 'slot) 3))
+
 ;;;; success