tests/slot-unbound.impure.lisp

   1 ;;;; tests of SLOT-UNBOUND
   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-UNBOUND-TEST"
  16   (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL"))
  17
  18 (in-package "SLOT-UNBOUND-TEST")
  19
  20 (defstruct (struct-a (:constructor make-struct-a (&aux unboundable)))
  21   (boxed 0 :type integer)
  22   (raw 0.0d0 :type double-float)
  23   (unboundable))
  24
  25 (defvar *slot-unbounds*)
  26
  27 (defmethod slot-unbound (class (s struct-a) slot-name)
  28   (push (cons 'struct-a slot-name) *slot-unbounds*)
  29   42)
  30
  31 (define-condition condition-a ()
  32   ((condition-bound :initform 0)
  33    (condition-unbound)))
  34
  35 (defmethod slot-unbound (class (c condition-a) slot-name)
  36   (push (cons 'condition-a slot-name) *slot-unbounds*)
  37   43)
  38
  39 (defclass class-a ()
  40   ((class-bound :initform 0)
  41    (class-unbound)))
  42
  43 (defmethod slot-unbound (class (c class-a) slot-name)
  44   (push (cons 'class-a slot-name) *slot-unbounds*)
  45   44)
  46
  47 (with-test (:name (slot-unbound :struct-a))
  48   (setf *slot-unbounds* nil)
  49   (let ((struct-a (make-struct-a)))
  50     (declare (optimize safety))
  51     (assert (eql (slot-value struct-a 'boxed) 0))
  52     (assert (eql (slot-value struct-a 'raw) 0.0d0))
  53     (assert (eql (slot-value struct-a 'unboundable) 42))
  54     (assert (equal *slot-unbounds* '((struct-a . unboundable))))))
  55
  56 (with-test (:name (slot-unbound :condition-a))
  57   (setf *slot-unbounds* nil)
  58   (let ((condition-a (make-condition 'condition-a)))
  59     (assert (eql (slot-value condition-a 'condition-bound) 0))
  60     (assert (eql (slot-value condition-a 'condition-unbound) 43))
  61     (assert (equal *slot-unbounds* '((condition-a . condition-unbound))))))
  62
  63 (with-test (:name (slot-unbound :class-a))
  64   (setf *slot-unbounds* nil)
  65   (let ((class-a (make-instance 'class-a)))
  66     (assert (eql (slot-value class-a 'class-bound) 0))
  67     (assert (eql (slot-value class-a 'class-unbound) 44))
  68     (assert (equal *slot-unbounds* '((class-a . class-unbound))))))