+;;; also, some combinations of MAKE-INSTANCE and subclassing missed
+;;; new methods (Gerd Moellmann sbcl-devel 2002-12-29):
+(defclass class234-b1 () ())
+(defclass class234-b2 (class234-b1) ())
+(defvar *bug234-b* 0)
+(defun bug234-b ()
+ (make-instance 'class234-b2))
+(compile 'bug234-b)
+(bug234-b)
+(assert (= *bug234-b* 0))
+(defmethod initialize-instance :before ((x class234-b1) &rest args)
+ (declare (ignore args))
+ (incf *bug234-b*))
+(bug234-b)
+(assert (= *bug234-b* 1))
+\f
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+\f
+;;; SLOT-MISSING should be called when there are missing slots.
+(defclass class-with-all-slots-missing () ())
+(defmethod slot-missing (class (o class-with-all-slots-missing)
+ slot-name op
+ &optional new-value)
+ op)
+(assert (eq (slot-value (make-instance 'class-with-all-slots-missing) 'foo)
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (slot-value x 'bar))
+ (make-instance 'class-with-all-slots-missing))
+ 'slot-value))
+(assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
+ (make-instance 'class-with-all-slots-missing))
+ ;; SLOT-MISSING's value is specified to be ignored; we
+ ;; return NEW-VALUE.
+ 'baz))
+\f
+;;; we should be able to specialize on anything that names a class.
+(defclass name-for-class () ())
+(defmethod something-that-specializes ((x name-for-class)) 1)
+(setf (find-class 'other-name-for-class) (find-class 'name-for-class))
+(defmethod something-that-specializes ((x other-name-for-class)) 2)
+(assert (= (something-that-specializes (make-instance 'name-for-class)) 2))
+(assert (= (something-that-specializes (make-instance 'other-name-for-class))
+ 2))
+\f
+;;; more forward referenced classes stuff
+(defclass frc-1 (frc-2) ())
+(assert (subtypep 'frc-1 (find-class 'frc-2)))
+(assert (subtypep (find-class 'frc-1) 'frc-2))
+(assert (not (subtypep (find-class 'frc-2) 'frc-1)))
+(defclass frc-2 (frc-3) ((a :initarg :a)))
+(assert (subtypep 'frc-1 (find-class 'frc-3)))
+(defclass frc-3 () ())
+(assert (typep (make-instance 'frc-1 :a 2) (find-class 'frc-1)))
+(assert (typep (make-instance 'frc-2 :a 3) (find-class 'frc-2)))
+\f
+;;; check that we can define classes with two slots of different names
+;;; (even if it STYLE-WARNs).
+(defclass odd-name-class ()
+ ((name :initarg :name)
+ (cl-user::name :initarg :name2)))
+(let ((x (make-instance 'odd-name-class :name 1 :name2 2)))
+ (assert (= (slot-value x 'name) 1))
+ (assert (= (slot-value x 'cl-user::name) 2)))
+\f
+;;; ALLOCATE-INSTANCE should work on structures, even if defined by
+;;; DEFSTRUCT (and not DEFCLASS :METACLASS STRUCTURE-CLASS).
+(defstruct allocatable-structure a)
+(assert (typep (allocate-instance (find-class 'allocatable-structure))
+ 'allocatable-structure))
+\f
+;;; Bug found by Paul Dietz when devising CPL tests: somewhat
+;;; amazingly, calls to CPL would work a couple of times, and then
+;;; start returning NIL. A fix was found (relating to the
+;;; applicability of constant-dfun optimization) by Gerd Moellmann.
+(defgeneric cpl (x)
+ (:method-combination list)
+ (:method list ((x broadcast-stream)) 'broadcast-stream)
+ (:method list ((x integer)) 'integer)
+ (:method list ((x number)) 'number)
+ (:method list ((x stream)) 'stream)
+ (:method list ((x structure-object)) 'structure-object))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl 0) '(integer number)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+(assert (equal (cpl (make-broadcast-stream))
+ '(broadcast-stream stream structure-object)))
+\f
+;;; Bug in CALL-NEXT-METHOD: assignment to the method's formal
+;;; parameters shouldn't affect the arguments to the next method for a
+;;; no-argument call to CALL-NEXT-METHOD
+(defgeneric cnm-assignment (x)
+ (:method (x) x)
+ (:method ((x integer)) (setq x 3)
+ (list x (call-next-method) (call-next-method x))))
+(assert (equal (cnm-assignment 1) '(3 1 3)))
+\f
+;;;; success