source: trunk/source/tests/ansi-tests/slot-value.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 3.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 10 16:16:59 2003
4;;;; Contains: Tests of SLOT-VALUE
5
6(in-package :cl-test)
7
8;;; SLOT-VALUE is used extensively elsewhere.
9
10(defclass slot-value-class-01 ()
11  (a
12   (b :type t)
13   (c :type fixnum)
14   (d :type float)
15   (e :type symbol)
16   (f :type short-float)
17   (g :type single-float)
18   (h :type double-float)
19   (i :type long-float)
20   (j :type rational)
21   (k :type ratio)
22   (l :type cons)
23   (m :type string)
24   (n :type vector)
25   (o :type bit)
26   ))
27
28(defparameter *slot-value-test-slot-names*
29  '(a b c d e f g h i j k l m n o))
30
31(defparameter *slot-value-test-slot-values*
32  '(t nil 10 4.0 a 1.0s0 2.0f0 3.0d0 4.0l0
33      5/4 2/3 (a . b) "abcd" #(1 2 3 4) 1))
34
35(deftest slot-value.1
36  (let ((obj (make-instance 'slot-value-class-01))
37        (slot-names *slot-value-test-slot-names*)
38        (slot-values *slot-value-test-slot-values*))
39    (loop for name in slot-names
40          for val in slot-values
41          unless (and (equal (multiple-value-list
42                              (setf (slot-value obj name) val))
43                             (list val))
44                      (equal (multiple-value-list
45                              (slot-value obj name))
46                             (list val)))
47          collect name))
48  nil)
49
50(defclass slot-value-class-02 (slot-value-class-01)
51  ((a :allocation :class)
52   (b :allocation :class)
53   (c :allocation :class)
54   (d :allocation :class)
55   (e :allocation :class)
56   (f :allocation :class)
57   (g :allocation :class)
58   (h :allocation :class)
59   (i :allocation :class)
60   (j :allocation :class)
61   (k :allocation :class)
62   (l :allocation :class)
63   (m :allocation :class)
64   (n :allocation :class)
65   (o :allocation :class)))
66
67(deftest slot-value.2
68  (let ((obj (make-instance 'slot-value-class-02))
69        (slot-names *slot-value-test-slot-names*)
70        (slot-values *slot-value-test-slot-values*))
71    (loop for name in slot-names
72          for val in slot-values
73          unless (and (equal (multiple-value-list
74                              (setf (slot-value obj name) val))
75                             (list val))
76                      (equal (multiple-value-list
77                              (slot-value obj name))
78                             (list val)))
79          collect name))
80  nil)
81
82;;; Order of evaluation test(s)
83
84(deftest slot-value.order.1
85  (let ((obj (make-instance 'slot-value-class-01))
86        (i 0) x y)
87    (values
88     (setf (slot-value obj 'a) t)
89     (slot-value (progn (setf x (incf i)) obj)
90                 (progn (setf y (incf i)) 'a))
91     i x y))
92  t t 2 1 2)
93
94(deftest slot-value.order.2
95  (let ((obj (make-instance 'slot-value-class-01))
96        (i 0) x y)
97    (values
98     (setf (slot-value (progn (setf x (incf i)) obj)
99                       (progn (setf y (incf i)) 'b))
100           t)
101     (slot-value obj 'b)
102     i x y))
103  t t 2 1 2)
104
105;;; Error tests
106
107(deftest slot-value.error.1
108  (signals-error (slot-value) program-error)
109  t)
110
111(deftest slot-value.error.2
112  (signals-error (slot-value (make-instance 'slot-value-class-01))
113                 program-error)
114  t)
115
116(deftest slot-value.error.3
117  (signals-error
118   (let ((obj (make-instance 'slot-value-class-01)))
119     (setf (slot-value obj 'a) t)
120     (slot-value obj 'a nil))
121   program-error)
122  t)
123
124(deftest slot-value.error.4
125  (handler-case
126   (progn (slot-value (make-instance 'slot-value-class-01) (gensym))
127          :bad)
128   (error () :good))
129  :good)
130
131(deftest slot-value.error.5
132  (let ((built-in-class (find-class 'built-in-class))
133        (slot-name (gensym)))
134    (check-predicate
135     #'(lambda (e)
136         (let ((class (class-of e)))
137           (or (not (eq (class-of class) built-in-class))
138               (handler-case (progn (slot-value e slot-name) nil)
139                             (error () t)))))))
140  nil)
141
142(deftest slot-value.error.6
143  (let ((built-in-class (find-class 'built-in-class))
144        (slot-name (gensym)))
145    (check-predicate
146     #'(lambda (e)
147         (let ((class (class-of e)))
148           (or (not (eq (class-of class) built-in-class))
149               (handler-case (setf (slot-value e slot-name) nil)
150                                  (error () t)))))))
151  nil)
Note: See TracBrowser for help on using the repository browser.