;;; 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)
(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)))))
+
+(with-test (:name :bug-1001799)
+ ;; compilation of the defmethod used to cause infinite recursion
+ (let ((pax (gensym "PAX"))
+ (pnr (gensym "PNR"))
+ (sup (gensym "SUP"))
+ (frob (gensym "FROB"))
+ (sb-ext:*evaluator-mode* :compile))
+ (eval
+ `(progn
+ (declaim (optimize (speed 1) (space 1) (safety 3) (debug 3) (compilation-speed 1)))
+ (defclass ,pax (,sup)
+ ((,pnr :type (or null ,pnr))))
+ (defclass ,pnr (,sup)
+ ((,pax :type (or null ,pax))))
+ (defclass ,sup ()
+ ())
+ (defmethod ,frob ((pnr ,pnr))
+ (slot-value pnr ',pax))))))
+
;;;; success