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 (load "assertoid.lisp")
  17
  18 (cl:defpackage "CLOS-1"
  19   (:use "CL" "ASSERTOID" "TEST-UTIL"))
  20 (cl:in-package "CLOS-1")
  21
  22 ;;; tests that various optimization paths for slot-valuish things
  23 ;;; respect class redefinitions.
  24 (defclass foo ()
  25   ((a :initarg :a)))
  26
  27 (defvar *foo* (make-instance 'foo :a 1))
  28
  29 (defmethod a-of ((x foo))
  30   (slot-value x 'a))
  31 (defmethod b-of ((x foo))
  32   (slot-value x 'b))
  33 (defmethod c-of ((x foo))
  34   (slot-value x 'c))
  35
  36 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  37   (dotimes (i 4)                        ; KLUDGE: get caches warm
  38     (assert (= 1 (slot-value *foo* 'a)))
  39     (assert (= 1 (a-of *foo*)))
  40     (assert (= 1 (funcall fun *foo*)))
  41     (assert-error (b-of *foo*))
  42     (assert-error (c-of *foo*))))
  43
  44 (defclass foo ()
  45   ((b :initarg :b :initform 3) (a :initarg :a)))
  46
  47 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  48   (dotimes (i 4)                        ; KLUDGE: get caches warm
  49     (assert (= 1 (slot-value *foo* 'a)))
  50     (assert (= 1 (a-of *foo*)))
  51     (assert (= 1 (funcall fun *foo*)))
  52     (assert (= 3 (b-of *foo*)))
  53     (assert-error (c-of *foo*))))
  54
  55 (defclass foo ()
  56   ((c :initarg :c :initform t :allocation :class)
  57    (b :initarg :b :initform 3)
  58    (a :initarg :a)))
  59
  60 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  61   (dotimes (i 4) ; KLUDGE: get caches warm
  62     (assert (= 1 (slot-value *foo* 'a)))
  63     (assert (= 1 (a-of *foo*)))
  64     (assert (= 1 (funcall fun *foo*)))
  65     (assert (= 3 (b-of *foo*)))
  66     (assert (eq t (c-of *foo*)))))
  67
  68 (defclass foo ()
  69   ((a :initarg :a)
  70    (b :initarg :b :initform 3)
  71    (c :initarg :c :initform t)))
  72
  73 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  74   (dotimes (i 4) ; KLUDGE: get caches warm
  75     (assert (= 1 (slot-value *foo* 'a)))
  76     (assert (= 1 (a-of *foo*)))
  77     (assert (= 1 (funcall fun *foo*)))
  78     (assert (= 3 (b-of *foo*)))
  79     (assert (eq t (c-of *foo*)))))
  80
  81 (defclass foo ()
  82   ((b :initarg :b :initform 3)))
  83
  84 (let ((fun (checked-compile '(lambda (x) (slot-value x 'a)))))
  85   (dotimes (i 4)                        ; KLUDGE: get caches warm
  86     (assert-error (slot-value *foo* 'a))
  87     (assert-error (a-of *foo*))
  88     (assert-error (funcall fun *foo*))
  89     (assert (= 3 (b-of *foo*)))
  90     (assert-error (c-of *foo*))))
  91
  92 ;;; test that :documentation argument to slot specifiers are used as
  93 ;;; the docstrings of accessor methods.
  94 (defclass foo ()
  95   ((a :reader a-of :documentation "docstring for A")
  96    (b :writer set-b-of :documentation "docstring for B")
  97    (c :accessor c :documentation  "docstring for C")))
  98
  99 (flet ((doc (fun)
 100          (documentation fun t)))
 101   (assert (string= (doc (find-method #'a-of nil '(foo))) "docstring for A"))
 102   (assert (string= (doc (find-method #'set-b-of nil '(t foo))) "docstring for B"))
 103   (assert (string= (doc (find-method #'c nil '(foo))) "docstring for C"))
 104   (assert (string= (doc (find-method #'(setf c) nil '(t foo))) "docstring for C")))
 105 \f
 106 ;;; some nasty tests of NO-NEXT-METHOD.
 107 (defvar *method-with-no-next-method*)
 108 (defvar *nnm-count* 0)
 109 (defun make-nnm-tester (x)
 110   (setq *method-with-no-next-method* (defmethod nnm-tester ((y (eql x))) (call-next-method))))
 111 (make-nnm-tester 1)
 112 (defmethod no-next-method ((gf (eql #'nnm-tester)) method &rest args)
 113   (declare (ignore args))
 114   (assert (eql method *method-with-no-next-method*))
 115   (incf *nnm-count*))
 116 (with-test (:name (no-next-method :unknown-specializer))
 117   (nnm-tester 1)
 118   (assert (= *nnm-count* 1)))
 119 (let ((gf #'nnm-tester))
 120   (reinitialize-instance gf :name 'new-nnm-tester)
 121   (setf (fdefinition 'new-nnm-tester) gf))
 122 (with-test (:name (no-next-method :gf-name-changed))
 123   (new-nnm-tester 1)
 124   (assert (= *nnm-count* 2)))
 125 \f
 126 ;;; Tests the compiler's incremental rejiggering of GF types.
 127 (fmakunbound 'foo)
 128 (with-test (:name :keywords-supplied-in-methods-ok-1)
 129   (defgeneric foo (x &key))
 130   (defmethod foo ((x integer) &key bar) (list x bar))
 131   (checked-compile '(lambda () (foo (read) :bar 10))))
 132
 133 (fmakunbound 'foo)
 134 (with-test (:name :keywords-supplied-in-methods-ok-2)
 135   (defgeneric foo (x &key))
 136   (defmethod foo ((x integer) &key bar) (list x bar))
 137   ;; On second thought...
 138   (remove-method #'foo (find-method #'foo () '(integer)))
 139   (multiple-value-bind  (fun failure-p warnings style-warnings)
 140       (checked-compile '(lambda () (foo (read) :bar 10))
 141                        :allow-style-warnings t)
 142     (declare (ignore fun failure-p warnings))
 143     (assert (= (length style-warnings) 1))))
 144
 145 ;; If the GF has &REST with no &KEY, not all methods are required to
 146 ;; parse the tail of the arglist as keywords, so we don't treat the
 147 ;; function type as having &KEY in it.
 148 (fmakunbound 'foo)
 149 (with-test (:name :gf-rest-method-key)
 150   (defgeneric foo (x &rest y))
 151   (defmethod foo ((i integer) &key w) (list i w))
 152   ;; 1.0.20.30 failed here.
 153   (checked-compile '(lambda () (foo 5 :w 10 :foo 15)))
 154   (assert
 155    (not (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))))
 156
 157 ;; If the GF has &KEY and &ALLOW-OTHER-KEYS, the methods' keys can be
 158 ;; anything, and we don't warn about unrecognized keys.
 159 (fmakunbound 'foo)
 160 (with-test (:name :gf-allow-other-keys)
 161   (defgeneric foo (x &key &allow-other-keys))
 162   (defmethod foo ((i integer) &key y z) (list i y z))
 163   ;; Correctness of a GF's ftype was previously ensured by the compiler,
 164   ;; and only if a lambda was compiled that referenced the GF, in a way
 165   ;; that was just barely non-broken enough to make the compiler happy.
 166   ;; Now the FTYPE is computed the instant anyone asks for it.
 167   (assert (equal (mapcar 'sb-kernel:key-info-name
 168                          (sb-kernel:fun-type-keywords
 169                           (sb-int:proclaimed-ftype 'foo)))
 170                  '(:y :z)))
 171   (checked-compile '(lambda () (foo 5 :z 10 :y 15)))
 172   (checked-compile '(lambda () (foo 5 :z 10 :foo 15)))
 173   (assert
 174    (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))
 175   (assert
 176    (sb-kernel::args-type-allowp (sb-int:proclaimed-ftype 'foo))))
 177
 178 ;; If any method has &ALLOW-OTHER-KEYS, 7.6.4 point 5 seems to say the
 179 ;; GF should be construed to have &ALLOW-OTHER-KEYS.
 180 (fmakunbound 'foo)
 181 (with-test (:name :method-allow-other-keys)
 182   (defgeneric foo (x &key))
 183   (defmethod foo ((x integer) &rest y &key &allow-other-keys) (list x y))
 184   (checked-compile '(lambda () (foo 10 :foo 20)))
 185   (assert (sb-kernel::args-type-keyp (sb-int:proclaimed-ftype 'foo)))
 186   (assert (sb-kernel::args-type-allowp (sb-int:proclaimed-ftype 'foo))))
 187
 188 (fmakunbound 'foo)
 189 (with-test (:name (defmethod symbol-macrolet))
 190   (symbol-macrolet ((cnm (call-next-method)))
 191     (defmethod foo ((x number)) (1+ cnm)))
 192   (defmethod foo ((x t)) 3)
 193   (assert (= (foo t) 3))
 194   (assert (= (foo 3) 4)))
 195
 196 (fmakunbound 'foo)
 197 (define-symbol-macro magic-cnm (call-next-method))
 198 (with-test (:name (defmethod define-symbol-macro))
 199   (defmethod foo ((x number)) (1- magic-cnm))
 200   (defmethod foo ((x t)) 3)
 201   (assert (= (foo t) 3))
 202   (assert (= (foo 3) 2)))