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

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

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

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 t))
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.