tests/clos-1.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of CLOS
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; clos.impure.lisp was getting too big and confusing
  15
  16 ;;; tests that various optimization paths for slot-valuish things
  17 ;;; respect class redefinitions.
  18 (defclass foo ()
  19   ((a :initarg :a)))
  20
  21 (defvar *foo* (make-instance 'foo :a 1))
  22
  23 (defmethod a-of ((x foo))
  24   (slot-value x 'a))
  25 (defmethod b-of ((x foo))
  26   (slot-value x 'b))
  27 (defmethod c-of ((x foo))
  28   (slot-value x 'c))
  29
  30 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  31   (dotimes (i 4)                        ; KLUDGE: get caches warm
  32     (assert (= 1 (slot-value *foo* 'a)))
  33     (assert (= 1 (a-of *foo*)))
  34     (assert (= 1 (funcall fun *foo*)))
  35     (assert-error (b-of *foo*))
  36     (assert-error (c-of *foo*))))
  37
  38 (defclass foo ()
  39   ((b :initarg :b :initform 3) (a :initarg :a)))
  40
  41 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  42   (dotimes (i 4)                        ; KLUDGE: get caches warm
  43     (assert (= 1 (slot-value *foo* 'a)))
  44     (assert (= 1 (a-of *foo*)))
  45     (assert (= 1 (funcall fun *foo*)))
  46     (assert (= 3 (b-of *foo*)))
  47     (assert-error (c-of *foo*))))
  48
  49 (defclass foo ()
  50   ((c :initarg :c :initform t :allocation :class)
  51    (b :initarg :b :initform 3)
  52    (a :initarg :a)))
  53
  54 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  55   (dotimes (i 4) ; KLUDGE: get caches warm
  56     (assert (= 1 (slot-value *foo* 'a)))
  57     (assert (= 1 (a-of *foo*)))
  58     (assert (= 1 (funcall fun *foo*)))
  59     (assert (= 3 (b-of *foo*)))
  60     (assert (eq t (c-of *foo*)))))
  61
  62 (defclass foo ()
  63   ((a :initarg :a)
  64    (b :initarg :b :initform 3)
  65    (c :initarg :c :initform t)))
  66
  67 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  68   (dotimes (i 4) ; KLUDGE: get caches warm
  69     (assert (= 1 (slot-value *foo* 'a)))
  70     (assert (= 1 (a-of *foo*)))
  71     (assert (= 1 (funcall fun *foo*)))
  72     (assert (= 3 (b-of *foo*)))
  73     (assert (eq t (c-of *foo*)))))
  74
  75 (defclass foo ()
  76   ((b :initarg :b :initform 3)))
  77
  78 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  79   (dotimes (i 4)                        ; KLUDGE: get caches warm
  80     (assert-error (slot-value *foo* 'a))
  81     (assert-error (a-of *foo*))
  82     (assert-error (funcall fun *foo*))
  83     (assert (= 3 (b-of *foo*)))
  84     (assert-error (c-of *foo*))))
  85
  86 ;;; test that :documentation argument to slot specifiers are used as
  87 ;;; the docstrings of accessor methods.
  88 (defclass foo ()
  89   ((a :reader a-of :documentation "docstring for A")
  90    (b :writer set-b-of :documentation "docstring for B")
  91    (c :accessor c :documentation  "docstring for C")))
  92
  93 (flet ((doc (fun)
  94          (documentation fun t)))
  95   (assert (string= (doc (find-method #'a-of nil '(foo))) "docstring for A"))
  96   (assert (string= (doc (find-method #'set-b-of nil '(t foo))) "docstring for B"))
  97   (assert (string= (doc (find-method #'c nil '(foo))) "docstring for C"))
  98   (assert (string= (doc (find-method #'(setf c) nil '(t foo))) "docstring for C")))
  99 \f
 100 ;;; some nasty tests of NO-NEXT-METHOD.
 101 (defvar *method-with-no-next-method*)
 102 (defvar *nnm-count* 0)
 103 (defun make-nnm-tester (x)
 104   (setq *method-with-no-next-method* (defmethod nnm-tester ((y (eql x))) (call-next-method))))
 105 (make-nnm-tester 1)
 106 (defmethod no-next-method ((gf (eql #'nnm-tester)) method &rest args)
 107   (declare (ignore args))
 108   (assert (eql method *method-with-no-next-method*))
 109   (incf *nnm-count*))
 110 (with-test (:name (no-next-method :unknown-specializer))
 111   (nnm-tester 1)
 112   (assert (= *nnm-count* 1)))
 113 (let ((gf #'nnm-tester))
 114   (reinitialize-instance gf :name 'new-nnm-tester)
 115   (setf (fdefinition 'new-nnm-tester) gf))
 116 (with-test (:name (no-next-method :gf-name-changed))
 117   (new-nnm-tester 1)
 118   (assert (= *nnm-count* 2)))
 119 \f
 120 ;;; Tests the compiler's incremental rejiggering of GF types.
 121 (fmakunbound 'foo)
 122 (with-test (:name :keywords-supplied-in-methods-ok-1)
 123   (defgeneric foo (x &key))
 124   (defmethod foo ((x integer) &key bar) (list x bar))
 125   (checked-compile '(lambda () (foo (read) :bar 10))))
 126
 127 (fmakunbound 'foo)
 128 (with-test (:name :keywords-supplied-in-methods-ok-2)
 129   (defgeneric foo (x &key))
 130   (defmethod foo ((x integer) &key bar) (list x bar))
 131   ;; On second thought...
 132   (remove-method #'foo (find-method #'foo () '(integer)))
 133   (multiple-value-bind  (fun failure-p warnings style-warnings)
 134       (checked-compile '(lambda () (foo (read) :bar 10))
 135                        :allow-style-warnings t)
 136     (declare (ignore fun failure-p warnings))
 137     (assert (= (length style-warnings) 1))))
 138
 139 ;; If the GF has &REST with no &KEY, not all methods are required to
 140 ;; parse the tail of the arglist as keywords, so we don't treat the
 141 ;; function type as having &KEY in it.
 142 (fmakunbound 'foo)
 143 (with-test (:name :gf-rest-method-key)
 144   (defgeneric foo (x &rest y))
 145   (defmethod foo ((i integer) &key w) (list i w))
 146   ;; 1.0.20.30 failed here.
 147   (checked-compile '(lambda () (foo 5 :w 10 :foo 15)))
 148   (assert
 149    (not (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))))
 150
 151 ;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
 152 ;; anything, and we don't warn about unrecognized keys.
 153 (fmakunbound 'foo)
 154 (with-test (:name :gf-allow-other-keys)
 155   (defgeneric foo (x &key &allow-other-keys))
 156   (defmethod foo ((i integer) &key y z) (list i y z))
 157   ;; Correctness of a GF's ftype was previously ensured by the compiler,
 158   ;; and only if a lambda was compiled that referenced the GF, in a way
 159   ;; that was just barely non-broken enough to make the compiler happy.
 160   ;; Now the FTYPE is computed the instant anyone asks for it.
 161   (assert (equal (mapcar 'sb-kernel:key-info-name
 162                          (sb-kernel:fun-type-keywords
 163                           (sb-int:global-ftype 'foo)))
 164                  '(:y :z)))
 165   (checked-compile '(lambda () (foo 5 :z 10 :y 15)))
 166   (checked-compile '(lambda () (foo 5 :z 10 :foo 15)))
 167   (assert
 168    (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))
 169   (assert
 170    (sb-kernel::args-type-allowp (sb-int:global-ftype 'foo))))
 171
 172 ;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
 173 ;; GF should be construed to have &ALLOW-OTHER-KEYS.
 174 (fmakunbound 'foo)
 175 (with-test (:name :method-allow-other-keys)
 176   (defgeneric foo (x &key))
 177   (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
 178   (checked-compile '(lambda () (foo 10 :foo 20)))
 179   (assert (sb-kernel::args-type-keyp (sb-int:global-ftype 'foo)))
 180   (assert (sb-kernel::args-type-allowp (sb-int:global-ftype 'foo))))
 181
 182 (fmakunbound 'foo)
 183 (with-test (:name (defmethod symbol-macrolet))
 184   (symbol-macrolet ((cnm (call-next-method)))
 185     (defmethod foo ((x number)) (1+ cnm)))
 186   (defmethod foo ((x t)) 3)
 187   (assert (= (foo t) 3))
 188   (assert (= (foo 3) 4)))
 189
 190 (fmakunbound 'foo)
 191 (define-symbol-macro magic-cnm (call-next-method))
 192 (with-test (:name (defmethod define-symbol-macro))
 193   (defmethod foo ((x number)) (1- magic-cnm))
 194   (defmethod foo ((x t)) 3)
 195   (assert (= (foo t) 3))
 196   (assert (= (foo 3) 2)))
 197
 198 (with-test (:name :bug-309084-a-i)
 199   (assert-error (eval '(define-method-combination bug-309084-a-i :documentation :operator))
 200                 program-error))
 201 (with-test (:name :bug-309084-a-ii)
 202   (assert-error (eval '(define-method-combination bug-309084-a-ii :documentation nil))
 203                 program-error))
 204 (with-test (:name :bug-309084-a-iii)
 205   (assert-error (eval '(define-method-combination bug-309084-a-iii nil))
 206                 program-error))
 207 (with-test (:name :bug-309084-a-vi)
 208   (assert-error (eval '(define-method-combination bug-309084-a-vi nil nil
 209                         (:generic-function)))
 210                 program-error))
 211 (with-test (:name :bug-309084-a-vii)
 212   (assert-error (eval '(define-method-combination bug-309084-a-vii nil nil
 213                         (:generic-function bar baz)))
 214                 program-error))
 215 (with-test (:name :bug-309084-a-viii)
 216   (assert-error (eval '(define-method-combination bug-309084-a-viii nil nil
 217                         (:generic-function (bar))))
 218                 program-error))
 219 (with-test (:name :bug-309084-a-ix)
 220   (assert-error (eval '(define-method-combination bug-309084-a-ix nil ((3))))
 221                 program-error))
 222 (with-test (:name :bug-309084-a-x)
 223   (assert-error (eval '(define-method-combination bug-309084-a-x nil ((a))))
 224                 program-error))
 225 (with-test (:name :bug-309084-a-iv)
 226   (assert-error (eval '(define-method-combination bug-309084-a-iv nil nil
 227                         (:arguments order &aux &key)))
 228                 program-error))
 229 (with-test (:name :bug-309084-a-v)
 230   (assert-error (eval '(define-method-combination bug-309084-a-v nil nil
 231                         (:arguments &whole)))
 232                 program-error))
 233
 234 (let (warnings)
 235   (handler-bind ((warning (lambda (c) (push c warnings))))
 236     (eval '(define-method-combination bug-309084-b/mc nil
 237              ((all *))
 238              (:arguments x &optional (y 'a yp) &key (z 'b zp) &aux (w (list y z)))
 239              `(list ,x ,y ,yp ,z ,zp ,w)))
 240     ;; Should not get any "assigned but never read" warnings.
 241     (assert (= (length warnings) 1))
 242     (assert (search "&OPTIONAL and &KEY" (princ-to-string (car warnings))))))
 243
 244 (defgeneric bug-309084-b/gf (a &optional b &key &allow-other-keys)
 245   (:method-combination bug-309084-b/mc)
 246   (:method (m &optional n &key) (list m n)))
 247
 248 (with-test (:name :bug-309084-b)
 249   (assert (equal (bug-309084-b/gf 1) '(1 a nil b nil (a b))))
 250   (assert (equal (bug-309084-b/gf 1 2) '(1 2 t b nil (2 b))))
 251   (assert (equal (bug-309084-b/gf 1 2 :z 3) '(1 2 t 3 t (2 3)))))
 252
 253 (defgeneric bug-309084-b/gf2 (a b &optional c d &key &allow-other-keys)
 254   (:method-combination bug-309084-b/mc)
 255   (:method (m n &optional o p &key) (list m n o p)))
 256
 257 (with-test (:name :bug-309084-b2)
 258   (assert (equal (bug-309084-b/gf2 1 2) '(1 a nil b nil (a b))))
 259   (assert (equal (bug-309084-b/gf2 1 2 3) '(1 3 t b nil (3 b))))
 260   (assert (equal (bug-309084-b/gf2 1 2 3 4) '(1 3 t b nil (3 b))))
 261   (assert (equal (bug-309084-b/gf2 1 2 :z t) '(1 :z t b nil (:z b))))
 262   (assert (equal (bug-309084-b/gf2 1 2 3 4 :z 5) '(1 3 t 5 t (3 5)))))
 263
 264 (defmethod bug-1840595-a (x y))
 265 (defmethod bug-1840595-z (x))
 266
 267 (with-test (:name :bug-1840595/reader)
 268   (eval '(defclass bug-1840595r () ()))
 269   (assert-error (eval '(defclass bug-1840595r () ((a :reader bug-1840595-a)))))
 270   (eval '(defclass bug-1840595r () ())))
 271
 272 (with-test (:name :bug-1840595/writer)
 273   (eval '(defclass bug-1840595w () ()))
 274   (assert-error (eval '(defclass bug-1840595w () ((z :writer bug-1840595-z)))))
 275   (eval '(defclass bug-1840595w () ())))
 276
 277 (with-test (:name :bug-1909659/reader)
 278   (eval '(defclass bug-1909659r () ((name :initarg :name :reader bug-1909659r-name))))
 279   (let ((one (make-instance 'bug-1909659r :name 1))
 280         (two (make-instance 'bug-1909659r :name 2)))
 281     (assert-error (bug-1909659r-name one two) program-error)
 282     (assert (eql (bug-1909659r-name one) 1))
 283     (assert (eql (bug-1909659r-name two) 2))))
 284
 285 (with-test (:name :bug-1909659/writer)
 286   (eval '(defclass bug-1909659w () ((name :initarg :name :writer bug-1909659w-set-name))))
 287   (let ((one (make-instance 'bug-1909659w :name 1))
 288         (two (make-instance 'bug-1909659w :name 2)))
 289     (assert-error (bug-1909659w-set-name one) program-error)
 290     (assert-error (bug-1909659w-set-name two) program-error)
 291     (bug-1909659w-set-name one two)
 292     (assert (eql (slot-value one 'name) 1))
 293     (assert (eql (slot-value two 'name) one))))
 294
 295 (with-test (:name :defmethod-self-call-arg-mismatch
 296             :skipped-on :interpreter)
 297   (assert-signal (eval '(defmethod method-self-call (a b &key)
 298                          b
 299                          (method-self-call a)))
 300       (and warning
 301            (not sb-kernel:redefinition-warning)))
 302   (assert-no-signal (eval '(defmethod method-self-call (a b &key z)
 303                             (method-self-call a b :z z)))
 304       (and warning
 305            (not sb-kernel:redefinition-warning)))
 306   (assert-signal (eval '(defmethod method-self-call (a b &key j)
 307                          j
 308                          (method-self-call a b :z j)))
 309       (and warning
 310            (not sb-kernel:redefinition-warning)))
 311   (eval '(defmethod method-self-call (a (b list) &key z)
 312           (list a b z)))
 313
 314   (assert-no-signal (eval '(defmethod method-self-call (a b &key j)
 315                             j
 316                             (method-self-call a b :z j :j 10)))
 317       (and warning
 318            (not sb-kernel:redefinition-warning))))
 319
 320 (define-method-combination qualifier-pattern-element-wild ()
 321   ((qpew (:qpew *)))
 322   `(1+ (call-method ,(first qpew))))
 323
 324 (defgeneric qualifier-pattern-element-wild-fun (x)
 325   (:method-combination qualifier-pattern-element-wild)
 326   (:method :qpew * ((x integer)) x)
 327   (:method :qpew t ((x ratio)) x)
 328   (:method :qpew 1 2 ((x symbol)) 3))
 329
 330 (with-test (:name :method-combination-qualfier-pattern-element-wild)
 331   (assert (= (qualifier-pattern-element-wild-fun 1) 2))
 332   (assert (= (qualifier-pattern-element-wild-fun 1/2) 3/2))
 333   (assert-error (qualifier-pattern-element-wild-fun t)))
 334
 335 (define-method-combination method-combination-arguments-whole ()
 336   ((methods *))
 337   (:arguments &whole args)
 338   (:generic-function gf)
 339   `(list* ,gf ,args))
 340
 341 (defgeneric method-combination-arguments-whole-fun (a &key key-1)
 342   (:method-combination method-combination-arguments-whole)
 343   (:method (a &key key-1 key-2)
 344     (declare (ignore a key-1 key-2))))
 345
 346 (with-test (:name :method-combination-arguments-whole)
 347   (assert (equal (method-combination-arguments-whole-fun 1 :key-1 2)
 348                  (list #'method-combination-arguments-whole-fun 1 :key-1 2)))
 349   (assert (equal (method-combination-arguments-whole-fun 1)
 350                  (list #'method-combination-arguments-whole-fun 1))))
 351
 352 (defconstant order-one 'order-two)
 353 (defconstant order-two :most-specific-last)
 354
 355 (define-method-combination dont-overevaluate ()
 356   ((group * :order order-one))
 357   `(call-method ,(first group)))
 358
 359 (with-test (:name :method-combination-dont-overevaluate)
 360   (defgeneric dont-overevaluate-gf (x)
 361     (:method-combination dont-overevaluate)
 362     (:method ((x t)) x))
 363   (assert-error (dont-overevaluate-gf 1)))
 364
 365 ;;; An example (non-normative) from the Standard, which we interpret
 366 ;;; as failing the requirement not to have multiple methods with the
 367 ;;; same specializers in the same method group.
 368
 369 (defun positive-integer-qualifier-p (method-qualifiers)
 370   (and (= (length method-qualifiers) 1)
 371        (typep (first method-qualifiers) '(integer 0 *))))
 372
 373 (define-method-combination example-method-combination ()
 374   ((methods positive-integer-qualifier-p))
 375   `(progn ,@(mapcar #'(lambda (method)
 376                         `(call-method ,method))
 377                     (stable-sort methods #'<
 378                                  :key #'(lambda (method)
 379                                           (first (method-qualifiers method)))))))
 380
 381 (defgeneric example-method-combination-gf (x s)
 382   (:method-combination example-method-combination)
 383   (:method 1 (x (s stream)) (format s "~&1: ~A~%" x))
 384   (:method 2 (x (s stream)) (format s "~&2: ~A~%" x)))
 385
 386 (with-test (:name :clhs-example-method-combination-no-order)
 387   (assert-error (example-method-combination-gf 1 (make-broadcast-stream))))
 388
 389 ;;; The same example as above, modified to declare (using a
 390 ;;; non-standard extension) that the order it receives methods in the
 391 ;;; group does not matter.
 392
 393 (define-method-combination example-method-combination-order-nil ()
 394   ((methods positive-integer-qualifier-p :order nil))
 395   `(progn ,@(mapcar #'(lambda (method)
 396                         `(call-method ,method))
 397                     (stable-sort methods #'<
 398                                  :key #'(lambda (method)
 399                                           (first (method-qualifiers method)))))))
 400
 401 (defgeneric example-method-combination-order-nil-gf (x s)
 402   (:method-combination example-method-combination-order-nil)
 403   (:method 1 (x (s stream)) (format s "1: ~A and " x))
 404   (:method 2 (x (s stream)) (format s "2: ~A" x)))
 405
 406 (with-test (:name :clhs-example-method-combination-order-nil)
 407   (let ((string (with-output-to-string (s)
 408                   (example-method-combination-order-nil-gf t s))))
 409     (assert (string= string "1: T and 2: T"))))