tests/clos-typechecking.impure.lisp

   1 ;;;; This file is for testing typechecking of writes to CLOS object slots
   2 ;;;; for code compiled with a (SAFETY 3) optimization policy.
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; While most of SBCL is derived from the CMU CL system, the test
   8 ;;;; files (like this one) were written from scratch after the fork
   9 ;;;; from CMU CL.
  10 ;;;;
  11 ;;;; This software is in the public domain and is provided with
  12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  13 ;;;; more information.
  14
  15 ;;; Typechecking should be working, but it isn't.
  16 #+interpreter (sb-ext:exit :code 104)
  17
  18 (shadow 'slot)
  19
  20 (declaim (optimize safety))
  21
  22 (defclass foo ()
  23   ((slot :initarg :slot :type fixnum :accessor slot)))
  24 (defclass foo/gf (sb-mop:standard-generic-function)
  25   ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
  26   (:metaclass sb-mop:funcallable-standard-class))
  27 (defmethod succeed/sv ((x foo))
  28   (setf (slot-value x 'slot) 1))
  29 (defmethod fail/sv ((x foo))
  30   (setf (slot-value x 'slot) t))
  31 (defmethod succeed/acc ((x foo))
  32   (setf (slot x) 1))
  33 (defmethod fail/acc ((x foo))
  34   (setf (slot x) t))
  35 (defmethod succeed/sv/gf ((x foo/gf))
  36   (setf (slot-value x 'slot/gf) 1))
  37 (defmethod fail/sv/gf ((x foo/gf))
  38   (setf (slot-value x 'slot/gf) t))
  39 (defmethod succeed/acc/gf ((x foo/gf))
  40   (setf (slot/gf x) 1))
  41 (defmethod fail/acc/gf ((x foo/gf))
  42   (setf (slot/gf x) t))
  43 (defvar *t* t)
  44 (defvar *one* 1)
  45
  46 ;; evaluator
  47 (with-test (:name (:evaluator))
  48   (eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
  49   (assert-error (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
  50                 type-error)
  51   (eval '(setf (slot (make-instance 'foo)) 1))
  52   (assert-error (eval '(setf (slot (make-instance 'foo)) t))
  53                 type-error)
  54   (eval '(succeed/sv (make-instance 'foo)))
  55   (assert-error (eval '(fail/sv (make-instance 'foo)))
  56                 type-error)
  57   (eval '(succeed/acc (make-instance 'foo)))
  58   (assert-error (eval '(fail/acc (make-instance 'foo)))
  59                 type-error)
  60   (eval '(make-instance 'foo :slot 1))
  61   (assert-error (eval '(make-instance 'foo :slot t))
  62                 type-error)
  63   (eval '(make-instance 'foo :slot *one*))
  64   (assert-error (eval '(make-instance 'foo :slot *t*))
  65                 type-error))
  66 ;; evaluator/gf
  67 (with-test (:name (:evaluator/gf))
  68   (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
  69   (assert-error
  70    (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
  71    type-error)
  72   (eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
  73   (assert-error (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
  74                 type-error)
  75   (eval '(succeed/sv/gf (make-instance 'foo/gf)))
  76   (assert-error (eval '(fail/sv/gf (make-instance 'foo/gf)))
  77                 type-error)
  78   (eval '(succeed/acc/gf (make-instance 'foo/gf)))
  79   (assert-error (eval '(fail/acc/gf (make-instance 'foo/gf)))
  80                 type-error)
  81   (eval '(make-instance 'foo/gf :slot/gf 1))
  82   (assert-error (eval '(make-instance 'foo/gf :slot/gf t))
  83                 type-error)
  84   (eval '(make-instance 'foo/gf :slot/gf *one*))
  85   (assert-error (eval '(make-instance 'foo/gf :slot/gf *t*))
  86                 type-error))
  87
  88 ;; compiler
  89 (with-test (:name (:compiler))
  90   (funcall (compile nil '(lambda ()
  91                           (setf (slot-value (make-instance 'foo) 'slot) 1))))
  92   (funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1))))
  93   (assert-error
  94    (funcall
  95     (compile nil '(lambda () (setf (slot (make-instance 'foo)) t))))
  96    type-error)
  97   (funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo)))))
  98   (assert-error
  99    (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo)))))
 100    type-error)
 101   (funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo)))))
 102   (assert-error
 103    (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo)))))
 104    type-error)
 105   (funcall (compile nil '(lambda () (make-instance 'foo :slot 1))))
 106   (assert-error
 107    (funcall (compile nil '(lambda () (make-instance 'foo :slot t))))
 108    type-error)
 109   (funcall (compile nil '(lambda () (make-instance 'foo :slot *one*))))
 110   (assert-error
 111    (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*))))
 112    type-error))
 113
 114 (with-test (:name (:compiler :setf :slot-value))
 115   (assert-error
 116    (funcall
 117     (compile nil '(lambda ()
 118                    (setf (slot-value (make-instance 'foo) 'slot) t))))
 119    type-error))
 120
 121 ; compiler/gf
 122 (with-test (:name (:compiler/gf))
 123   (funcall (compile nil
 124                     '(lambda ()
 125                       (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
 126   (funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))))
 127   (assert-error
 128    (funcall
 129     (compile nil
 130              '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))))
 131    type-error)
 132   (funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))))
 133   (assert-error
 134    (funcall (compile nil '(lambda ()
 135                            (fail/sv/gf (make-instance 'foo/gf)))))
 136    type-error)
 137   (funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))))
 138   (assert-error
 139    (funcall (compile nil '(lambda ()
 140                            (fail/acc/gf (make-instance 'foo/gf)))))
 141    type-error)
 142   (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1))))
 143   (assert-error
 144    (funcall (compile nil '(lambda ()
 145                            (make-instance 'foo/gf :slot/gf t))))
 146    type-error)
 147   (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*))))
 148   (assert-error
 149    (funcall (compile nil '(lambda ()
 150                            (make-instance 'foo/gf :slot/gf *t*))))
 151    type-error))
 152
 153 (with-test (:name (:compiler/gf :setf :slot-value))
 154   (assert-error
 155    (funcall
 156     (compile nil
 157              '(lambda ()
 158                (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
 159    type-error))
 160
 161
 162 (with-test (:name (:slot-inheritance :slot-value :float/single-float))
 163   (defclass a () ((slot1 :initform 0.0 :type float)))
 164   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 165   (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
 166   (inheritance-test (make-instance 'a))
 167   (assert-error (inheritance-test (make-instance 'b)) type-error))
 168
 169 (with-test (:name (:slot-inheritance :slot-value :t/single-float))
 170   (defclass a () ((slot1 :initform 0.0)))
 171   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 172   (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
 173   (inheritance-test (make-instance 'a))
 174   (assert-error (inheritance-test (make-instance 'b)) type-error))
 175
 176 (with-test (:name (:slot-inheritance :writer :float/single-float))
 177   (defclass a () ((slot1 :initform 0.0 :type float :accessor slot1-of)))
 178   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 179   (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
 180   (inheritance-test (make-instance 'a))
 181   (assert-error (inheritance-test (make-instance 'b)) type-error))
 182
 183 (with-test (:name (:slot-inheritance :writer :float/single-float))
 184   (defclass a () ((slot1 :initform 0.0 :accessor slot1-of)))
 185   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 186   (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
 187   (inheritance-test (make-instance 'a))
 188   (assert-error (inheritance-test (make-instance 'b)) type-error))
 189
 190 (with-test (:name (:slot-inheritance :type-intersection))
 191   (defclass a* ()
 192     ((slot1 :initform 1
 193             :initarg :slot1
 194             :accessor slot1-of
 195             :type fixnum)))
 196   (defclass b* ()
 197     ((slot1 :initform 1
 198             :initarg :slot1
 199             :accessor slot1-of
 200             :type unsigned-byte)))
 201   (defclass c* (a* b*)
 202     ())
 203   (setf (slot1-of (make-instance 'a*)) -1)
 204   (setf (slot1-of (make-instance 'b*)) (1+ most-positive-fixnum))
 205   (setf (slot1-of (make-instance 'c*)) 1)
 206   (assert-error (setf (slot1-of (make-instance 'c*)) -1)
 207                 type-error)
 208   (assert-error (setf (slot1-of (make-instance 'c*))
 209                       (1+ most-positive-fixnum))
 210                 type-error)
 211   (assert-error (make-instance 'c* :slot1 -1)
 212                 type-error)
 213   (assert-error (make-instance 'c* :slot1 (1+ most-positive-fixnum))
 214                 type-error))
 215
 216 (defclass a ()
 217   ((slot1 :initform nil
 218           :initarg :slot1
 219           :accessor slot1-of
 220           :type (or null function))))
 221 (defclass b (a)
 222   ((slot1 :initform nil
 223           :initarg :slot1
 224           :accessor slot1-of
 225           :type (or null (function (fixnum) fixnum)))))
 226
 227 (with-test (:name (:type :function))
 228   (setf (slot1-of (make-instance 'a)) (lambda () 1))
 229   (setf (slot1-of (make-instance 'b)) (lambda () 1))
 230   (assert-error (setf (slot1-of (make-instance 'a)) 1)
 231                 type-error)
 232   (assert-error (setf (slot1-of (make-instance 'b)) 1)
 233                 type-error)
 234   (make-instance 'a :slot1 (lambda () 1))
 235   (make-instance 'b :slot1 (lambda () 1)))
 236
 237 (with-test (:name :alternate-metaclass/standard-instance-structure-protocol)
 238   (defclass my-alt-metaclass (standard-class) ())
 239   (defmethod sb-mop:validate-superclass ((class my-alt-metaclass) superclass)
 240     t)
 241   (defclass my-alt-metaclass-instance-class ()
 242     ((slot :type fixnum :initarg :slot))
 243     (:metaclass my-alt-metaclass))
 244   (defun make-my-instance (class)
 245     (make-instance class :slot :not-a-fixnum))
 246   (assert-error (make-my-instance 'my-alt-metaclass-instance-class)
 247                 type-error))
 248
 249 (with-test (:name :typecheck-class-allocation)
 250   ;; :CLASS slot :INITFORMs are executed at class definition time
 251   (assert-error
 252    (eval `(locally (declare (optimize safety))
 253             (defclass class-allocation-test-bad ()
 254               ((slot :initform "slot"
 255                      :initarg :slot
 256                      :type fixnum
 257                      :allocation :class)))))
 258    type-error)
 259   (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD")))
 260     (eval `(locally (declare (optimize safety))
 261              (defclass ,name ()
 262                ((slot :initarg :slot
 263                       :type (integer 100 200)
 264                       :allocation :class)))))
 265     (eval
 266      `(macrolet ((check (form)
 267                    `(assert (multiple-value-bind (ok err)
 268                                 (ignore-errors ,form)
 269                               (and (not ok)
 270                                    (typep err 'type-error)
 271                                    (equal '(integer 100 200)
 272                                           (type-error-expected-type err)))))))
 273         (macrolet ((test (form)
 274                      `(progn
 275                         (check (eval '(locally (declare (optimize safety))
 276                                        ,form)))
 277                         (check (funcall (compile nil '(lambda ()
 278                                                        (declare (optimize safety))
 279                                                        ,form))))))
 280                    (test-slot (value form)
 281                      `(progn
 282                         (assert (eql ,value (slot-value (eval ',form) 'slot)))
 283                         (assert (eql ,value (slot-value (funcall (compile nil '(lambda () ,form)))
 284                                                         'slot))))))
 285           (test (make-instance ',name :slot :bad))
 286           (assert (not (slot-boundp (make-instance ',name) 'slot)))
 287           (let ((* (make-instance ',name :slot 101)))
 288             (test-slot 101 *)
 289             (test (setf (slot-value * 'slot) (list 1 2 3)))
 290             (setf (slot-value * 'slot) 110)
 291             (test-slot 110 *))
 292           (test-slot 110 (make-instance ',name))
 293           (test-slot 111 (make-instance ',name :slot 111)))))))