X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=237e5eaac84f6d007a99f109f59877f2cb158de2;hb=4e3b57699314dbd3883470d9b196287b178f3e6d;hp=9d43e31eb19ab3ddfc035ff3b6d6d4829170f587;hpb=ec6d4bd97d9adc6f4003747d8ca92fad7766ccfd;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 9d43e31..237e5ea 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -115,6 +115,72 @@
 (defgeneric born-to-be-redefined (x))
 (assert (eq (born-to-be-redefined 1) 'int))
 
+;;; In the removal of ITERATE from SB-PCL, a bug was introduced
+;;; preventing forward-references and also change-class (which
+;;; forward-references used interally) from working properly.  One
+;;; symptom was reported by Brian Spilsbury (sbcl-devel 2002-04-08),
+;;; and another on IRC by Dan Barlow simultaneously.  Better check
+;;; that it doesn't happen again.
+;;;
+;;; First, the forward references:
+(defclass a (b) ())
+(defclass b () ())
+;;; Then change-class
+(defclass class-with-slots ()
+  ((a-slot :initarg :a-slot :accessor a-slot)
+   (b-slot :initarg :b-slot :accessor b-slot)
+   (c-slot :initarg :c-slot :accessor c-slot)))
+
+(let ((foo (make-instance 'class-with-slots
+			  :a-slot 1
+			  :b-slot 2
+			  :c-slot 3)))
+  (let ((bar (change-class foo 'class-with-slots)))
+    (assert (= (a-slot bar) 1))
+    (assert (= (b-slot bar) 2))
+    (assert (= (c-slot bar) 3))))
+
+;;; some more change-class testing, now that we have an ANSI-compliant
+;;; version (thanks to Espen Johnsen):
+(defclass from-class ()
+  ((foo :initarg :foo :accessor foo)))
+
+(defclass to-class ()
+  ((foo :initarg :foo :accessor foo)
+   (bar :initarg :bar :accessor bar)))
+
+(let* ((from (make-instance 'from-class :foo 1))
+       (to (change-class from 'to-class :bar 2)))
+  (assert (= (foo to) 1))
+  (assert (= (bar to) 2)))
+
+;;; printing a structure class should not loop indefinitely (or cause
+;;; a stack overflow):
+(defclass test-printing-structure-class ()
+  ((slot :initarg :slot))
+  (:metaclass structure-class))
+
+(print (make-instance 'test-printing-structure-class :slot 2))
+
+;;; structure-classes should behave nicely when subclassed
+(defclass super-structure ()
+  ((a :initarg :a :accessor a-accessor)
+   (b :initform 2 :reader b-reader))
+  (:metaclass structure-class))
+
+(defclass sub-structure (super-structure)
+  ((c :initarg :c :writer c-writer :accessor c-accessor))
+  (:metaclass structure-class))
+
+(let ((foo (make-instance 'sub-structure :a 1 :c 3)))
+  (assert (= (a-accessor foo) 1))
+  (assert (= (b-reader foo) 2))
+  (assert (= (c-accessor foo) 3))
+  (setf (a-accessor foo) 4)
+  (c-writer 5 foo)
+  (assert (= (a-accessor foo) 4))
+  (assert (= (c-accessor foo) 5)))
+
 ;;;; success
 
 (sb-ext:quit :unix-status 104)