X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=91eab018bc1ab08d224c89e4fd4295ec259f58ef;hb=f16e93459cd73b1884e3d576c95e422f8e8a000e;hp=46a36a8ba82e094a6645a9cd53e972e986680fab;hpb=d8e47f8f2ccda542b1ab60b080ebed483ae14376;p=sbcl.git

diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 46a36a8..91eab01 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,8 +11,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "compiler-test-util.lisp")
 (defpackage "CLOS-IMPURE"
-  (:use "CL" "ASSERTOID" "TEST-UTIL"))
+  (:use "CL" "ASSERTOID" "TEST-UTIL" "COMPILER-TEST-UTIL"))
 (in-package "CLOS-IMPURE")
 
 ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
@@ -71,6 +72,15 @@
 (assert (expect-error (defgeneric foo5 (x &rest))))
 (assert (expect-error (defmethod foo6 (x &rest))))
 
+;;; legal method specializers
+(defclass bug-525916-1 () ())
+(defclass bug-525916-2 () ())
+(with-test (:name :bug-525916)
+(assert (expect-error (defmethod invalid ((arg)) arg)))
+(assert (expect-error (defmethod invalid (nil) 1)))
+(assert (expect-error (defmethod invalid ((arg . bug-525916-1)) arg)))
+(assert (expect-error (defmethod invalid ((arg bug-525916-1 bug-525916-2)) arg))))
+
 ;;; more lambda-list checking
 ;;;
 ;;; DEFGENERIC lambda lists are subject to various limitations, as per
@@ -1777,4 +1787,51 @@
     bug-485019)
   (bug-485019 (make-instance 'bug-485019)))
 
+;;; The compiler didn't propagate the declarared type before applying
+;;; the transform for (SETF SLOT-VALUE), so the generic accessor was used.
+(defstruct foo-520366
+  slot)
+(defun quux-520366 (cont)
+  (funcall cont))
+(defun bar-520366 (foo-struct)
+  (declare (type foo-520366 foo-struct))
+  (with-slots (slot) foo-struct
+    (tagbody
+       (quux-520366 #'(lambda ()
+                        (setf slot :value)
+                        (go TAG)))
+     TAG)))
+(with-test (:name :bug-520366)
+  (let ((callees (find-named-callees #'bar-520366)))
+    (assert (equal (list #'quux-520366) callees))))
+
+(defgeneric no-applicable-method/retry (x))
+(defmethod no-applicable-method/retry ((x string))
+  "string")
+(with-test (:name :no-applicable-method/retry)
+  (assert (equal "cons"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-applicable-method/retry ((x cons))
+                                                "cons"))
+                                       (invoke-restart r))))))
+                   (no-applicable-method/retry (cons t t))))))
+
+(defgeneric no-primary-method/retry (x))
+(defmethod no-primary-method/retry :before (x) (assert x))
+(with-test (:name :no-primary-method/retry)
+  (assert (equal "ok!"
+                 (handler-bind ((error
+                                 (lambda (c)
+                                   (declare (ignore c))
+                                   (let ((r (find-restart 'sb-pcl::retry)))
+                                     (when r
+                                       (eval `(defmethod no-primary-method/retry (x)
+                                                "ok!"))
+                                       (invoke-restart r))))))
+                   (no-primary-method/retry (cons t t))))))
+
 ;;;; success