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)