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 (invoke-restart 'run-tests::skip-file)
  17
  18 (shadow 'slot)
  19
  20 (declaim (optimize safety))
  21
  22 (defvar *t* t)
  23 (defvar *one* 1)
  24 \f
  25 ;;;; Slot type checking for standard instances
  26
  27 (defclass foo ()
  28   ((slot :initarg :slot :type fixnum :accessor slot)))
  29 (defmethod succeed/sv ((x foo))
  30   (setf (slot-value x 'slot) 1))
  31 (defmethod fail/sv ((x foo))
  32   (setf (slot-value x 'slot) t))
  33 (defmethod succeed/acc ((x foo))
  34   (setf (slot x) 1))
  35 (defmethod fail/acc ((x foo))
  36   (setf (slot x) t))
  37
  38 ;;; Test slot type checking for standard instances in EVALed code.
  39 (with-test (:name (standard-object slot-value setf :initarg type-error eval))
  40   (eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
  41   (assert-error (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
  42                 type-error)
  43   (eval '(setf (slot (make-instance 'foo)) 1))
  44   (assert-error (eval '(setf (slot (make-instance 'foo)) t))
  45                 type-error)
  46   (eval '(succeed/sv (make-instance 'foo)))
  47   (assert-error (eval '(fail/sv (make-instance 'foo)))
  48                 type-error)
  49   (eval '(succeed/acc (make-instance 'foo)))
  50   (assert-error (eval '(fail/acc (make-instance 'foo)))
  51                 type-error)
  52   (eval '(make-instance 'foo :slot 1))
  53   (assert-error (eval '(make-instance 'foo :slot t))
  54                 type-error)
  55   (eval '(make-instance 'foo :slot *one*))
  56   (assert-error (eval '(make-instance 'foo :slot *t*))
  57                 type-error))
  58
  59 ;;; Test slot type checking for standard instances in compiled code.
  60 (with-test (:name (standard-object slot-value setf :initarg type-error
  61                    compile))
  62   (checked-compile-and-assert (:optimize :safe)
  63       '(lambda ()
  64          (setf (slot-value (make-instance 'foo) 'slot) 1))
  65     (() 1))
  66   (checked-compile-and-assert ()
  67       '(lambda ()
  68          (setf (slot-value (make-instance 'foo) 'slot) t))
  69     (() (condition 'type-error)))
  70
  71   (checked-compile-and-assert (:optimize :safe)
  72       '(lambda () (setf (slot (make-instance 'foo)) 1))
  73     (() 1))
  74   (checked-compile-and-assert (:optimize :safe)
  75       '(lambda () (setf (slot (make-instance 'foo)) t))
  76     (() (condition 'type-error)))
  77
  78   (checked-compile-and-assert (:optimize :safe)
  79       '(lambda () (succeed/sv (make-instance 'foo)))
  80     (() 1))
  81   (checked-compile-and-assert (:optimize :safe)
  82       '(lambda () (fail/sv (make-instance 'foo)))
  83     (() (condition 'type-error)))
  84
  85   (checked-compile-and-assert (:optimize :safe)
  86       '(lambda () (succeed/acc (make-instance 'foo)))
  87     (() 1))
  88   (checked-compile-and-assert (:optimize :safe)
  89       '(lambda () (fail/acc (make-instance 'foo)))
  90     (() (condition 'type-error)))
  91
  92   ;; These four cases trigger PCL's constructor mechanism and
  93   ;;
  94   ;; FIXME: the type mismatch is handled poorly:
  95   ;; When the function is *called*, an entry is added to the
  96   ;; constructor cache, this process signals a TYPE-WARNING, usually
  97   ;; meant for compile-time. When the call proceeds and executes the
  98   ;; newly cached constructor, the expected runtime TYPE-ERROR is
  99   ;; signaled.
 100   ;;
 101   ;; FIXME: also note that constructor type checks are only inserted
 102   ;; when SAFETY is 3, which is different from other slot type checks.
 103   (checked-compile-and-assert (:optimize :maximally-safe)
 104       '(lambda () (make-instance 'foo :slot 1))
 105     (() '(cons foo null) :test (lambda (values expected)
 106                                  (typep values (first expected)))))
 107   (checked-compile-and-assert (:optimize :maximally-safe)
 108       '(lambda () (make-instance 'foo :slot t))
 109     (() (condition '(or sb-int:type-warning type-error))))
 110
 111   (checked-compile-and-assert (:optimize :maximally-safe)
 112       '(lambda () (make-instance 'foo :slot *one*))
 113     (() '(cons foo null) :test (lambda (values expected)
 114                                  (typep values (first expected)))))
 115   (checked-compile-and-assert (:optimize :maximally-safe)
 116       '(lambda () (make-instance 'foo :slot *t*))
 117     (() (condition 'type-error))))
 118 \f
 119 ;;;; Slot type checking for funcallable instances
 120
 121 (defclass foo/gf (sb-mop:standard-generic-function)
 122   ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
 123   (:metaclass sb-mop:funcallable-standard-class))
 124 (defmethod succeed/sv/gf ((x foo/gf))
 125   (setf (slot-value x 'slot/gf) 1))
 126 (defmethod fail/sv/gf ((x foo/gf))
 127   (setf (slot-value x 'slot/gf) t))
 128 (defmethod succeed/acc/gf ((x foo/gf))
 129   (setf (slot/gf x) 1))
 130 (defmethod fail/acc/gf ((x foo/gf))
 131   (setf (slot/gf x) t))
 132
 133 ;;; Test slot type checking for funcallable instances in EVALed code.
 134 (with-test (:name (sb-mop:funcallable-standard-object slot-value setf
 135                    :initarg type-error eval))
 136   (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
 137   (assert-error
 138    (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
 139    type-error)
 140   (eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
 141   (assert-error (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
 142                 type-error)
 143   (eval '(succeed/sv/gf (make-instance 'foo/gf)))
 144   (assert-error (eval '(fail/sv/gf (make-instance 'foo/gf)))
 145                 type-error)
 146   (eval '(succeed/acc/gf (make-instance 'foo/gf)))
 147   (assert-error (eval '(fail/acc/gf (make-instance 'foo/gf)))
 148                 type-error)
 149   (eval '(make-instance 'foo/gf :slot/gf 1))
 150   (assert-error (eval '(make-instance 'foo/gf :slot/gf t))
 151                 type-error)
 152   (eval '(make-instance 'foo/gf :slot/gf *one*))
 153   (assert-error (eval '(make-instance 'foo/gf :slot/gf *t*))
 154                 type-error))
 155
 156 ;;; Test slot type checking for funcallable instances in compiled
 157 ;;; code.
 158 (with-test (:name (sb-mop:funcallable-standard-object slot-value setf
 159                    :initarg type-error compile))
 160   (checked-compile-and-assert (:optimize :safe)
 161       '(lambda ()
 162          (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
 163     (() 1))
 164   (checked-compile-and-assert (:optimize :safe)
 165       '(lambda ()
 166          (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
 167     (() (condition 'type-error)))
 168
 169   (checked-compile-and-assert (:optimize :safe)
 170       '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))
 171     (() 1))
 172   (checked-compile-and-assert (:optimize :safe)
 173       '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))
 174     (() (condition 'type-error)))
 175
 176   (checked-compile-and-assert (:optimize :safe)
 177       '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))
 178     (() 1))
 179   (checked-compile-and-assert (:optimize :safe)
 180       '(lambda ()
 181          (fail/sv/gf (make-instance 'foo/gf)))
 182     (() (condition 'type-error)))
 183
 184   (checked-compile-and-assert (:optimize :safe)
 185       '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))
 186     (() 1))
 187   (checked-compile-and-assert (:optimize :safe)
 188       '(lambda () (fail/acc/gf (make-instance 'foo/gf)))
 189     (() (condition 'type-error)))
 190
 191   ;; FIXME: Comments for corresponding cases in standard instance test
 192   ;; apply here as well.
 193   (checked-compile-and-assert (:optimize :maximally-safe)
 194       '(lambda () (make-instance 'foo/gf :slot/gf 1))
 195     (() '(cons foo/gf null) :test (lambda (actual expected)
 196                                     (typep actual (first expected)))))
 197   (checked-compile-and-assert (:optimize :maximally-safe)
 198       '(lambda () (make-instance 'foo/gf :slot/gf t))
 199     (() (condition '(or sb-int:type-warning type-error))))
 200
 201   (checked-compile-and-assert (:optimize :maximally-safe)
 202       '(lambda () (make-instance 'foo/gf :slot/gf *one*))
 203     (() '(cons foo/gf null) :test (lambda (actual expected)
 204                                     (typep actual (first expected)))))
 205   (checked-compile-and-assert (:optimize :maximally-safe)
 206       '(lambda () (make-instance 'foo/gf :slot/gf *t*))
 207     (() (condition 'type-error))))
 208 \f
 209 ;;;; Type checking for inherited slots
 210
 211 (defclass inheritance-a/slot-value/float ()
 212   ((slot1 :initform 0.0 :type float)))
 213 (defclass inheritance-b/slot-value/float (inheritance-a/slot-value/float)
 214   ((slot1 :initform 0.0 :type single-float)))
 215 (defmethod inheritance/slot-value/float ((a inheritance-a/slot-value/float))
 216   (setf (slot-value a 'slot1) 1d0))
 217
 218 (with-test (:name (:slot-inheritance slot-value float single-float))
 219   (inheritance/slot-value/float
 220    (make-instance 'inheritance-a/slot-value/float))
 221   (assert-error (inheritance/slot-value/float
 222                  (make-instance 'inheritance-b/slot-value/float))
 223                 type-error))
 224
 225 (defclass inheritance-a/slot-value/t ()
 226   ((slot1 :initform 0.0)))
 227 (defclass inheritance-b/slot-value/t (inheritance-a/slot-value/t)
 228   ((slot1 :initform 0.0 :type single-float)))
 229 (defmethod inheritance/slot-value/t ((a inheritance-a/slot-value/t))
 230   (setf (slot-value a 'slot1) 1d0))
 231
 232 (with-test (:name (:slot-inheritance slot-value t single-float))
 233   (inheritance/slot-value/t (make-instance 'inheritance-a/slot-value/t))
 234   (assert-error (inheritance/slot-value/t
 235                  (make-instance 'inheritance-b/slot-value/t))
 236                 type-error))
 237
 238 (defclass inheritance-a/accessor/float ()
 239   ((slot1 :initform 0.0 :type float :accessor slot1-of)))
 240 (defclass inheritance-b/accessor/float (inheritance-a/accessor/float)
 241   ((slot1 :initform 0.0 :type single-float)))
 242 (defmethod inheritance/accessor/float ((a inheritance-a/accessor/float))
 243   (setf (slot1-of a) 1d0))
 244
 245 (with-test (:name (:slot-inheritance :writer float single-float))
 246   (inheritance/accessor/float
 247    (make-instance 'inheritance-a/accessor/float))
 248   (assert-error (inheritance/accessor/float
 249                  (make-instance 'inheritance-b/accessor/float))
 250                 type-error))
 251
 252 (defclass inheritance-a/accessor/t ()
 253   ((slot1 :initform 0.0 :accessor slot1-of)))
 254 (defclass inheritance-b/accessor/t (inheritance-a/accessor/t)
 255   ((slot1 :initform 0.0 :type single-float)))
 256 (defmethod inheritance/accessor/t ((a inheritance-a/accessor/t))
 257   (setf (slot1-of a) 1d0))
 258
 259 (with-test (:name (:slot-inheritance :writer t single-float))
 260   (inheritance/accessor/t (make-instance 'inheritance-a/accessor/t))
 261   (assert-error (inheritance/accessor/t
 262                  (make-instance 'inheritance-b/accessor/t))
 263                 type-error))
 264
 265 (defclass inheritance-intersection-a* ()
 266   ((slot1 :initform 1
 267           :initarg :slot1
 268           :accessor slot1-of
 269           :type fixnum)))
 270 (defclass inheritance-intersection-b* ()
 271   ((slot1 :initform 1
 272           :initarg :slot1
 273           :accessor slot1-of
 274           :type unsigned-byte)))
 275 (defclass inheritance-intersection-c* (inheritance-intersection-a*
 276                                        inheritance-intersection-b*)
 277   ())
 278
 279 (with-test (:name (:slot-inheritance :type-intersection))
 280   (setf (slot1-of (make-instance 'inheritance-intersection-a*)) -1)
 281   (setf (slot1-of (make-instance 'inheritance-intersection-b*))
 282         (1+ most-positive-fixnum))
 283   (setf (slot1-of (make-instance 'inheritance-intersection-c*)) 1)
 284   (assert-error (setf (slot1-of (make-instance 'inheritance-intersection-c*))
 285                       -1)
 286                 type-error)
 287   (assert-error (setf (slot1-of (make-instance 'inheritance-intersection-c*))
 288                       (1+ most-positive-fixnum))
 289                 type-error)
 290   (assert-error (make-instance 'inheritance-intersection-c* :slot1 -1)
 291                 type-error)
 292   (assert-error (make-instance 'inheritance-intersection-c*
 293                                :slot1 (1+ most-positive-fixnum))
 294                 type-error))
 295
 296 (defclass slot-type-function-a ()
 297   ((slot1 :initform nil
 298           :initarg :slot1
 299           :accessor slot1-of
 300           :type (or null function))))
 301 (defclass slot-type-function-b (slot-type-function-a)
 302   ((slot1 :initform nil
 303           :initarg :slot1
 304           :accessor slot1-of
 305           :type (or null (function (fixnum) fixnum)))))
 306
 307 (with-test (:name (:type function type-error))
 308   (setf (slot1-of (make-instance 'slot-type-function-a)) (lambda () 1))
 309   (setf (slot1-of (make-instance 'slot-type-function-b)) (lambda () 1))
 310   (assert-error (setf (slot1-of (make-instance 'slot-type-function-a)) 1)
 311                 type-error)
 312   (assert-error (setf (slot1-of (make-instance 'slot-type-function-b)) 1)
 313                 type-error)
 314   (make-instance 'slot-type-function-a :slot1 (lambda () 1))
 315   (make-instance 'slot-type-function-b :slot1 (lambda () 1)))
 316
 317 (defclass my-alt-metaclass (standard-class) ())
 318 (defmethod sb-mop:validate-superclass ((class my-alt-metaclass) superclass)
 319   t)
 320 (defclass my-alt-metaclass-instance-class ()
 321   ((slot :type fixnum :initarg :slot))
 322   (:metaclass my-alt-metaclass))
 323 (defun make-my-instance (class)
 324   (make-instance class :slot :not-a-fixnum))
 325
 326 (with-test (:name :alternate-metaclass/standard-instance-structure-protocol)
 327   (assert-error (make-my-instance 'my-alt-metaclass-instance-class)
 328                 type-error))
 329
 330 (with-test (:name (:typecheck :allocation :class))
 331   ;; :CLASS slot :INITFORMs are executed at class definition time
 332   (assert-error
 333    (eval `(locally (declare (optimize safety))
 334             (defclass class-allocation-test-bad ()
 335               ((slot :initform "slot"
 336                      :initarg :slot
 337                      :type fixnum
 338                      :allocation :class)))))
 339    type-error)
 340   (let ((name (gensym "CLASS-ALLOCATION-TEST-GOOD")))
 341     (eval `(locally (declare (optimize safety))
 342              (defclass ,name ()
 343                ((slot :initarg :slot
 344                       :type (integer 100 200)
 345                       :allocation :class)))))
 346     (eval
 347      `(macrolet ((check (form)
 348                    `(assert (multiple-value-bind (ok err)
 349                                 (ignore-errors ,form)
 350                               (and (not ok)
 351                                    (typep err 'type-error)
 352                                    (equal '(integer 100 200)
 353                                           (type-error-expected-type err)))))))
 354         (macrolet ((test (form)
 355                      `(progn
 356                         (check (eval '(locally (declare (optimize safety))
 357                                        ,form)))
 358                         (check (funcall (checked-compile
 359                                          '(lambda ()
 360                                            (declare (optimize safety))
 361                                            ,form))))))
 362                    (test-slot (value form)
 363                      `(progn
 364                         (assert (eql ,value (slot-value (eval ',form) 'slot)))
 365                         (assert (eql ,value (slot-value (funcall (checked-compile
 366                                                                   '(lambda () ,form)))
 367                                                         'slot))))))
 368           (test (make-instance ',name :slot :bad))
 369           (assert (not (slot-boundp (make-instance ',name) 'slot)))
 370           (let ((* (make-instance ',name :slot 101)))
 371             (test-slot 101 *)
 372             (test (setf (slot-value * 'slot) (list 1 2 3)))
 373             (setf (slot-value * 'slot) 110)
 374             (test-slot 110 *))
 375           (test-slot 110 (make-instance ',name))
 376           (test-slot 111 (make-instance ',name :slot 111)))))))