X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fclos.impure.lisp;h=ec9dffcb10006840dd63b2d5904cac567ff635d1;hb=829d76d5f12e1c1b6b21ca4c71b34719b8fed5e1;hp=4b0f1db2a23554fa3749f31974f3e96472048dfe;hpb=091c101153942c9452a05ce0ec72f31a22608d9f;p=sbcl.git diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 4b0f1db..ec9dffc 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) @@ -1743,5 +1755,121 @@ (assert (eq :defined-method (sb-int:info :function :where-from 'i-dont-want-to-be-clobbered-2)))) + +(with-test (:name :bogus-parameter-specializer-name-error) + (assert (eq :ok + (handler-case + (eval `(defmethod #:fii ((x "a string")) 'string)) + (sb-int:reference-condition (c) + (when (member '(:ansi-cl :macro defmethod) + (sb-int:reference-condition-references c) + :test #'equal) + :ok)))))) + +(defclass remove-default-initargs-test () + ((x :initarg :x :initform 42))) +(defclass remove-default-initatgs-test () + ((x :initarg :x :initform 42)) + (:default-initargs :x 0)) +(defclass remove-default-initargs-test () + ((x :initarg :x :initform 42))) +(with-test (:name :remove-default-initargs) + (assert (= 42 (slot-value (make-instance 'remove-default-initargs-test) + 'x)))) + +(with-test (:name :bug-485019) + ;; there was a bug in WALK-SETQ, used in method body walking, in the + ;; presence of declarations on symbol macros. + (defclass bug-485019 () + ((array :initarg :array))) + (defmethod bug-485019 ((bug-485019 bug-485019)) + (with-slots (array) bug-485019 + (declare (type (or null simple-array) array)) + (setf array (make-array 4))) + 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))))) + ;;;; success