0.7.9.49:

[sbcl.git] / tests / clos.impure.lisp

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index b4462cd..bd46fa1 100644 (file)
--- 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))
+\f
+;;; 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))
+\f
+;;; 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)))
+\f
+;;; 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)
+\f
+;;; 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))
 \f
 ;;;; success