slot-value.lsp 4.14 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 10 16:16:59 2003
;;;; Contains: Tests of SLOT-VALUE

(in-package :cl-test)

;;; SLOT-VALUE is used extensively elsewhere.

(defclass slot-value-class-01 ()
  (a
   (b :type t)
   (c :type fixnum)
   (d :type float)
   (e :type symbol)
   (f :type short-float)
   (g :type single-float)
   (h :type double-float)
   (i :type long-float)
   (j :type rational)
   (k :type ratio)
   (l :type cons)
   (m :type string)
   (n :type vector)
   (o :type bit)
   ))

(defparameter *slot-value-test-slot-names*
  '(a b c d e f g h i j k l m n o))

(defparameter *slot-value-test-slot-values*
  '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0
      5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1))

(deftest slot-value.1
  (let ((obj (make-instance 'slot-value-class-01))
sds's avatar
sds committed
37 38
        (slot-names *slot-value-test-slot-names*)
        (slot-values *slot-value-test-slot-values*))
39
    (loop for name in slot-names
sds's avatar
sds committed
40 41 42 43 44 45 46 47
          for val in slot-values
          unless (and (equal (multiple-value-list
                              (setf (slot-value obj name) val))
                             (list val))
                      (equal (multiple-value-list
                              (slot-value obj name))
                             (list val)))
          collect name))
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
  nil)

(defclass slot-value-class-02 (slot-value-class-01)
  ((a :allocation :class)
   (b :allocation :class)
   (c :allocation :class)
   (d :allocation :class)
   (e :allocation :class)
   (f :allocation :class)
   (g :allocation :class)
   (h :allocation :class)
   (i :allocation :class)
   (j :allocation :class)
   (k :allocation :class)
   (l :allocation :class)
   (m :allocation :class)
   (n :allocation :class)
   (o :allocation :class)))

(deftest slot-value.2
  (let ((obj (make-instance 'slot-value-class-02))
sds's avatar
sds committed
69 70
        (slot-names *slot-value-test-slot-names*)
        (slot-values *slot-value-test-slot-values*))
71
    (loop for name in slot-names
sds's avatar
sds committed
72 73 74 75 76 77 78 79
          for val in slot-values
          unless (and (equal (multiple-value-list
                              (setf (slot-value obj name) val))
                             (list val))
                      (equal (multiple-value-list
                              (slot-value obj name))
                             (list val)))
          collect name))
80 81
  nil)

82 83 84 85
;;; Order of evaluation test(s)

(deftest slot-value.order.1
  (let ((obj (make-instance 'slot-value-class-01))
sds's avatar
sds committed
86
        (i 0) x y)
87 88 89
    (values
     (setf (slot-value obj 'a) t)
     (slot-value (progn (setf x (incf i)) obj)
sds's avatar
sds committed
90
                 (progn (setf y (incf i)) 'a))
91 92 93 94 95
     i x y))
  t t 2 1 2)

(deftest slot-value.order.2
  (let ((obj (make-instance 'slot-value-class-01))
sds's avatar
sds committed
96
        (i 0) x y)
97 98
    (values
     (setf (slot-value (progn (setf x (incf i)) obj)
sds's avatar
sds committed
99 100
                       (progn (setf y (incf i)) 'b))
           t)
101 102 103
     (slot-value obj 'b)
     i x y))
  t t 2 1 2)
104 105 106 107

;;; Error tests

(deftest slot-value.error.1
108 109
  (signals-error (slot-value) program-error)
  t)
110 111

(deftest slot-value.error.2
112
  (signals-error (slot-value (make-instance 'slot-value-class-01))
sds's avatar
sds committed
113
                 program-error)
114
  t)
115 116

(deftest slot-value.error.3
117
  (signals-error
118 119
   (let ((obj (make-instance 'slot-value-class-01)))
     (setf (slot-value obj 'a) t)
120 121 122
     (slot-value obj 'a nil))
   program-error)
  t)
123 124 125 126

(deftest slot-value.error.4
  (handler-case
   (progn (slot-value (make-instance 'slot-value-class-01) (gensym))
sds's avatar
sds committed
127
          :bad)
128 129 130 131 132
   (error () :good))
  :good)

(deftest slot-value.error.5
  (let ((built-in-class (find-class 'built-in-class))
sds's avatar
sds committed
133
        (slot-name (gensym)))
134 135
    (check-predicate
     #'(lambda (e)
sds's avatar
sds committed
136 137 138 139
         (let ((class (class-of e)))
           (or (not (eq (class-of class) built-in-class))
               (handler-case (progn (slot-value e slot-name) nil)
                             (error () t)))))))
140 141 142 143
  nil)

(deftest slot-value.error.6
  (let ((built-in-class (find-class 'built-in-class))
sds's avatar
sds committed
144
        (slot-name (gensym)))
145 146
    (check-predicate
     #'(lambda (e)
sds's avatar
sds committed
147 148 149 150
         (let ((class (class-of e)))
           (or (not (eq (class-of class) built-in-class))
               (handler-case (setf (slot-value e slot-name) nil)
                                  (error () t)))))))
151
  nil)