source: trunk/source/tests/ansi-tests/with-slots.lsp @ 8991

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

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

File size: 4.3 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 17 18:04:10 2003
4;;;; Contains: Tests of WITH-SLOTS
5
6(in-package :cl-test)
7
8(deftest with-slots.1
9  (with-slots () nil)
10  nil)
11
12(deftest with-slots.2
13  (with-slots () nil (values)))
14
15(deftest with-slots.3
16  (with-slots () nil (values 'a 'b 'c 'd 'e 'f))
17  a b c d e f)
18
19(deftest with-slots.4
20  (let ((x 0) (y 10) (z 20))
21    (values
22     x y z
23     (with-slots () (incf x) (incf y 3) (incf z 100))
24     x y z))
25  0 10 20
26  120
27  1 13 120)
28
29;;; with-slots is an implicit progn, not a tagbody
30
31(deftest with-slots.5
32  (block done
33    (tagbody
34     (with-slots () nil
35                 (go 10)
36                 10
37                 (return-from done :bad))
38     10
39     (return-from done :good)))
40  :good)
41
42;;; with-slots has no implicit block
43(deftest with-slots.6
44  (block nil
45    (with-slots () nil (return :good))
46    (return :bad))
47  :good)
48
49
50;;; Tests on standard objects
51
52(defclass with-slots-class-01 () ((a :initarg :a)
53                                  (b :initarg :b)
54                                  (c :initarg :c)))
55
56(deftest with-slots.7
57  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
58    (with-slots (a b c) obj (values a b c)))
59  x y z)
60
61(deftest with-slots.8
62  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
63    (with-slots
64     (a b c) obj
65     (values (setf a 'p) (setf b 'q) (setf c 'r)
66             (map-slot-value obj '(a b c)))))
67  p q r (p q r))
68
69(deftest with-slots.9
70  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
71    (with-slots
72     (a b c) obj
73     (values (setq a 'p) (setq b 'q) (setq c 'r)
74             (map-slot-value obj '(a b c)))))
75  p q r (p q r))
76
77(deftest with-slots.10
78  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
79    (with-slots ((a2 a) (b2 b) (c2 c)) obj (values a2 b2 c2)))
80  x y z)
81
82(deftest with-slots.11
83  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
84    (with-slots
85     ((a2 a) (b2 b) (c2 c)) obj
86     (values (setf a2 'p) (setf b2 'q) (setf c2 'r)
87             (map-slot-value obj '(a b c)))))
88  p q r (p q r))
89
90(deftest with-slots.12
91  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
92    (with-slots
93     ((a2 a) (b2 b) (c2 c)) obj
94     (values (setq a2 'p) (setq b2 'q) (setq c2 'r)
95             (map-slot-value obj '(a b c)))))
96  p q r (p q r))
97
98(deftest with-slots.13
99  (let ((obj (make-instance 'with-slots-class-01)))
100    (with-slots
101     (a b c) obj
102     (values (setf a 'p) (setf b 'q) (setf c 'r)
103             (map-slot-value obj '(a b c)))))
104  p q r (p q r))
105
106(deftest with-slots.14
107  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
108    (with-slots (a b c) obj
109                (let ((obj (make-instance 'with-slots-class-01
110                                          :a 'bad :b 'bad :c 'bad)))
111                  (values a b c))))
112  1 2 3)
113
114
115(deftest with-slots.15
116  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)))
117    (with-slots (a b c) obj
118                (with-slots
119                 ((a2 a) (b2 b) (c2 c))
120                 (make-instance 'with-slots-class-01
121                                :a 'bad :b 'bad :c 'bad)
122                 (values a b c))))
123  1 2 3)
124
125(deftest with-slots.16
126  (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad)))
127    (with-slots (a b c) obj
128                (with-slots
129                 (a b c)
130                 (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3)
131                 (values a b c))))
132  1 2 3)
133
134
135(deftest with-slots.17
136  (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad)))
137    (with-slots (a b) obj
138                (with-slots
139                 (c)
140                 (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3)
141                 (values a b c))))
142  1 2 3)
143
144;;; If slot is unbound, act as if slot-value had been called
145
146(defmethod slot-unbound ((class t)
147                         (instance with-slots-class-01)
148                         slot-name)
149  'missing)
150
151(deftest with-slots.18
152  (let ((obj (make-instance 'with-slots-class-01)))
153    (with-slots (a b c) obj (values a b c)))
154  missing missing missing)
155
156(deftest with-slots.19
157  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
158    (with-slots (a b c) obj
159                (declare (optimize (speed 3) (safety 3)))
160                (values a b c)))
161  x y z)
162
163(deftest with-slots.20
164  (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z)))
165    (with-slots (a b c) obj
166                (declare (optimize (speed 3) (safety 3)))
167                (declare (special *x*))
168                (values a b c)))
169  x y z)
170
171;;; Free declaration scope test
172
173(deftest with-slots.21
174  (block done
175    (let ((x :bad))
176      (declare (special x))
177      (let ((x :good))
178        (with-slots nil (return-from done x)
179                    (declare (special x))))))
180  :good)
Note: See TracBrowser for help on using the repository browser.