X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=2f642b56ceeed3da82c65fd5ad83033b3a4b868c;hb=df679ed627975948b1cee190f4d79c397588c43e;hp=41b20492243771bfa4b5ee2beb5b0729a72c4f35;hpb=619ee68faffc3990c5108611762ef54bf8cbbd1e;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 41b2049..2f642b5 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -176,8 +176,16 @@
 ;;; that it doesn't happen again.
 ;;;
 ;;; First, the forward references:
-(defclass a (b) ())
-(defclass b () ())
+(defclass forward-ref-a (forward-ref-b) ())
+(defclass forward-ref-b () ())
+;;; (a couple more complicated examples found by Paul Dietz' test
+;;; suite):
+(defclass forward-ref-c1 (forward-ref-c2) ())
+(defclass forward-ref-c2 (forward-ref-c3) ())
+
+(defclass forward-ref-d1 (forward-ref-d2 forward-ref-d3) ())
+(defclass forward-ref-d2 (forward-ref-d4 forward-ref-d5) ())
+
 ;;; Then change-class
 (defclass class-with-slots ()
   ((a-slot :initarg :a-slot :accessor a-slot)
@@ -312,7 +320,9 @@
   (assert-program-error (defclass foo008 ()
 			  (a :initarg :a)
 			  (:default-initargs :a 1)
-			  (:default-initargs :a 2))))
+			  (:default-initargs :a 2)))
+  ;; and also BUG 47d, fixed in sbcl-0.8alpha.0.26
+  (assert-program-error (defgeneric if (x))))
 
 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.
@@ -553,5 +563,52 @@
 (bug234-b)
 (assert (= *bug234-b* 1))
 
+;;; we should be able to make classes with uninterned names:
+(defclass #:class-with-uninterned-name () ())
+
+;;; 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))
+	    'setf))
+
+;;; 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))
+
+;;; 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)))
+
+;;; 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)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)