tests/slot-boundp.impure.lisp

   1 ;;;; tests of SLOT-BOUNDP and SLOT-MAKUNBOUND
   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 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (load "compiler-test-util.lisp")
  15 (defpackage "SLOT-BOUNDP-TEST"
  16   (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL"))
  17
  18 (in-package "SLOT-BOUNDP-TEST")
  19
  20 (defstruct struct-a
  21   (boxed 0 :type integer)
  22   (raw 0.0d0 :type double-float))
  23
  24 (defstruct (struct-b
  25             (:include struct-a)
  26             (:constructor make-struct-b
  27                 (&aux unboundable unboundable-boxed unboundable-raw)))
  28   (unboundable)
  29   (unboundable-boxed 0 :type integer)
  30   (unboundable-raw 0.0d0 :type double-float))
  31
  32 (define-condition condition-a ()
  33   ((condition-unbound)
  34    (condition-bound :initform 0)
  35    (condition-allocation-class :allocation :class)))
  36
  37 (defclass class-a ()
  38   ((class-unbound)
  39    (class-bound :initform 0)
  40    (class-allocation-class :allocation :class)))
  41
  42 (defun find-slotd (class name)
  43   (find name (class-slots class) :key 'slot-definition-name))
  44
  45 (with-test (:name (:always-boundp-struct-a :notinline))
  46   (let ((fun (lambda (x slot-name)
  47                (declare (notinline slot-boundp))
  48                (slot-boundp x slot-name)))
  49         (struct-a (make-struct-a)))
  50     (assert (funcall fun struct-a 'boxed))
  51     (assert (funcall fun struct-a 'raw))))
  52
  53 (with-test (:name (:always-boundp-struct-a :inline))
  54   (let ((struct-a (make-struct-a)))
  55     (assert (slot-boundp struct-a 'boxed))
  56     (assert (slot-boundp struct-a 'raw))))
  57
  58 (with-test (:name (:always-boundp-struct-a :mop))
  59   (let ((struct-a (make-struct-a))
  60         (class (find-class 'struct-a)))
  61     (assert (slot-boundp-using-class class struct-a (find-slotd class 'boxed)))
  62     (assert (slot-boundp-using-class class struct-a (find-slotd class 'raw)))))
  63
  64 (with-test (:name (:always-boundp-struct-a :struct-accessors))
  65   (let ((struct-a (make-struct-a)))
  66     (assert (eql 0 (struct-a-boxed struct-a)))
  67     (assert (eql 0.0d0 (struct-a-raw struct-a)))))
  68
  69 (with-test (:name (:not-always-boundp-struct-b :notinline))
  70   (let ((fun (lambda (x slot-name)
  71                (declare (notinline slot-boundp))
  72                (slot-boundp x slot-name)))
  73         (struct-b (make-struct-b)))
  74     (assert (funcall fun struct-b 'boxed))
  75     (assert (funcall fun struct-b 'raw))
  76
  77     (assert (not (funcall fun struct-b 'unboundable)))
  78     (setf (struct-b-unboundable struct-b) 42)
  79     (assert (= (slot-value struct-b 'unboundable) 42))
  80     (assert (funcall fun struct-b 'unboundable))
  81
  82     (assert (not (funcall fun struct-b 'unboundable-boxed)))
  83     (setf (struct-b-unboundable-boxed struct-b) 43)
  84     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
  85     (assert (funcall fun struct-b 'unboundable-boxed))
  86
  87     ;; Raw slots are always-bound even if there is an &AUX constructor
  88     ;; (there is no reasonable way to represent an unbound marker in a
  89     ;; raw slot).
  90     (assert (funcall fun struct-b 'unboundable-raw))
  91     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
  92     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
  93     (assert (funcall fun struct-b 'unboundable-raw))))
  94
  95 (with-test (:name (:not-always-boundp-struct-b :inline))
  96   (let ((struct-b (make-struct-b)))
  97     (assert (slot-boundp struct-b 'boxed))
  98     (assert (slot-boundp struct-b 'raw))
  99
 100     (assert (not (slot-boundp struct-b 'unboundable)))
 101     (setf (struct-b-unboundable struct-b) 42)
 102     (assert (= (slot-value struct-b 'unboundable) 42))
 103     (assert (slot-boundp struct-b 'unboundable))
 104
 105     (assert (not (slot-boundp struct-b 'unboundable-boxed)))
 106     (setf (struct-b-unboundable-boxed struct-b) 43)
 107     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
 108     (assert (slot-boundp struct-b 'unboundable-boxed))
 109
 110     (assert (slot-boundp struct-b 'unboundable-raw))
 111     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 112     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
 113     (assert (slot-boundp struct-b 'unboundable-raw))))
 114
 115 (with-test (:name (:not-always-boundp-struct-b :mop))
 116   (let ((struct-b (make-struct-b))
 117         (class (find-class 'struct-b)))
 118     (assert (slot-boundp-using-class class struct-b (find-slotd class 'boxed)))
 119     (assert (slot-boundp-using-class class struct-b (find-slotd class 'raw)))
 120
 121     (assert (not (slot-boundp-using-class class struct-b (find-slotd class 'unboundable))))
 122     (setf (struct-b-unboundable struct-b) 42)
 123     (assert (= (slot-value struct-b 'unboundable) 42))
 124     (assert (slot-boundp-using-class class struct-b (find-slotd class 'unboundable)))
 125
 126     (assert (not (slot-boundp-using-class class struct-b (find-slotd class 'unboundable-boxed))))
 127     (setf (struct-b-unboundable-boxed struct-b) 43)
 128     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
 129     (assert (slot-boundp-using-class class struct-b (find-slotd class 'unboundable-boxed)))
 130
 131     (assert (slot-boundp-using-class class struct-b (find-slotd class 'unboundable-raw)))
 132     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 133     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
 134     (assert (slot-boundp-using-class class struct-b (find-slotd class 'unboundable-raw)))))
 135
 136 (with-test (:name (:not-always-boundp-struct-b :struct-accessors))
 137   (let ((struct-b (make-struct-b)))
 138     (assert (eql 0 (struct-b-boxed struct-b)))
 139     (assert (eql 0.0d0 (struct-b-raw struct-b)))
 140
 141     (assert-error (struct-b-unboundable struct-b))
 142     (setf (struct-b-unboundable struct-b) 42)
 143     (assert (= (struct-b-unboundable struct-b) 42))
 144
 145     (assert-error (struct-b-unboundable-boxed struct-b))
 146     (setf (struct-b-unboundable-boxed struct-b) 43)
 147     (assert (= (struct-b-unboundable-boxed struct-b) 43))
 148
 149     (assert (eql 0.0d0 (struct-b-unboundable-raw struct-b)))
 150     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 151     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))))
 152
 153 (with-test (:name (:cannot-makunbound-struct-a :notinline))
 154   (let ((fun (lambda (x slot-name)
 155                (declare (notinline slot-makunbound))
 156                (slot-makunbound x slot-name)))
 157         (struct-a (make-struct-a)))
 158     (assert-error (funcall fun struct-a 'boxed))
 159     (assert-error (funcall fun struct-a 'raw))))
 160
 161 (with-test (:name (:cannot-makunbound-struct-a :inline))
 162   (let ((struct-a (make-struct-a)))
 163     (assert-error (slot-makunbound struct-a 'boxed))
 164     (assert-error (slot-makunbound struct-a 'raw))))
 165
 166 (with-test (:name (:cannot-makunbound-struct-a :mop))
 167   (let ((struct-a (make-struct-a))
 168         (class (find-class 'struct-a)))
 169     (assert-error (slot-makunbound-using-class class struct-a (find-slotd class 'boxed)))
 170     (assert-error (slot-makunbound-using-class class struct-a (find-slotd class 'raw)))))
 171
 172 (with-test (:name (:can-makunbound-struct-b :notinline))
 173   (let ((fun (lambda (x slot-name)
 174                (declare (notinline slot-makunbound))
 175                (slot-makunbound x slot-name)))
 176         (struct-b (make-struct-b)))
 177     (assert (not (slot-boundp struct-b 'unboundable)))
 178     (assert-error (funcall fun struct-b 'boxed))
 179     (assert-error (funcall fun struct-b 'raw))
 180     (assert (eql (funcall fun struct-b 'unboundable) struct-b))
 181
 182     (setf (struct-b-unboundable struct-b) 42)
 183     (assert (slot-boundp struct-b 'unboundable))
 184     (assert (= (slot-value struct-b 'unboundable) 42))
 185     (assert (eql (funcall fun struct-b 'unboundable) struct-b))
 186     (assert (not (slot-boundp struct-b 'unboundable)))
 187
 188     (setf (struct-b-unboundable-boxed struct-b) 43)
 189     (assert (slot-boundp struct-b 'unboundable-boxed))
 190     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
 191     (assert (eql (funcall fun struct-b 'unboundable-boxed) struct-b))
 192     (assert (not (slot-boundp struct-b 'unboundable-boxed)))
 193
 194     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 195     (assert (slot-boundp struct-b 'unboundable-raw))
 196     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
 197     (assert-error (funcall fun struct-b 'unboundable-raw))
 198     (assert (slot-boundp struct-b 'unboundable-raw))))
 199
 200 (with-test (:name (:can-makunbound-struct-b :inline))
 201   (let ((struct-b (make-struct-b)))
 202     (assert (not (slot-boundp struct-b 'unboundable)))
 203     (assert-error (slot-makunbound struct-b 'boxed))
 204     (assert-error (slot-makunbound struct-b 'raw))
 205     (assert (eql (slot-makunbound struct-b 'unboundable) struct-b))
 206
 207     (setf (struct-b-unboundable struct-b) 42)
 208     (assert (slot-boundp struct-b 'unboundable))
 209     (assert (= (slot-value struct-b 'unboundable) 42))
 210     (assert (eql (slot-makunbound struct-b 'unboundable) struct-b))
 211     (assert (not (slot-boundp struct-b 'unboundable)))
 212
 213     (setf (struct-b-unboundable-boxed struct-b) 43)
 214     (assert (slot-boundp struct-b 'unboundable-boxed))
 215     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
 216     (assert (eql (slot-makunbound struct-b 'unboundable-boxed) struct-b))
 217     (assert (not (slot-boundp struct-b 'unboundable-boxed)))
 218
 219     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 220     (assert (slot-boundp struct-b 'unboundable-raw))
 221     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
 222     (assert-error (slot-makunbound struct-b 'unboundable-raw))
 223     (assert (slot-boundp struct-b 'unboundable-raw))))
 224
 225 (with-test (:name (:can-makunbound-struct-b :mop))
 226   (let ((struct-b (make-struct-b))
 227         (class (find-class 'struct-b)))
 228     (assert (not (slot-boundp struct-b 'unboundable)))
 229     (assert-error (slot-makunbound-using-class class struct-b (find-slotd class 'boxed)))
 230     (assert-error (slot-makunbound-using-class class struct-b (find-slotd class 'raw)))
 231     (assert (eql (slot-makunbound-using-class class struct-b (find-slotd class 'unboundable))
 232                  struct-b))
 233
 234     (setf (struct-b-unboundable struct-b) 42)
 235     (assert (slot-boundp struct-b 'unboundable))
 236     (assert (= (slot-value struct-b 'unboundable) 42))
 237     (assert (eql (slot-makunbound-using-class class struct-b (find-slotd class 'unboundable))
 238                  struct-b))
 239     (assert (not (slot-boundp struct-b 'unboundable)))
 240
 241     (setf (struct-b-unboundable-boxed struct-b) 43)
 242     (assert (slot-boundp struct-b 'unboundable-boxed))
 243     (assert (= (slot-value struct-b 'unboundable-boxed) 43))
 244     (assert
 245      (eql (slot-makunbound-using-class class struct-b (find-slotd class 'unboundable-boxed))
 246           struct-b))
 247     (assert (not (slot-boundp struct-b 'unboundable-boxed)))
 248
 249     (setf (struct-b-unboundable-raw struct-b) 44.0d0)
 250     (assert (slot-boundp struct-b 'unboundable-raw))
 251     (assert (= (slot-value struct-b 'unboundable-raw) 44.0d0))
 252     (assert-error
 253      (slot-makunbound-using-class class struct-b (find-slotd class 'unboundable-raw)))
 254     (assert (slot-boundp struct-b 'unboundable-raw))))
 255
 256 (with-test (:name (:not-always-boundp-condition-a :notinline))
 257   (let ((fun (lambda (x slot-name)
 258                (declare (notinline slot-boundp))
 259                (slot-boundp x slot-name)))
 260         (condition-a (make-condition 'condition-a)))
 261     (assert (funcall fun condition-a 'condition-bound))
 262
 263     (assert (not (funcall fun condition-a 'condition-unbound)))
 264     (setf (slot-value condition-a 'condition-unbound) 42)
 265     (assert (funcall fun condition-a 'condition-unbound))
 266
 267     (assert (not (funcall fun condition-a 'condition-allocation-class)))
 268     (setf (slot-value condition-a 'condition-allocation-class) 43)
 269     (assert (funcall fun condition-a 'condition-allocation-class))))
 270
 271 (with-test (:name (:can-makunbound-condition-a :notinline))
 272   (let ((fun (lambda (x slot-name)
 273                (declare (notinline slot-makunbound))
 274                (slot-makunbound x slot-name)))
 275         (condition-a (make-condition 'condition-a)))
 276     (assert (eql (funcall fun condition-a 'condition-bound) condition-a))
 277     (assert (not (slot-boundp condition-a 'condition-bound)))
 278
 279     (assert (eql (funcall fun condition-a 'condition-unbound) condition-a))
 280     (setf (slot-value condition-a 'condition-unbound) 42)
 281     (assert (slot-boundp condition-a 'condition-unbound))
 282     (assert (funcall fun condition-a 'condition-unbound))
 283     (assert (not (slot-boundp condition-a 'condition-unbound)))
 284
 285     (assert (eql (funcall fun condition-a 'condition-allocation-class) condition-a))
 286     (setf (slot-value condition-a 'condition-allocation-class) 43)
 287     (assert (slot-boundp condition-a 'condition-allocation-class))
 288     (assert (funcall fun condition-a 'condition-allocation-class))
 289     (assert (not (slot-boundp condition-a 'condition-allocation-class)))))
 290
 291 (with-test (:name (:not-always-boundp-class-a :notinline))
 292   (slot-makunbound (make-instance 'class-a) 'class-allocation-class)
 293   (let ((fun (lambda (x slot-name)
 294                (declare (notinline slot-boundp))
 295                (slot-boundp x slot-name)))
 296         (class-a (make-instance 'class-a)))
 297     (assert (funcall fun class-a 'class-bound))
 298
 299     (assert (not (funcall fun class-a 'class-unbound)))
 300     (setf (slot-value class-a 'class-unbound) 42)
 301     (assert (funcall fun class-a 'class-unbound))
 302
 303     (assert (not (funcall fun class-a 'class-allocation-class)))
 304     (setf (slot-value class-a 'class-allocation-class) 43)
 305     (assert (funcall fun class-a 'class-allocation-class))))
 306
 307 (defmethod not-always-boundp-class-a ((x class-a))
 308   (assert (slot-boundp x 'class-bound))
 309
 310   (assert (not (slot-boundp x 'class-unbound)))
 311   (setf (slot-value x 'class-unbound) 42)
 312   (assert (slot-boundp x 'class-unbound))
 313
 314   (assert (not (slot-boundp x 'class-allocation-class)))
 315   (setf (slot-value x 'class-allocation-class) 43)
 316   (assert (slot-boundp x 'class-allocation-class))
 317
 318   (let ((y (make-instance 'class-a)))
 319     (assert (slot-boundp y 'class-bound))
 320     (assert (not (slot-boundp y 'class-unbound)))
 321     (assert (slot-boundp y 'class-allocation-class))))
 322
 323 (with-test (:name (:not-always-boundp-class-a :method))
 324   (slot-makunbound (make-instance 'class-a) 'class-allocation-class)
 325   (not-always-boundp-class-a (make-instance 'class-a)))
 326
 327 (with-test (:name (:can-makunbound-class-a :notinline))
 328   (let ((fun (lambda (x slot-name)
 329                (declare (notinline slot-makunbound))
 330                (slot-makunbound x slot-name)))
 331         (class-a (make-instance 'class-a)))
 332     (assert (eql (funcall fun class-a 'class-bound) class-a))
 333     (assert (not (slot-boundp class-a 'class-bound)))
 334
 335     (assert (eql (funcall fun class-a 'class-unbound) class-a))
 336     (setf (slot-value class-a 'class-unbound) 42)
 337     (assert (slot-boundp class-a 'class-unbound))
 338     (assert (funcall fun class-a 'class-unbound))
 339     (assert (not (slot-boundp class-a 'class-unbound)))
 340
 341     (assert (eql (funcall fun class-a 'class-allocation-class) class-a))
 342     (setf (slot-value class-a 'class-allocation-class) 43)
 343     (assert (slot-boundp class-a 'class-allocation-class))
 344     (assert (funcall fun class-a 'class-allocation-class))
 345     (assert (not (slot-boundp class-a 'class-allocation-class)))))
 346
 347 (defmethod can-makunbound-class-a ((x class-a))
 348   (assert (eql (slot-makunbound x 'class-bound) x))
 349   (assert (not (slot-boundp x 'class-bound)))
 350
 351   (assert (eql (slot-makunbound x 'class-unbound) x))
 352   (setf (slot-value x 'class-unbound) 42)
 353   (assert (slot-boundp x 'class-unbound))
 354   (assert (slot-makunbound x 'class-unbound))
 355   (assert (not (slot-boundp x 'class-unbound)))
 356
 357   (assert (eql (slot-makunbound x 'class-allocation-class) x))
 358   (setf (slot-value x 'class-allocation-class) 43)
 359   (assert (slot-boundp x 'class-allocation-class))
 360   (assert (slot-makunbound x 'class-allocation-class))
 361   (assert (not (slot-boundp x 'class-allocation-class)))
 362
 363   (let ((y (make-instance 'class-a)))
 364     (assert (slot-boundp y 'class-bound))
 365     (assert (not (slot-boundp y 'class-unbound)))
 366     (assert (not (slot-boundp y 'class-allocation-class)))))
 367
 368 (with-test (:name (:can-makunbound-class-a :method))
 369   (slot-makunbound (make-instance 'class-a) 'class-allocation-class)
 370   (can-makunbound-class-a (make-instance 'class-a)))