X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=a319f42f260cc487349387d7effd13dc6b0b40e0;hb=937a46e64983862cb9e21761db95e58700341940;hp=f0f7cc3f495c373b76a1d942b8783e8ee80d7c77;hpb=7e00a27796fce8eb5b0ab920dda636584a011ba2;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index f0f7cc3..a319f42 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -70,7 +70,7 @@
 (assert (expect-error (defgeneric foo2 (x a &rest))))
 (defgeneric foo3 (x &rest y))
 (defmethod foo3 ((x t) &rest y) nil)
-(defmethod foo4 ((x t) &key y &rest z) nil)
+(defmethod foo4 ((x t) &rest z &key y) nil)
 (defgeneric foo4 (x &rest z &key y))
 (assert (expect-error (defgeneric foo5 (x &rest))))
 (assert (expect-error (macroexpand-1 '(defmethod foo6 (x &rest)))))
@@ -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,31 @@
   (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)))
+  ;; DEFCLASS should detect an error if slot names aren't suitable as
+  ;; variable names:
+  (assert-program-error (defclass foo009 ()
+			  ((:a :initarg :a))))
+  (assert-program-error (defclass foo010 ()
+			  (("a" :initarg :a))))
+  (assert-program-error (defclass foo011 ()
+			  ((#1a() :initarg :a))))
+  (assert-program-error (defclass foo012 ()
+			  ((t :initarg :t))))
+  (assert-program-error (defclass foo013 () ("a")))
+  ;; specialized lambda lists have certain restrictions on ordering,
+  ;; repeating keywords, and the like:
+  (assert-program-error (defmethod foo014 ((foo t) &rest) nil))
+  (assert-program-error (defmethod foo015 ((foo t) &rest x y) nil))
+  (assert-program-error (defmethod foo016 ((foo t) &allow-other-keys) nil))
+  (assert-program-error (defmethod foo017 ((foo t)
+					   &optional x &optional y) nil))
+  (assert-program-error (defmethod foo018 ((foo t) &rest x &rest y) nil))
+  (assert-program-error (defmethod foo019 ((foo t) &rest x &optional y) nil))
+  (assert-program-error (defmethod foo020 ((foo t) &key x &optional y) nil))
+  (assert-program-error (defmethod foo021 ((foo t) &key x &rest y) nil)))
 
 ;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
 ;;; preserved through the bootstrap process until sbcl-0.7.8.39.
@@ -401,26 +433,17 @@
 		    form)))
 	    'dmc-test-return))
 
-;;; DEFMETHOD should signal a PROGRAM-ERROR if an incompatible lambda
-;;; list is given:
+;;; DEFMETHOD should signal an ERROR if an incompatible lambda list is
+;;; given:
 (defmethod incompatible-ll-test-1 (x) x)
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-1 (x y) y))
-  (assert (null result))
-  (assert (typep error 'program-error)))
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-1 (x &rest y) y))
-  (assert (null result))
-  (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x y) y)))
+(assert (raises-error? (defmethod incompatible-ll-test-1 (x &rest y) y)))
 ;;; Sneakily using a bit of MOPness to check some consistency
 (assert (= (length
 	    (sb-pcl:generic-function-methods #'incompatible-ll-test-1)) 1))
 
 (defmethod incompatible-ll-test-2 (x &key bar) bar)
-(multiple-value-bind (result error)
-    (ignore-errors (defmethod incompatible-ll-test-2 (x) x))
-  (assert (null result))
-  (assert (typep error 'program-error)))
+(assert (raises-error? (defmethod incompatible-ll-test-2 (x) x)))
 (defmethod incompatible-ll-test-2 (x &rest y) y)
 (assert (= (length
 	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
@@ -569,7 +592,9 @@
 	    'slot-value))
 (assert (eq (funcall (lambda (x) (setf (slot-value x 'baz) 'baz))
 		     (make-instance 'class-with-all-slots-missing))
-	    'setf))
+	    ;; SLOT-MISSING's value is specified to be ignored; we
+	    ;; return NEW-VALUE.
+	    'baz))
 
 ;;; we should be able to specialize on anything that names a class.
 (defclass name-for-class () ())
@@ -580,5 +605,63 @@
 (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)))
+
+;;; 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))
+
+;;; 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)))
+
+;;; 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)))
+
 ;;;; success
 (sb-ext:quit :unix-status 104)