;;;; 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")
\f
;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
(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
(shared-initialize x '(a))
(assert (slot-boundp x 'a))
(assert (eq :ok (slot-value x 'a)))))
+
+(declaim (ftype (function (t t t) (values single-float &optional))
+ i-dont-want-to-be-clobbered-1
+ i-dont-want-to-be-clobbered-2))
+(defgeneric i-dont-want-to-be-clobbered-1 (t t t))
+(defmethod i-dont-want-to-be-clobbered-2 ((x cons) y z)
+ y)
+(defun i-cause-an-gf-info-update ()
+ (i-dont-want-to-be-clobbered-2 t t t))
+(with-test (:name :defgeneric-should-clobber-ftype)
+ ;; (because it doesn't check the argument or result types)
+ (assert (equal '(function (t t t) *)
+ (sb-kernel:type-specifier
+ (sb-int:info :function
+ :type 'i-dont-want-to-be-clobbered-1))))
+ (assert (equal '(function (t t t) *)
+ (sb-kernel:type-specifier
+ (sb-int:info :function
+ :type 'i-dont-want-to-be-clobbered-2))))
+ (assert (eq :defined-method
+ (sb-int:info :function
+ :where-from 'i-dont-want-to-be-clobbered-1)))
+ (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))))
\f
+(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) callees))))
+
;;;; success