X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=56fb8c374a5370f9c7dcc4ce650799528535b67b;hb=0a15b6bbf9d5d3a64b5ac08bb96b6e5ec221d2ae;hp=46a36a8ba82e094a6645a9cd53e972e986680fab;hpb=d8e47f8f2ccda542b1ab60b080ebed483ae14376;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 46a36a8..56fb8c3 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 @@ -1102,7 +1112,9 @@ (assert (= (method-on-defined-type-and-class 3) 4))))) ;; bug 281 -(let ((sb-pcl::*max-emf-precomputation-methods* 0)) +(let (#+nil ; no more sb-pcl::*max-emf-precomputation-methods* as of + ; sbcl-1.0.41.x + (sb-pcl::*max-emf-precomputation-methods* 0)) (eval '(defgeneric bug-281 (x) (:method-combination +) (:method ((x symbol)) 1) @@ -1777,4 +1789,103 @@ 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)))))) + +;;; test that a cacheing strategy for make-instance initargs checking +;;; can handle class redefinitions +(defclass cacheing-initargs-redefinitions-check () + ((slot :initarg :slot))) +(defun cacheing-initargs-redefinitions-check-fun (&optional (initarg :slot)) + (declare (notinline make-instance)) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check initarg 3)) +(with-test (:name :make-instance-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot 3) + (cacheing-initargs-redefinitions-check-fun :slot) + (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot2)))) +(defclass cacheing-initargs-redefinitions-check () + ((slot :initarg :slot2))) +(with-test (:name :make-instance-redefined-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot2 3) + (cacheing-initargs-redefinitions-check-fun :slot2) + (assert (raises-error? (cacheing-initargs-redefinitions-check-fun :slot)))) +(defmethod initialize-instance :after ((class cacheing-initargs-redefinitions-check) &key slot) + nil) +(with-test (:name :make-instance-new-method-initargs) + (make-instance 'cacheing-initargs-redefinitions-check) + (make-instance 'cacheing-initargs-redefinitions-check :slot2 3) + (cacheing-initargs-redefinitions-check-fun :slot2) + (let ((thing (cacheing-initargs-redefinitions-check-fun :slot))) + (assert (not (slot-boundp thing 'slot))))) + +(with-test (:name :defmethod-specializer-builtin-class-alias) + (let ((alias (gensym))) + (setf (find-class alias) (find-class 'symbol)) + (eval `(defmethod lp-618387 ((s ,alias)) + (symbol-name s))) + (assert (equal "FOO" (funcall 'lp-618387 :foo))))) + +(with-test (:name :pcl-spurious-ignore-warnings) + (defgeneric no-spurious-ignore-warnings (req &key key)) + (handler-bind ((warning (lambda (x) (error "~A" x)))) + (eval + '(defmethod no-spurious-ignore-warnings ((req number) &key key) + (declare (ignore key)) + (check-type req integer)))) + (defgeneric should-get-an-ignore-warning (req &key key)) + (let ((warnings 0)) + (handler-bind ((warning (lambda (c) (setq warnings 1) (muffle-warning c)))) + (eval '(defmethod should-get-an-ignore-warning ((req integer) &key key) + (check-type req integer)))) + (assert (= warnings 1)))) + + + ;;;; success