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 (shadow 'slot)
  16
  17 (declaim (optimize safety))
  18
  19 (defclass foo ()
  20   ((slot :initarg :slot :type fixnum :accessor slot)))
  21 (defclass foo/gf (sb-mop:standard-generic-function)
  22   ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf))
  23   (:metaclass sb-mop:funcallable-standard-class))
  24 (defmethod succeed/sv ((x foo))
  25   (setf (slot-value x 'slot) 1))
  26 (defmethod fail/sv ((x foo))
  27   (setf (slot-value x 'slot) t))
  28 (defmethod succeed/acc ((x foo))
  29   (setf (slot x) 1))
  30 (defmethod fail/acc ((x foo))
  31   (setf (slot x) t))
  32 (defmethod succeed/sv/gf ((x foo/gf))
  33   (setf (slot-value x 'slot/gf) 1))
  34 (defmethod fail/sv/gf ((x foo/gf))
  35   (setf (slot-value x 'slot/gf) t))
  36 (defmethod succeed/acc/gf ((x foo/gf))
  37   (setf (slot/gf x) 1))
  38 (defmethod fail/acc/gf ((x foo/gf))
  39   (setf (slot/gf x) t))
  40 (defvar *t* t)
  41 (defvar *one* 1)
  42
  43 ;; evaluator
  44 (with-test (:name (:evaluator))
  45   (eval '(setf (slot-value (make-instance 'foo) 'slot) 1))
  46   (assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t))
  47                          type-error))
  48   (eval '(setf (slot (make-instance 'foo)) 1))
  49   (assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t))
  50                          type-error))
  51   (eval '(succeed/sv (make-instance 'foo)))
  52   (assert (raises-error? (eval '(fail/sv (make-instance 'foo)))
  53                          type-error))
  54   (eval '(succeed/acc (make-instance 'foo)))
  55   (assert (raises-error? (eval '(fail/acc (make-instance 'foo)))
  56                          type-error))
  57   (eval '(make-instance 'foo :slot 1))
  58   (assert (raises-error? (eval '(make-instance 'foo :slot t))
  59                          type-error))
  60   (eval '(make-instance 'foo :slot *one*))
  61   (assert (raises-error? (eval '(make-instance 'foo :slot *t*))
  62                          type-error)))
  63 ;; evaluator/gf
  64 (with-test (:name (:evaluator/gf))
  65   (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))
  66   (assert (raises-error?
  67            (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))
  68            type-error))
  69   (eval '(setf (slot/gf (make-instance 'foo/gf)) 1))
  70   (assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t))
  71                          type-error))
  72   (eval '(succeed/sv/gf (make-instance 'foo/gf)))
  73   (assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf)))
  74                          type-error))
  75   (eval '(succeed/acc/gf (make-instance 'foo/gf)))
  76   (assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf)))
  77                          type-error))
  78   (eval '(make-instance 'foo/gf :slot/gf 1))
  79   (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t))
  80                          type-error))
  81   (eval '(make-instance 'foo/gf :slot/gf *one*))
  82   (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*))
  83                          type-error)))
  84
  85 ;; compiler
  86 (with-test (:name (:compiler))
  87   (funcall (compile nil '(lambda ()
  88                           (setf (slot-value (make-instance 'foo) 'slot) 1))))
  89   (funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1))))
  90   (assert (raises-error?
  91            (funcall
  92             (compile nil '(lambda () (setf (slot (make-instance 'foo)) t))))
  93            type-error))
  94   (funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo)))))
  95   (assert (raises-error?
  96            (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo)))))
  97            type-error))
  98   (funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo)))))
  99   (assert (raises-error?
 100            (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo)))))
 101            type-error))
 102   (funcall (compile nil '(lambda () (make-instance 'foo :slot 1))))
 103   (assert (raises-error?
 104            (funcall (compile nil '(lambda () (make-instance 'foo :slot t))))
 105            type-error))
 106   (funcall (compile nil '(lambda () (make-instance 'foo :slot *one*))))
 107   (assert (raises-error?
 108            (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*))))
 109            type-error)))
 110
 111 (with-test (:name (:compiler :setf :slot-value))
 112   (assert (raises-error?
 113            (funcall
 114             (compile nil '(lambda ()
 115                            (setf (slot-value (make-instance 'foo) 'slot) t))))
 116            type-error)))
 117
 118 ; compiler/gf
 119 (with-test (:name (:compiler/gf))
 120   (funcall (compile nil
 121                     '(lambda ()
 122                       (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1))))
 123   (funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1))))
 124   (assert (raises-error?
 125            (funcall
 126             (compile nil
 127                      '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t))))
 128            type-error))
 129   (funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf)))))
 130   (assert (raises-error?
 131            (funcall (compile nil '(lambda ()
 132                                    (fail/sv/gf (make-instance 'foo/gf)))))
 133            type-error))
 134   (funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf)))))
 135   (assert (raises-error?
 136            (funcall (compile nil '(lambda ()
 137                                    (fail/acc/gf (make-instance 'foo/gf)))))
 138            type-error))
 139   (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1))))
 140   (assert (raises-error?
 141            (funcall (compile nil '(lambda ()
 142                                    (make-instance 'foo/gf :slot/gf t))))
 143            type-error))
 144   (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*))))
 145   (assert (raises-error?
 146            (funcall (compile nil '(lambda ()
 147                                    (make-instance 'foo/gf :slot/gf *t*))))
 148            type-error)))
 149
 150 (with-test (:name (:compiler/gf :setf :slot-value))
 151   (assert (raises-error?
 152            (funcall
 153             (compile nil
 154                      '(lambda ()
 155                        (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t))))
 156            type-error)))
 157
 158
 159 (with-test (:name (:slot-inheritance :slot-value :float/single-float))
 160   (defclass a () ((slot1 :initform 0.0 :type float)))
 161   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 162   (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
 163   (inheritance-test (make-instance 'a))
 164   (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
 165
 166 (with-test (:name (:slot-inheritance :slot-value :t/single-float))
 167   (defclass a () ((slot1 :initform 0.0)))
 168   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 169   (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0))
 170   (inheritance-test (make-instance 'a))
 171   (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
 172
 173 (with-test (:name (:slot-inheritance :writer :float/single-float))
 174   (defclass a () ((slot1 :initform 0.0 :type float :accessor slot1-of)))
 175   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 176   (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
 177   (inheritance-test (make-instance 'a))
 178   (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
 179
 180 (with-test (:name (:slot-inheritance :writer :float/single-float))
 181   (defclass a () ((slot1 :initform 0.0 :accessor slot1-of)))
 182   (defclass b (a) ((slot1 :initform 0.0 :type single-float)))
 183   (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0))
 184   (inheritance-test (make-instance 'a))
 185   (assert (raises-error? (inheritance-test (make-instance 'b)) type-error)))
 186
 187 (with-test (:name (:slot-inheritance :type-intersection))
 188   (defclass a* ()
 189     ((slot1 :initform 1
 190             :initarg :slot1
 191             :accessor slot1-of
 192             :type fixnum)))
 193   (defclass b* ()
 194     ((slot1 :initform 1
 195             :initarg :slot1
 196             :accessor slot1-of
 197             :type unsigned-byte)))
 198   (defclass c* (a* b*)
 199     ())
 200   (setf (slot1-of (make-instance 'a*)) -1)
 201   (setf (slot1-of (make-instance 'b*)) (1+ most-positive-fixnum))
 202   (setf (slot1-of (make-instance 'c*)) 1)
 203   (assert (raises-error? (setf (slot1-of (make-instance 'c*)) -1)
 204                                type-error))
 205   (assert (raises-error? (setf (slot1-of (make-instance 'c*))
 206                                (1+ most-positive-fixnum))
 207                          type-error))
 208   (assert (raises-error? (make-instance 'c* :slot1 -1)
 209                          type-error))
 210   (assert (raises-error? (make-instance 'c* :slot1 (1+ most-positive-fixnum))
 211                          type-error)))
 212
 213 (defclass a ()
 214   ((slot1 :initform nil
 215           :initarg :slot1
 216           :accessor slot1-of
 217           :type (or null function))))
 218 (defclass b (a)
 219   ((slot1 :initform nil
 220           :initarg :slot1
 221           :accessor slot1-of
 222           :type (or null (function (fixnum) fixnum)))))
 223
 224 (with-test (:name (:type :function))
 225   (setf (slot1-of (make-instance 'a)) (lambda () 1))
 226   (setf (slot1-of (make-instance 'b)) (lambda () 1))
 227   (assert (raises-error? (setf (slot1-of (make-instance 'a)) 1)
 228                          type-error))
 229   (assert (raises-error? (setf (slot1-of (make-instance 'b)) 1)
 230                          type-error))
 231   (make-instance 'a :slot1 (lambda () 1))
 232   (make-instance 'b :slot1 (lambda () 1)))
 233
 234 (with-test (:name :alternate-metaclass/standard-instance-structure-protocol)
 235   (defclass my-alt-metaclass (standard-class) ())
 236   (defmethod sb-mop:validate-superclass ((class my-alt-metaclass) superclass)
 237     t)
 238   (defclass my-alt-metaclass-instance-class ()
 239     ((slot :type fixnum :initarg :slot))
 240     (:metaclass my-alt-metaclass))
 241   (defun make-my-instance (class)
 242     (make-instance class :slot :not-a-fixnum))
 243   (assert (raises-error? (make-my-instance 'my-alt-metaclass-instance-class)
 244                          type-error)))