;;; DOCUMENTATION's argument-precedence-order wasn't being faithfully
;;; preserved through the bootstrap process until sbcl-0.7.8.39.
;;; (thanks to Gerd Moellmann)
-(let ((answer (documentation '+ 'function)))
- (assert (stringp answer))
- (defmethod documentation ((x (eql '+)) y) "WRONG")
- (assert (string= (documentation '+ 'function) answer)))
+(with-test (:name :documentation-argument-precedence-order)
+ (defun foo022 ()
+ "Documentation"
+ t)
+ (let ((answer (documentation 'foo022 'function)))
+ (assert (stringp answer))
+ (defmethod documentation ((x (eql 'foo022)) y) "WRONG")
+ (assert (string= (documentation 'foo022 'function) answer))))
\f
;;; only certain declarations are permitted in DEFGENERIC
(macrolet ((assert-program-error (form)
(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)
(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))))
+
+(defgeneric generic-function-pretty-arglist-optional-and-key (req &optional opt &key key)
+ (:method (req &optional opt &key key)
+ (list req opt key)))
+
+(with-test (:name :generic-function-pretty-arglist-optional-and-key)
+ (handler-bind ((warning #'error))
+ ;; Used to signal a style-warning
+ (assert (equal '(req &optional opt &key key)
+ (sb-pcl::generic-function-pretty-arglist
+ #'generic-function-pretty-arglist-optional-and-key)))))
+
+(with-test (:name :bug-894202)
+ (assert (eq :good
+ (handler-case
+ (let ((name (gensym "FOO"))
+ (decl (gensym "BAR")))
+ (eval `(defgeneric ,name ()
+ (declare (,decl)))))
+ (warning ()
+ :good)))))
+
+(with-test (:name :bug-898331)
+ (handler-bind ((warning #'error))
+ (eval `(defgeneric bug-898331 (request type remaining-segment-requests all-requests)))
+ (eval `(defmethod bug-898331 ((request cons) (type (eql :cancel))
+ remaining-segment-requests
+ all-segment-requests)
+ (declare (ignore all-segment-requests))
+ (check-type request t)))))
+
;;;; success