X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=bd46fa1bcfca293e99d8da45553895934530f0b0;hb=742e0b2aed0e06a5ac6036c6b576088e3f91208f;hp=b4462cd453cc355fe2d9f767338145eb19b93177;hpb=2fe7ca730f378505f86a7553462fa3241185d444;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b4462cd..bd46fa1 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -365,6 +365,84 @@
 	   k)
 
 (dmc-test-mc :k 1)
+;;; While I'm at it, DEFINE-METHOD-COMBINATION is defined to return
+;;; the NAME argument, not some random method object. So:
+(assert (eq (define-method-combination dmc-test-return-foo)
+	    'dmc-test-return-foo))
+(assert (eq (define-method-combination dmc-test-return-bar :operator and)
+	    'dmc-test-return-bar))
+(assert (eq (define-method-combination dmc-test-return
+		(&optional (order :most-specific-first))
+	      ((around (:around))
+	       (primary (dmc-test-return) :order order :required t))
+	      (let ((form (if (rest primary)
+			      `(and ,@(mapcar #'(lambda (method)
+						  `(call-method ,method))
+					      primary))
+			      `(call-method ,(first primary)))))
+		(if around
+		    `(call-method ,(first around)
+		      (,@(rest around)
+		       (make-method ,form)))
+		    form)))
+	    'dmc-test-return))
+
+;;; DEFMETHOD should signal a PROGRAM-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)))
+;;; 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)))
+(defmethod incompatible-ll-test-2 (x &rest y) y)
+(assert (= (length
+	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 1))
+(defmethod incompatible-ll-test-2 ((x integer) &key bar) bar)
+(assert (= (length
+	    (sb-pcl:generic-function-methods #'incompatible-ll-test-2)) 2))
+(assert (equal (incompatible-ll-test-2 t 1 2) '(1 2)))
+(assert (eq (incompatible-ll-test-2 1 :bar 'yes) 'yes))
+
+;;; Attempting to instantiate classes with forward references in their
+;;; CPL should signal errors (FIXME: of what type?)
+(defclass never-finished-class (this-one-unfinished-too) ())
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'never-finished-class))
+  (assert (null result))
+  (assert (typep error 'error)))
+(multiple-value-bind (result error)
+    (ignore-errors (make-instance 'this-one-unfinished-too))
+  (assert (null result))
+  (assert (typep error 'error)))
+
+;;; Classes with :ALLOCATION :CLASS slots should be subclassable (and
+;;; weren't for a while in sbcl-0.7.9.xx)
+(defclass superclass-with-slot ()
+  ((a :allocation :class)))
+(defclass subclass-for-class-allocation (superclass-with-slot) ())
+(make-instance 'subclass-for-class-allocation)
+
+;;; bug #136: CALL-NEXT-METHOD was being a little too lexical,
+;;; resulting in failure in the following:
+(defmethod call-next-method-lexical-args ((x integer))
+  x)
+(defmethod call-next-method-lexical-args :around ((x integer))
+  (let ((x (1+ x)))
+    (call-next-method)))
+(assert (= (call-next-method-lexical-args 3) 3))
 
 ;;;; success