(assert (= 3 (b-of *foo*)))
(assert (raises-error? (c-of *foo*)))))
-;; test that :documentation argument to slot specifiers are used as
-;; the docstrings of accessor methods.
+;;; test that :documentation argument to slot specifiers are used as
+;;; the docstrings of accessor methods.
(defclass foo ()
((a :reader a-of :documentation "docstring for A")
(b :writer set-b-of :documentation "docstring for B")
(flet ((doc (fun)
(documentation fun t)))
- (assert (string= (doc (find-method #'a-of nil '((foo)))) "docstring for A"))
- (assert (string= (doc (find-method #'set-b-of nil '(t (foo)))) "docstring for B"))
- (assert (string= (doc (find-method #'c nil '((foo)))) "docstring for C"))
- (assert (string= (doc (find-method #'(setf c) nil '(t (foo)))) "docstring for C")))
+ (assert (string= (doc (find-method #'a-of nil '(foo))) "docstring for A"))
+ (assert (string= (doc (find-method #'set-b-of nil '(t foo))) "docstring for B"))
+ (assert (string= (doc (find-method #'c nil '(foo))) "docstring for C"))
+ (assert (string= (doc (find-method #'(setf c) nil '(t foo))) "docstring for C")))
+\f
+;;; some nasty tests of NO-NEXT-METHOD.
+(defvar *method-with-no-next-method*)
+(defvar *nnm-count* 0)
+(defun make-nnm-tester (x)
+ (setq *method-with-no-next-method* (defmethod nnm-tester ((y (eql x))) (call-next-method))))
+(make-nnm-tester 1)
+(defmethod no-next-method ((gf (eql #'nnm-tester)) method &rest args)
+ (assert (eql method *method-with-no-next-method*))
+ (incf *nnm-count*))
+(with-test (:name (no-next-method :unknown-specializer))
+ (nnm-tester 1)
+ (assert (= *nnm-count* 1)))
+(let ((gf #'nnm-tester))
+ (reinitialize-instance gf :name 'new-nnm-tester)
+ (setf (fdefinition 'new-nnm-tester) gf))
+(with-test (:name (no-next-method :gf-name-changed))
+ (new-nnm-tester 1)
+ (assert (= *nnm-count* 2)))
+\f
+;;; Tests the compiler's incremental rejiggering of GF types.
+(fmakunbound 'foo)
+(with-test (:name keywords-supplied-in-methods-ok-1)
+ (assert
+ (null
+ (nth-value
+ 1
+ (progn
+ (defgeneric foo (x &key))
+ (defmethod foo ((x integer) &key bar) (list x bar))
+ (compile nil '(lambda () (foo (read) :bar 10))))))))
+
+(fmakunbound 'foo)
+(with-test (:name keywords-supplied-in-methods-ok-2)
+ (assert
+ (nth-value
+ 1
+ (progn
+ (defgeneric foo (x &key))
+ (defmethod foo ((x integer) &key bar) (list x bar))
+ ;; On second thought...
+ (remove-method #'foo (find-method #'foo () '(integer)))
+ (compile nil '(lambda () (foo (read) :bar 10)))))))
+
+;; If the GF has &REST with no &KEY, not all methods are required to
+;; parse the tail of the arglist as keywords, so we don't treat the
+;; function type as having &KEY in it.
+(fmakunbound 'foo)
+(with-test (:name gf-rest-method-key)
+ (defgeneric foo (x &rest y))
+ (defmethod foo ((i integer) &key w) (list i w))
+ ;; 1.0.20.30 failed here.
+ (assert
+ (null (nth-value 1 (compile nil '(lambda () (foo 5 :w 10 :foo 15))))))
+ (assert
+ (not (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))))
+
+;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
+;; anything, and we don't warn about unrecognized keys.
+(fmakunbound 'foo)
+(with-test (:name gf-allow-other-keys)
+ (defgeneric foo (x &key &allow-other-keys))
+ (defmethod foo ((i integer) &key y z) (list i y z))
+ (assert
+ (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :y 15))))))
+ (assert
+ (null (nth-value 1 (compile nil '(lambda () (foo 5 :z 10 :foo 15))))))
+ (assert
+ (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
+ (assert
+ (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo))))
+
+;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
+;; GF should be construed to have &ALLOW-OTHER-KEYS.
+(fmakunbound 'foo)
+(with-test (:name method-allow-other-keys)
+ (defgeneric foo (x &key))
+ (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
+ (assert (null (nth-value 1 (compile nil '(lambda () (foo 10 :foo 20))))))
+ (assert (sb-kernel::args-type-keyp (sb-c::info :function :type 'foo)))
+ (assert (sb-kernel::args-type-allowp (sb-c::info :function :type 'foo))))
+
+