+
+;;; 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)))
+
+;;; Until Pierre Mai's patch (sbcl-devel 2002-06-18, merged in
+;;; sbcl-0.7.4.39) the :MOST-SPECIFIC-LAST option had no effect.
+(defgeneric bug180 ((x t))
+ (:method-combination list :most-specific-last))
+(defmethod bug180 list ((x number))
+ 'number)
+(defmethod bug180 list ((x fixnum))
+ 'fixnum)
+(assert (equal (bug180 14) '(number fixnum)))
+\f
+;;; 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)))
+\f
+;;; At least as of sbcl-0.7.4, PCL has code to support a special
+;;; encoding of effective method functions for slot accessors as
+;;; FIXNUMs. Given this special casing, it'd be easy for slot accessor
+;;; functions to get broken in special ways even though ordinary
+;;; generic functions work. As of sbcl-0.7.4 we didn't have any tests
+;;; for that possibility. Now we have a few tests:
+(defclass fish ()
+ ((fin :reader ffin :writer ffin!)
+ (tail :reader ftail :writer ftail!)))
+(defvar *fish* (make-instance 'fish))
+(ffin! 'triangular-fin *fish*)
+(defclass cod (fish) ())
+(defvar *cod* (make-instance 'cod))
+(defparameter *clos-dispatch-side-fx* (make-array 0 :fill-pointer 0))
+(defmethod ffin! (new-fin (cod cod))
+ (format t "~&about to set ~S fin to ~S~%" cod new-fin)
+ (vector-push-extend '(cod) *clos-dispatch-side-fx*)
+ (prog1
+ (call-next-method)
+ (format t "~&done setting ~S fin to ~S~%" cod new-fin)))
+(defmethod ffin! :before (new-fin (cod cod))
+ (vector-push-extend '(:before cod) *clos-dispatch-side-fx*)
+ (format t "~&exploring the CLOS dispatch zoo with COD fins~%"))
+(ffin! 'almost-triang-fin *cod*)
+(assert (eq (ffin *cod*) 'almost-triang-fin))
+(assert (equalp #((:before cod) (cod)) *clos-dispatch-side-fx*))