7 |
|
|
8 |
;;; |
;;; |
9 |
|
|
10 |
(define-condition-with-tests cond-1 nil nil) |
(define-condition-with-tests condition-1 nil nil) |
11 |
|
|
12 |
(define-condition-with-tests cond-2 (condition) nil) |
(define-condition-with-tests condition-2 (condition) nil) |
13 |
|
|
14 |
#-gcl (define-condition-with-tests #:cond-3 nil nil) |
#-gcl (define-condition-with-tests #:condition-3 nil nil) |
15 |
|
|
16 |
(define-condition-with-tests cond-4 nil |
(define-condition-with-tests condition-4 nil |
17 |
((slot1 :initarg :slot1 :reader cond-4/slot-1) |
((slot1 :initarg :slot1 :reader condition-4/slot-1) |
18 |
(slot2 :initarg :slot2 :reader cond-4/slot-2))) |
(slot2 :initarg :slot2 :reader condition-4/slot-2))) |
19 |
|
|
20 |
(deftest cond-4-slots.1 |
(deftest condition-4-slots.1 |
21 |
(let ((c (make-condition 'cond-4 :slot1 'a :slot2 'b))) |
(let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b))) |
22 |
(and (typep c 'cond-4) |
(and (typep c 'condition-4) |
23 |
(eqt (cond-4/slot-1 c) 'a) |
(eqt (condition-4/slot-1 c) 'a) |
24 |
(eqt (cond-4/slot-2 c) 'b))) |
(eqt (condition-4/slot-2 c) 'b))) |
25 |
t) |
t) |
26 |
|
|
27 |
(define-condition-with-tests cond-5 nil |
(define-condition-with-tests condition-5 nil |
28 |
((slot1 :initarg :slot1 :initform 'x :reader cond-5/slot-1) |
((slot1 :initarg :slot1 :initform 'x :reader condition-5/slot-1) |
29 |
(slot2 :initarg :slot2 :initform 'y :reader cond-5/slot-2))) |
(slot2 :initarg :slot2 :initform 'y :reader condition-5/slot-2))) |
30 |
|
|
31 |
(deftest cond-5-slots.1 |
(deftest condition-5-slots.1 |
32 |
(let ((c (make-condition 'cond-5 :slot1 'a :slot2 'b))) |
(let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b))) |
33 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
34 |
(eqt (cond-5/slot-1 c) 'a) |
(eqt (condition-5/slot-1 c) 'a) |
35 |
(eqt (cond-5/slot-2 c) 'b))) |
(eqt (condition-5/slot-2 c) 'b))) |
36 |
t) |
t) |
37 |
|
|
38 |
(deftest cond-5-slots.2 |
(deftest condition-5-slots.2 |
39 |
(let ((c (make-condition 'cond-5 :slot1 'a))) |
(let ((c (make-condition 'condition-5 :slot1 'a))) |
40 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
41 |
(eqt (cond-5/slot-1 c) 'a) |
(eqt (condition-5/slot-1 c) 'a) |
42 |
(eqt (cond-5/slot-2 c) 'y))) |
(eqt (condition-5/slot-2 c) 'y))) |
43 |
t) |
t) |
44 |
|
|
45 |
(deftest cond-5-slots.3 |
(deftest condition-5-slots.3 |
46 |
(let ((c (make-condition 'cond-5 :slot2 'b))) |
(let ((c (make-condition 'condition-5 :slot2 'b))) |
47 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
48 |
(eqt (cond-5/slot-1 c) 'x) |
(eqt (condition-5/slot-1 c) 'x) |
49 |
(eqt (cond-5/slot-2 c) 'b))) |
(eqt (condition-5/slot-2 c) 'b))) |
50 |
t) |
t) |
51 |
|
|
52 |
(deftest cond-5-slots.4 |
(deftest condition-5-slots.4 |
53 |
(let ((c (make-condition 'cond-5))) |
(let ((c (make-condition 'condition-5))) |
54 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
55 |
(eqt (cond-5/slot-1 c) 'x) |
(eqt (condition-5/slot-1 c) 'x) |
56 |
(eqt (cond-5/slot-2 c) 'y))) |
(eqt (condition-5/slot-2 c) 'y))) |
57 |
t) |
t) |
58 |
|
|
59 |
(define-condition-with-tests cond-6 nil |
(define-condition-with-tests condition-6 nil |
60 |
((slot1 :initarg :slot1 :initarg :both-slots |
((slot1 :initarg :slot1 :initarg :both-slots |
61 |
:initform 'x :reader cond-6/slot-1) |
:initform 'x :reader condition-6/slot-1) |
62 |
(slot2 :initarg :slot2 :initarg :both-slots |
(slot2 :initarg :slot2 :initarg :both-slots |
63 |
:initform 'y :reader cond-6/slot-2))) |
:initform 'y :reader condition-6/slot-2))) |
64 |
|
|
65 |
(deftest cond-6-slots.1 |
(deftest condition-6-slots.1 |
66 |
(let ((c (make-condition 'cond-6 :both-slots 'a))) |
(let ((c (make-condition 'condition-6 :both-slots 'a))) |
67 |
(and (typep c 'cond-6) |
(and (typep c 'condition-6) |
68 |
(eqt (cond-6/slot-1 c) 'a) |
(eqt (condition-6/slot-1 c) 'a) |
69 |
(eqt (cond-6/slot-2 c) 'a))) |
(eqt (condition-6/slot-2 c) 'a))) |
70 |
t) |
t) |
71 |
|
|
72 |
(deftest cond-6-slots.2 |
(deftest condition-6-slots.2 |
73 |
(let ((c (make-condition 'cond-6))) |
(let ((c (make-condition 'condition-6))) |
74 |
(and (typep c 'cond-6) |
(and (typep c 'condition-6) |
75 |
(eqt (cond-6/slot-1 c) 'x) |
(eqt (condition-6/slot-1 c) 'x) |
76 |
(eqt (cond-6/slot-2 c) 'y))) |
(eqt (condition-6/slot-2 c) 'y))) |
77 |
t) |
t) |
78 |
|
|
79 |
(deftest cond-6-slots.3 |
(deftest condition-6-slots.3 |
80 |
(let ((c (make-condition 'cond-6 :slot1 'a :both-slots 'b))) |
(let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b))) |
81 |
(and (typep c 'cond-6) |
(and (typep c 'condition-6) |
82 |
(eqt (cond-6/slot-1 c) 'a) |
(eqt (condition-6/slot-1 c) 'a) |
83 |
(eqt (cond-6/slot-2 c) 'b))) |
(eqt (condition-6/slot-2 c) 'b))) |
84 |
t) |
t) |
85 |
|
|
86 |
(deftest cond-6-slots.4 |
(deftest condition-6-slots.4 |
87 |
(let ((c (make-condition 'cond-6 :slot2 'b :both-slots 'a))) |
(let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a))) |
88 |
(and (typep c 'cond-6) |
(and (typep c 'condition-6) |
89 |
(eqt (cond-6/slot-1 c) 'a) |
(eqt (condition-6/slot-1 c) 'a) |
90 |
(eqt (cond-6/slot-2 c) 'b))) |
(eqt (condition-6/slot-2 c) 'b))) |
91 |
t) |
t) |
92 |
|
|
93 |
(deftest cond-6-slots.5 |
(deftest condition-6-slots.5 |
94 |
(let ((c (make-condition 'cond-6 :both-slots 'a :slot1 'c :slot2 'd))) |
(let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd))) |
95 |
(and (typep c 'cond-6) |
(and (typep c 'condition-6) |
96 |
(eqt (cond-6/slot-1 c) 'a) |
(eqt (condition-6/slot-1 c) 'a) |
97 |
(eqt (cond-6/slot-2 c) 'a))) |
(eqt (condition-6/slot-2 c) 'a))) |
98 |
t) |
t) |
99 |
|
|
100 |
(define-condition-with-tests cond-7 nil |
(define-condition-with-tests condition-7 nil |
101 |
((s :initarg :i1 :initarg :i2 :reader cond-7/s))) |
((s :initarg :i1 :initarg :i2 :reader condition-7/s))) |
102 |
|
|
103 |
(deftest cond-7-slots.1 |
(deftest condition-7-slots.1 |
104 |
(let ((c (make-condition 'cond-7 :i1 'a))) |
(let ((c (make-condition 'condition-7 :i1 'a))) |
105 |
(and (typep c 'cond-7) |
(and (typep c 'condition-7) |
106 |
(eqt (cond-7/s c) 'a))) |
(eqt (condition-7/s c) 'a))) |
107 |
t) |
t) |
108 |
|
|
109 |
(deftest cond-7-slots.2 |
(deftest condition-7-slots.2 |
110 |
(let ((c (make-condition 'cond-7 :i2 'a))) |
(let ((c (make-condition 'condition-7 :i2 'a))) |
111 |
(and (typep c 'cond-7) |
(and (typep c 'condition-7) |
112 |
(eqt (cond-7/s c) 'a))) |
(eqt (condition-7/s c) 'a))) |
113 |
t) |
t) |
114 |
|
|
115 |
(deftest cond-7-slots.3 |
(deftest condition-7-slots.3 |
116 |
(let ((c (make-condition 'cond-7 :i1 'a :i2 'b))) |
(let ((c (make-condition 'condition-7 :i1 'a :i2 'b))) |
117 |
(and (typep c 'cond-7) |
(and (typep c 'condition-7) |
118 |
(eqt (cond-7/s c) 'a))) |
(eqt (condition-7/s c) 'a))) |
119 |
t) |
t) |
120 |
|
|
121 |
(deftest cond-7-slots.4 |
(deftest condition-7-slots.4 |
122 |
(let ((c (make-condition 'cond-7 :i2 'a :i1 'b))) |
(let ((c (make-condition 'condition-7 :i2 'a :i1 'b))) |
123 |
(and (typep c 'cond-7) |
(and (typep c 'condition-7) |
124 |
(eqt (cond-7/s c) 'a))) |
(eqt (condition-7/s c) 'a))) |
125 |
t) |
t) |
126 |
|
|
127 |
(defparameter *cond-8-counter* 0) |
(defparameter *condition-8-counter* 0) |
128 |
|
|
129 |
(define-condition-with-tests cond-8 nil |
(define-condition-with-tests condition-8 nil |
130 |
((s :initarg :i1 :initform (incf *cond-8-counter*) :reader cond-8/s))) |
((s :initarg :i1 :initform (incf *condition-8-counter*) :reader condition-8/s))) |
131 |
|
|
132 |
(deftest cond-8-slots.1 |
(deftest condition-8-slots.1 |
133 |
(let ((*cond-8-counter* 100)) |
(let ((*condition-8-counter* 100)) |
134 |
(declare (special *cond-8-counter*)) |
(declare (special *condition-8-counter*)) |
135 |
(values |
(values |
136 |
(cond-8/s (make-condition 'cond-8)) |
(condition-8/s (make-condition 'condition-8)) |
137 |
*cond-8-counter*)) |
*condition-8-counter*)) |
138 |
101 101) |
101 101) |
139 |
|
|
140 |
(define-condition-with-tests cond-9 nil |
(define-condition-with-tests condition-9 nil |
141 |
((s1 :initarg :i1 :initform 15 :reader cond-9/s1) |
((s1 :initarg :i1 :initform 15 :reader condition-9/s1) |
142 |
(s2 :initarg :i2 :initform 37 :reader cond-9/s2))) |
(s2 :initarg :i2 :initform 37 :reader condition-9/s2))) |
143 |
|
|
144 |
(deftest cond-9-slots.1 |
(deftest condition-9-slots.1 |
145 |
(let ((c (make-condition 'cond-9))) |
(let ((c (make-condition 'condition-9))) |
146 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
147 |
(cond-9/s1 c) |
(condition-9/s1 c) |
148 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
149 |
t 15 37) |
t 15 37) |
150 |
|
|
151 |
(deftest cond-9-slots.2 |
(deftest condition-9-slots.2 |
152 |
(let ((c (make-condition 'cond-9 :i1 3))) |
(let ((c (make-condition 'condition-9 :i1 3))) |
153 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
154 |
(cond-9/s1 c) |
(condition-9/s1 c) |
155 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
156 |
t 3 37) |
t 3 37) |
157 |
|
|
158 |
(deftest cond-9-slots.3 |
(deftest condition-9-slots.3 |
159 |
(let ((c (make-condition 'cond-9 :i2 3))) |
(let ((c (make-condition 'condition-9 :i2 3))) |
160 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
161 |
(cond-9/s1 c) |
(condition-9/s1 c) |
162 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
163 |
t 15 3) |
t 15 3) |
164 |
|
|
165 |
(deftest cond-9-slots.4 |
(deftest condition-9-slots.4 |
166 |
(let ((c (make-condition 'cond-9 :i2 3 :i2 8))) |
(let ((c (make-condition 'condition-9 :i2 3 :i2 8))) |
167 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
168 |
(cond-9/s1 c) |
(condition-9/s1 c) |
169 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
170 |
t 15 3) |
t 15 3) |
171 |
|
|
172 |
(deftest cond-9-slots.5 |
(deftest condition-9-slots.5 |
173 |
(let ((c (make-condition 'cond-9 :i1 3 :i2 8))) |
(let ((c (make-condition 'condition-9 :i1 3 :i2 8))) |
174 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
175 |
(cond-9/s1 c) |
(condition-9/s1 c) |
176 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
177 |
t 3 8) |
t 3 8) |
178 |
|
|
179 |
(deftest cond-9-slots.6 |
(deftest condition-9-slots.6 |
180 |
(let ((c (make-condition 'cond-9 :i1 3 :i2 8 :i1 100 :i2 500))) |
(let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500))) |
181 |
(values (notnot (typep c 'cond-9)) |
(values (notnot (typep c 'condition-9)) |
182 |
(cond-9/s1 c) |
(condition-9/s1 c) |
183 |
(cond-9/s2 c))) |
(condition-9/s2 c))) |
184 |
t 3 8) |
t 3 8) |
185 |
|
|
186 |
;;; (define-condition-with-tests cond-10 nil |
;;; (define-condition-with-tests condition-10 nil |
187 |
;;; ((s1 :initarg :i1 :writer cond-10/s1-w :reader cond-10/s1-r))) |
;;; ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r))) |
188 |
;;; |
;;; |
189 |
;;; (deftest cond-10-slots.1 |
;;; (deftest condition-10-slots.1 |
190 |
;;; (let ((c (make-condition 'cond-10 :i1 11))) |
;;; (let ((c (make-condition 'condition-10 :i1 11))) |
191 |
;;; (cond-10/s1-r c)) |
;;; (condition-10/s1-r c)) |
192 |
;;; 11) |
;;; 11) |
193 |
;;; |
;;; |
194 |
;;; (deftest cond-10-slots.2 |
;;; (deftest condition-10-slots.2 |
195 |
;;; (let ((c (make-condition 'cond-10 :i1 11))) |
;;; (let ((c (make-condition 'condition-10 :i1 11))) |
196 |
;;; (cond-10/s1-w 17 c)) |
;;; (condition-10/s1-w 17 c)) |
197 |
;;; 17) |
;;; 17) |
198 |
;;; |
;;; |
199 |
;;; (deftest cond-10-slots.3 |
;;; (deftest condition-10-slots.3 |
200 |
;;; (let ((c (make-condition 'cond-10 :i1 11))) |
;;; (let ((c (make-condition 'condition-10 :i1 11))) |
201 |
;;; (cond-10/s1-w 107 c) |
;;; (condition-10/s1-w 107 c) |
202 |
;;; (cond-10/s1-r c)) |
;;; (condition-10/s1-r c)) |
203 |
;;; 107) |
;;; 107) |
204 |
;;; |
;;; |
205 |
;;; (define-condition-with-tests cond-11 nil |
;;; (define-condition-with-tests condition-11 nil |
206 |
;;; ((s1 :initarg :i1 :writer (setf cond-11/w) :reader cond-11/r))) |
;;; ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r))) |
207 |
;;; |
;;; |
208 |
;;; (deftest cond-11-slots.1 |
;;; (deftest condition-11-slots.1 |
209 |
;;; (let ((c (make-condition 'cond-11 :i1 11))) |
;;; (let ((c (make-condition 'condition-11 :i1 11))) |
210 |
;;; (cond-11/r c)) |
;;; (condition-11/r c)) |
211 |
;;; 11) |
;;; 11) |
212 |
;;; |
;;; |
213 |
;;; (deftest cond-11-slots.2 |
;;; (deftest condition-11-slots.2 |
214 |
;;; (let ((c (make-condition 'cond-11 :i1 11))) |
;;; (let ((c (make-condition 'condition-11 :i1 11))) |
215 |
;;; (setf (cond-11/w c) 17)) |
;;; (setf (condition-11/w c) 17)) |
216 |
;;; 17) |
;;; 17) |
217 |
;;; |
;;; |
218 |
;;; (deftest cond-11-slots.3 |
;;; (deftest condition-11-slots.3 |
219 |
;;; (let ((c (make-condition 'cond-11 :i1 11))) |
;;; (let ((c (make-condition 'condition-11 :i1 11))) |
220 |
;;; (setf (cond-11/w c) 117) |
;;; (setf (condition-11/w c) 117) |
221 |
;;; (cond-11/r c)) |
;;; (condition-11/r c)) |
222 |
;;; 117) |
;;; 117) |
223 |
;;; |
;;; |
224 |
;;; (deftest cond-11-slots.4 |
;;; (deftest condition-11-slots.4 |
225 |
;;; (let ((c (make-condition 'cond-11 :i1 11))) |
;;; (let ((c (make-condition 'condition-11 :i1 11))) |
226 |
;;; (values |
;;; (values |
227 |
;;; (funcall #'(setf cond-11/w) 117 c) |
;;; (funcall #'(setf condition-11/w) 117 c) |
228 |
;;; (cond-11/r c))) |
;;; (condition-11/r c))) |
229 |
;;; 117 117) |
;;; 117 117) |
230 |
|
|
231 |
;;; The cond-12 and cond-13 tests have been removed. Duane Rettig |
;;; The condition-12 and condition-13 tests have been removed. Duane Rettig |
232 |
;;; convincingly argued that the feature being tested (non-symbol |
;;; convincingly argued that the feature being tested (non-symbol |
233 |
;;; slot names) remains in the standard only because of editing errors. |
;;; slot names) remains in the standard only because of editing errors. |
234 |
|
|
235 |
;;; (define-condition-with-tests cond-12 nil |
;;; (define-condition-with-tests condition-12 nil |
236 |
;;; (((slot1) :initarg :slot1 :reader cond-12/slot-1) |
;;; (((slot1) :initarg :slot1 :reader condition-12/slot-1) |
237 |
;;; ((slot2) :initarg :slot2 :reader cond-12/slot-2))) |
;;; ((slot2) :initarg :slot2 :reader condition-12/slot-2))) |
238 |
;;; |
;;; |
239 |
;;; (deftest cond-12-slots.1 |
;;; (deftest condition-12-slots.1 |
240 |
;;; (let ((c (make-condition 'cond-12 :slot1 'a :slot2 'b))) |
;;; (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b))) |
241 |
;;; (and (typep c 'cond-12) |
;;; (and (typep c 'condition-12) |
242 |
;;; (eqt (cond-12/slot-1 c) 'a) |
;;; (eqt (condition-12/slot-1 c) 'a) |
243 |
;;; (eqt (cond-12/slot-2 c) 'b))) |
;;; (eqt (condition-12/slot-2 c) 'b))) |
244 |
;;; t) |
;;; t) |
245 |
;;; |
;;; |
246 |
;;; (define-condition-with-tests cond-13 nil |
;;; (define-condition-with-tests condition-13 nil |
247 |
;;; (((slot1 10) :initarg :slot1 :reader cond-13/slot-1))) |
;;; (((slot1 10) :initarg :slot1 :reader condition-13/slot-1))) |
248 |
;;; |
;;; |
249 |
;;; (deftest cond-13-slots.1 |
;;; (deftest condition-13-slots.1 |
250 |
;;; (let ((c (make-condition 'cond-13))) |
;;; (let ((c (make-condition 'condition-13))) |
251 |
;;; (and (typep c 'cond-13) |
;;; (and (typep c 'condition-13) |
252 |
;;; (cond-13/slot-1 c))) |
;;; (condition-13/slot-1 c))) |
253 |
;;; 10) |
;;; 10) |
254 |
|
|
255 |
(define-condition-with-tests cond-14 nil |
(define-condition-with-tests condition-14 nil |
256 |
((s1 :initarg :i1 :type fixnum :reader cond-14/s1) |
((s1 :initarg :i1 :type fixnum :reader condition-14/s1) |
257 |
(s2 :initarg :i2 :type t :reader cond-14/s2))) |
(s2 :initarg :i2 :type t :reader condition-14/s2))) |
258 |
|
|
259 |
(deftest cond-14-slots.1 |
(deftest condition-14-slots.1 |
260 |
(let ((c (make-condition 'cond-14 :i1 10))) |
(let ((c (make-condition 'condition-14 :i1 10))) |
261 |
(and (typep c 'cond-14) |
(and (typep c 'condition-14) |
262 |
(cond-14/s1 c))) |
(condition-14/s1 c))) |
263 |
10) |
10) |
264 |
|
|
265 |
(deftest cond-14-slots.2 |
(deftest condition-14-slots.2 |
266 |
(let ((c (make-condition 'cond-14 :i2 'a))) |
(let ((c (make-condition 'condition-14 :i2 'a))) |
267 |
(and (typep c 'cond-14) |
(and (typep c 'condition-14) |
268 |
(cond-14/s2 c))) |
(condition-14/s2 c))) |
269 |
a) |
a) |
270 |
|
|
271 |
(deftest cond-14-slots.3 |
(deftest condition-14-slots.3 |
272 |
(let ((c (make-condition 'cond-14 :i1 10 :i2 'h))) |
(let ((c (make-condition 'condition-14 :i1 10 :i2 'h))) |
273 |
(and (typep c 'cond-14) |
(and (typep c 'condition-14) |
274 |
(eqt (cond-14/s1 c) 10) |
(eqt (condition-14/s1 c) 10) |
275 |
(cond-14/s2 c))) |
(condition-14/s2 c))) |
276 |
h) |
h) |
277 |
|
|
278 |
(define-condition-with-tests cond-15 nil |
(define-condition-with-tests condition-15 nil |
279 |
((s1 :type nil))) |
((s1 :type nil))) |
280 |
|
|
281 |
(define-condition-with-tests cond-16 nil |
(define-condition-with-tests condition-16 nil |
282 |
((slot1)) |
((slot1)) |
283 |
(:report "The report for cond-16")) |
(:report "The report for condition-16")) |
284 |
|
|
285 |
(deftest cond-16-report.1 |
(deftest condition-16-report.1 |
286 |
(let ((*print-escape* nil) |
(let ((*print-escape* nil) |
287 |
(c (make-condition 'cond-16))) |
(c (make-condition 'condition-16))) |
288 |
(with-output-to-string (s) (print-object c s))) |
(with-output-to-string (s) (print-object c s))) |
289 |
"The report for cond-16") |
"The report for condition-16") |
290 |
|
|
291 |
(define-condition-with-tests cond-17 nil |
(define-condition-with-tests condition-17 nil |
292 |
((s :initarg :i1 :reader cond-17/s )) |
((s :initarg :i1 :reader condition-17/s )) |
293 |
(:report cond-17-report)) |
(:report condition-17-report)) |
294 |
|
|
295 |
(defun cond-17-report (c s) |
(defun condition-17-report (c s) |
296 |
(format s "cond-17: ~A" (cond-17/s c))) |
(format s "condition-17: ~A" (condition-17/s c))) |
297 |
|
|
298 |
(deftest cond-17-report.1 |
(deftest condition-17-report.1 |
299 |
(let ((*print-escape* nil) |
(let ((*print-escape* nil) |
300 |
(c (make-condition 'cond-17 :i1 1234))) |
(c (make-condition 'condition-17 :i1 1234))) |
301 |
(with-output-to-string (s) (print-object c s))) |
(with-output-to-string (s) (print-object c s))) |
302 |
"cond-17: 1234") |
"condition-17: 1234") |
303 |
|
|
304 |
(define-condition-with-tests cond-18 nil |
(define-condition-with-tests condition-18 nil |
305 |
((s :initarg :i1 :reader cond-18/s )) |
((s :initarg :i1 :reader condition-18/s )) |
306 |
(:report (lambda (c s) (format s "cond-18: ~A" (cond-18/s c))))) |
(:report (lambda (c s) (format s "condition-18: ~A" (condition-18/s c))))) |
307 |
|
|
308 |
(deftest cond-18-report.1 |
(deftest condition-18-report.1 |
309 |
(let ((*print-escape* nil) |
(let ((*print-escape* nil) |
310 |
(c (make-condition 'cond-18 :i1 4321))) |
(c (make-condition 'condition-18 :i1 4321))) |
311 |
(with-output-to-string (s) (print-object c s))) |
(with-output-to-string (s) (print-object c s))) |
312 |
"cond-18: 4321") |
"condition-18: 4321") |
313 |
|
|
314 |
;;; |
;;; |
315 |
;;; Tests of :default-initargs |
;;; Tests of :default-initargs |
320 |
;;; are initargs and initforms. I have taken the second interpretation. |
;;; are initargs and initforms. I have taken the second interpretation. |
321 |
;;; |
;;; |
322 |
|
|
323 |
(define-condition-with-tests cond-19 nil |
(define-condition-with-tests condition-19 nil |
324 |
((s1 :reader cond-19/s1 :initarg :i1) |
((s1 :reader condition-19/s1 :initarg :i1) |
325 |
(s2 :reader cond-19/s2 :initarg :i2)) |
(s2 :reader condition-19/s2 :initarg :i2)) |
326 |
(:default-initargs :i1 10 |
(:default-initargs :i1 10 |
327 |
:i2 20)) |
:i2 20)) |
328 |
|
|
329 |
(deftest cond-19-slots.1 |
(deftest condition-19-slots.1 |
330 |
(let ((c (make-condition 'cond-19))) |
(let ((c (make-condition 'condition-19))) |
331 |
(values |
(values |
332 |
(notnot (typep c 'cond-19)) |
(notnot (typep c 'condition-19)) |
333 |
(cond-19/s1 c) |
(condition-19/s1 c) |
334 |
(cond-19/s2 c))) |
(condition-19/s2 c))) |
335 |
t 10 20) |
t 10 20) |
336 |
|
|
337 |
(deftest cond-19-slots.2 |
(deftest condition-19-slots.2 |
338 |
(let ((c (make-condition 'cond-19 :i1 'a))) |
(let ((c (make-condition 'condition-19 :i1 'a))) |
339 |
(values |
(values |
340 |
(notnot (typep c 'cond-19)) |
(notnot (typep c 'condition-19)) |
341 |
(cond-19/s1 c) |
(condition-19/s1 c) |
342 |
(cond-19/s2 c))) |
(condition-19/s2 c))) |
343 |
t a 20) |
t a 20) |
344 |
|
|
345 |
(deftest cond-19-slots.3 |
(deftest condition-19-slots.3 |
346 |
(let ((c (make-condition 'cond-19 :i2 'a))) |
(let ((c (make-condition 'condition-19 :i2 'a))) |
347 |
(values |
(values |
348 |
(notnot (typep c 'cond-19)) |
(notnot (typep c 'condition-19)) |
349 |
(cond-19/s1 c) |
(condition-19/s1 c) |
350 |
(cond-19/s2 c))) |
(condition-19/s2 c))) |
351 |
t 10 a) |
t 10 a) |
352 |
|
|
353 |
(deftest cond-19-slots.4 |
(deftest condition-19-slots.4 |
354 |
(let ((c (make-condition 'cond-19 :i1 'x :i2 'y))) |
(let ((c (make-condition 'condition-19 :i1 'x :i2 'y))) |
355 |
(values |
(values |
356 |
(notnot (typep c 'cond-19)) |
(notnot (typep c 'condition-19)) |
357 |
(cond-19/s1 c) |
(condition-19/s1 c) |
358 |
(cond-19/s2 c))) |
(condition-19/s2 c))) |
359 |
t x y) |
t x y) |
360 |
|
|
361 |
(deftest cond-19-slots.5 |
(deftest condition-19-slots.5 |
362 |
(let ((c (make-condition 'cond-19 :i2 'y :i1 'x))) |
(let ((c (make-condition 'condition-19 :i2 'y :i1 'x))) |
363 |
(values |
(values |
364 |
(notnot (typep c 'cond-19)) |
(notnot (typep c 'condition-19)) |
365 |
(cond-19/s1 c) |
(condition-19/s1 c) |
366 |
(cond-19/s2 c))) |
(condition-19/s2 c))) |
367 |
t x y) |
t x y) |
368 |
|
|
369 |
(defparameter *cond-20/s1-val* 0) |
(defparameter *condition-20/s1-val* 0) |
370 |
(defparameter *cond-20/s2-val* 0) |
(defparameter *condition-20/s2-val* 0) |
371 |
|
|
372 |
(define-condition-with-tests cond-20 nil |
(define-condition-with-tests condition-20 nil |
373 |
((s1 :reader cond-20/s1 :initarg :i1) |
((s1 :reader condition-20/s1 :initarg :i1) |
374 |
(s2 :reader cond-20/s2 :initarg :i2)) |
(s2 :reader condition-20/s2 :initarg :i2)) |
375 |
(:default-initargs :i1 (incf *cond-20/s1-val*) |
(:default-initargs :i1 (incf *condition-20/s1-val*) |
376 |
:i2 (incf *cond-20/s2-val*))) |
:i2 (incf *condition-20/s2-val*))) |
377 |
|
|
378 |
(deftest cond-20-slots.1 |
(deftest condition-20-slots.1 |
379 |
(let ((*cond-20/s1-val* 0) |
(let ((*condition-20/s1-val* 0) |
380 |
(*cond-20/s2-val* 10)) |
(*condition-20/s2-val* 10)) |
381 |
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
(declare (special *condition-20/s1-val* *condition-20/s2-val*)) |
382 |
(let ((c (make-condition 'cond-20))) |
(let ((c (make-condition 'condition-20))) |
383 |
(values |
(values |
384 |
(notnot (typep c 'cond-20)) |
(notnot (typep c 'condition-20)) |
385 |
(cond-20/s1 c) |
(condition-20/s1 c) |
386 |
(cond-20/s2 c) |
(condition-20/s2 c) |
387 |
*cond-20/s1-val* |
*condition-20/s1-val* |
388 |
*cond-20/s2-val*))) |
*condition-20/s2-val*))) |
389 |
t 1 11 1 11) |
t 1 11 1 11) |
390 |
|
|
391 |
(deftest cond-20-slots.2 |
(deftest condition-20-slots.2 |
392 |
(let ((*cond-20/s1-val* 0) |
(let ((*condition-20/s1-val* 0) |
393 |
(*cond-20/s2-val* 10)) |
(*condition-20/s2-val* 10)) |
394 |
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
(declare (special *condition-20/s1-val* *condition-20/s2-val*)) |
395 |
(let ((c (make-condition 'cond-20 :i1 'x))) |
(let ((c (make-condition 'condition-20 :i1 'x))) |
396 |
(values |
(values |
397 |
(notnot (typep c 'cond-20)) |
(notnot (typep c 'condition-20)) |
398 |
(cond-20/s1 c) |
(condition-20/s1 c) |
399 |
(cond-20/s2 c) |
(condition-20/s2 c) |
400 |
*cond-20/s1-val* |
*condition-20/s1-val* |
401 |
*cond-20/s2-val*))) |
*condition-20/s2-val*))) |
402 |
t x 11 0 11) |
t x 11 0 11) |
403 |
|
|
404 |
(deftest cond-20-slots.3 |
(deftest condition-20-slots.3 |
405 |
(let ((*cond-20/s1-val* 0) |
(let ((*condition-20/s1-val* 0) |
406 |
(*cond-20/s2-val* 10)) |
(*condition-20/s2-val* 10)) |
407 |
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
(declare (special *condition-20/s1-val* *condition-20/s2-val*)) |
408 |
(let ((c (make-condition 'cond-20 :i2 'y))) |
(let ((c (make-condition 'condition-20 :i2 'y))) |
409 |
(values |
(values |
410 |
(notnot (typep c 'cond-20)) |
(notnot (typep c 'condition-20)) |
411 |
(cond-20/s1 c) |
(condition-20/s1 c) |
412 |
(cond-20/s2 c) |
(condition-20/s2 c) |
413 |
*cond-20/s1-val* |
*condition-20/s1-val* |
414 |
*cond-20/s2-val*))) |
*condition-20/s2-val*))) |
415 |
t 1 y 1 10) |
t 1 y 1 10) |
416 |
|
|
417 |
(deftest cond-20-slots.4 |
(deftest condition-20-slots.4 |
418 |
(let ((*cond-20/s1-val* 0) |
(let ((*condition-20/s1-val* 0) |
419 |
(*cond-20/s2-val* 10)) |
(*condition-20/s2-val* 10)) |
420 |
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
(declare (special *condition-20/s1-val* *condition-20/s2-val*)) |
421 |
(let ((c (make-condition 'cond-20 :i2 'y :i1 'x))) |
(let ((c (make-condition 'condition-20 :i2 'y :i1 'x))) |
422 |
(values |
(values |
423 |
(notnot (typep c 'cond-20)) |
(notnot (typep c 'condition-20)) |
424 |
(cond-20/s1 c) |
(condition-20/s1 c) |
425 |
(cond-20/s2 c) |
(condition-20/s2 c) |
426 |
*cond-20/s1-val* |
*condition-20/s1-val* |
427 |
*cond-20/s2-val*))) |
*condition-20/s2-val*))) |
428 |
t x y 0 10) |
t x y 0 10) |
429 |
|
|
430 |
|
|
431 |
;;;;;;;;; tests of inheritance |
;;;;;;;;; tests of inheritance |
432 |
|
|
433 |
(define-condition-with-tests cond-21 (cond-4) nil) |
(define-condition-with-tests condition-21 (condition-4) nil) |
434 |
|
|
435 |
(deftest cond-21-slots.1 |
(deftest condition-21-slots.1 |
436 |
(let ((c (make-condition 'cond-21 :slot1 'a :slot2 'b))) |
(let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b))) |
437 |
(and (typep c 'cond-4) |
(and (typep c 'condition-4) |
438 |
(typep c 'cond-21) |
(typep c 'condition-21) |
439 |
(eqt (cond-4/slot-1 c) 'a) |
(eqt (condition-4/slot-1 c) 'a) |
440 |
(eqt (cond-4/slot-2 c) 'b))) |
(eqt (condition-4/slot-2 c) 'b))) |
441 |
t) |
t) |
442 |
|
|
443 |
(define-condition-with-tests cond-22 (cond-4) |
(define-condition-with-tests condition-22 (condition-4) |
444 |
((slot3 :initarg :slot3 :reader cond-22/slot-3) |
((slot3 :initarg :slot3 :reader condition-22/slot-3) |
445 |
(slot4 :initarg :slot4 :reader cond-22/slot-4))) |
(slot4 :initarg :slot4 :reader condition-22/slot-4))) |
446 |
|
|
447 |
(deftest cond-22-slots.1 |
(deftest condition-22-slots.1 |
448 |
(let ((c (make-condition 'cond-22 :slot1 'a :slot2 'b |
(let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b |
449 |
:slot3 'c :slot4 'd))) |
:slot3 'c :slot4 'd))) |
450 |
(and (typep c 'cond-4) |
(and (typep c 'condition-4) |
451 |
(typep c 'cond-22) |
(typep c 'condition-22) |
452 |
(eqt (cond-4/slot-1 c) 'a) |
(eqt (condition-4/slot-1 c) 'a) |
453 |
(eqt (cond-4/slot-2 c) 'b) |
(eqt (condition-4/slot-2 c) 'b) |
454 |
(eqt (cond-22/slot-3 c) 'c) |
(eqt (condition-22/slot-3 c) 'c) |
455 |
(eqt (cond-22/slot-4 c) 'd) |
(eqt (condition-22/slot-4 c) 'd) |
456 |
)) |
)) |
457 |
t) |
t) |
458 |
|
|
459 |
(define-condition-with-tests cond-23 (cond-5) nil) |
(define-condition-with-tests condition-23 (condition-5) nil) |
460 |
|
|
461 |
(deftest cond-23-slots.1 |
(deftest condition-23-slots.1 |
462 |
(let ((c (make-condition 'cond-23 :slot1 'a :slot2 'b))) |
(let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b))) |
463 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
464 |
(typep c 'cond-23) |
(typep c 'condition-23) |
465 |
(eqt (cond-5/slot-1 c) 'a) |
(eqt (condition-5/slot-1 c) 'a) |
466 |
(eqt (cond-5/slot-2 c) 'b) |
(eqt (condition-5/slot-2 c) 'b) |
467 |
)) |
)) |
468 |
t) |
t) |
469 |
|
|
470 |
(deftest cond-23-slots.2 |
(deftest condition-23-slots.2 |
471 |
(let ((c (make-condition 'cond-23 :slot1 'a))) |
(let ((c (make-condition 'condition-23 :slot1 'a))) |
472 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
473 |
(typep c 'cond-23) |
(typep c 'condition-23) |
474 |
(eqt (cond-5/slot-1 c) 'a) |
(eqt (condition-5/slot-1 c) 'a) |
475 |
(eqt (cond-5/slot-2 c) 'y) |
(eqt (condition-5/slot-2 c) 'y) |
476 |
)) |
)) |
477 |
t) |
t) |
478 |
|
|
479 |
(deftest cond-23-slots.3 |
(deftest condition-23-slots.3 |
480 |
(let ((c (make-condition 'cond-23 :slot2 'b))) |
(let ((c (make-condition 'condition-23 :slot2 'b))) |
481 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
482 |
(typep c 'cond-23) |
(typep c 'condition-23) |
483 |
(eqt (cond-5/slot-1 c) 'x) |
(eqt (condition-5/slot-1 c) 'x) |
484 |
(eqt (cond-5/slot-2 c) 'b) |
(eqt (condition-5/slot-2 c) 'b) |
485 |
)) |
)) |
486 |
t) |
t) |
487 |
|
|
488 |
(deftest cond-23-slots.4 |
(deftest condition-23-slots.4 |
489 |
(let ((c (make-condition 'cond-23))) |
(let ((c (make-condition 'condition-23))) |
490 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
491 |
(typep c 'cond-23) |
(typep c 'condition-23) |
492 |
(eqt (cond-5/slot-1 c) 'x) |
(eqt (condition-5/slot-1 c) 'x) |
493 |
(eqt (cond-5/slot-2 c) 'y) |
(eqt (condition-5/slot-2 c) 'y) |
494 |
)) |
)) |
495 |
t) |
t) |
496 |
|
|
497 |
(define-condition-with-tests cond-24 (cond-5) |
(define-condition-with-tests condition-24 (condition-5) |
498 |
nil |
nil |
499 |
(:default-initargs :slot1 'z)) |
(:default-initargs :slot1 'z)) |
500 |
|
|
501 |
(deftest cond-24-slots.1 |
(deftest condition-24-slots.1 |
502 |
(let ((c (make-condition 'cond-24))) |
(let ((c (make-condition 'condition-24))) |
503 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
504 |
(typep c 'cond-24) |
(typep c 'condition-24) |
505 |
(eqt (cond-5/slot-1 c) 'z) |
(eqt (condition-5/slot-1 c) 'z) |
506 |
(eqt (cond-5/slot-2 c) 'y) |
(eqt (condition-5/slot-2 c) 'y) |
507 |
)) |
)) |
508 |
t) |
t) |
509 |
|
|
510 |
(deftest cond-24-slots.2 |
(deftest condition-24-slots.2 |
511 |
(let ((c (make-condition 'cond-24 :slot1 'a))) |
(let ((c (make-condition 'condition-24 :slot1 'a))) |
512 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
513 |
(typep c 'cond-24) |
(typep c 'condition-24) |
514 |
(eqt (cond-5/slot-1 c) 'a) |
(eqt (condition-5/slot-1 c) 'a) |
515 |
(eqt (cond-5/slot-2 c) 'y) |
(eqt (condition-5/slot-2 c) 'y) |
516 |
)) |
)) |
517 |
t) |
t) |
518 |
|
|
519 |
(deftest cond-24-slots.3 |
(deftest condition-24-slots.3 |
520 |
(let ((c (make-condition 'cond-24 :slot2 'a))) |
(let ((c (make-condition 'condition-24 :slot2 'a))) |
521 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
522 |
(typep c 'cond-24) |
(typep c 'condition-24) |
523 |
(eqt (cond-5/slot-1 c) 'z) |
(eqt (condition-5/slot-1 c) 'z) |
524 |
(eqt (cond-5/slot-2 c) 'a) |
(eqt (condition-5/slot-2 c) 'a) |
525 |
)) |
)) |
526 |
t) |
t) |
527 |
|
|
528 |
(deftest cond-24-slots.4 |
(deftest condition-24-slots.4 |
529 |
(let ((c (make-condition 'cond-24 :slot1 'b :slot2 'a))) |
(let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a))) |
530 |
(and (typep c 'cond-5) |
(and (typep c 'condition-5) |
531 |
(typep c 'cond-24) |
(typep c 'condition-24) |
532 |
(eqt (cond-5/slot-1 c) 'b) |
(eqt (condition-5/slot-1 c) 'b) |
533 |
(eqt (cond-5/slot-2 c) 'a) |
(eqt (condition-5/slot-2 c) 'a) |
534 |
)) |
)) |
535 |
t) |
t) |
536 |
|
|
537 |
;;; Multiple inheritance |
;;; Multiple inheritance |
538 |
|
|
539 |
(define-condition-with-tests cond-25a nil |
(define-condition-with-tests condition-25a nil |
540 |
((s1 :initarg :s1 :initform 'a :reader cond-25a/s1))) |
((s1 :initarg :s1 :initform 'a :reader condition-25a/s1))) |
541 |
|
|
542 |
(define-condition-with-tests cond-25b nil |
(define-condition-with-tests condition-25b nil |
543 |
((s2 :initarg :s2 :initform 'b :reader cond-25b/s2))) |
((s2 :initarg :s2 :initform 'b :reader condition-25b/s2))) |
544 |
|
|
545 |
(define-condition-with-tests cond-25 (cond-25a cond-25b) |
(define-condition-with-tests condition-25 (condition-25a condition-25b) |
546 |
((s3 :initarg :s3 :initform 'c :reader cond-25/s3))) |
((s3 :initarg :s3 :initform 'c :reader condition-25/s3))) |
547 |
|
|
548 |
(deftest cond-25-slots.1 |
(deftest condition-25-slots.1 |
549 |
(let ((c (make-condition 'cond-25))) |
(let ((c (make-condition 'condition-25))) |
550 |
(and (typep c 'cond-25a) |
(and (typep c 'condition-25a) |
551 |
(typep c 'cond-25b) |
(typep c 'condition-25b) |
552 |
(typep c 'cond-25) |
(typep c 'condition-25) |
553 |
(eqt (cond-25a/s1 c) 'a) |
(eqt (condition-25a/s1 c) 'a) |
554 |
(eqt (cond-25b/s2 c) 'b) |
(eqt (condition-25b/s2 c) 'b) |
555 |
(eqt (cond-25/s3 c) 'c))) |
(eqt (condition-25/s3 c) 'c))) |
556 |
t) |
t) |
557 |
|
|
558 |
(deftest cond-25-slots.2 |
(deftest condition-25-slots.2 |
559 |
(let ((c (make-condition 'cond-25 :s1 'x))) |
(let ((c (make-condition 'condition-25 :s1 'x))) |
560 |
(and (typep c 'cond-25a) |
(and (typep c 'condition-25a) |
561 |
(typep c 'cond-25b) |
(typep c 'condition-25b) |
562 |
(typep c 'cond-25) |
(typep c 'condition-25) |
563 |
(eqt (cond-25a/s1 c) 'x) |
(eqt (condition-25a/s1 c) 'x) |
564 |
(eqt (cond-25b/s2 c) 'b) |
(eqt (condition-25b/s2 c) 'b) |
565 |
(eqt (cond-25/s3 c) 'c))) |
(eqt (condition-25/s3 c) 'c))) |
566 |
t) |
t) |
567 |
|
|
568 |
(deftest cond-25-slots.3 |
(deftest condition-25-slots.3 |
569 |
(let ((c (make-condition 'cond-25 :s2 'x))) |
(let ((c (make-condition 'condition-25 :s2 'x))) |
570 |
(and (typep c 'cond-25a) |
(and (typep c 'condition-25a) |
571 |
(typep c 'cond-25b) |
(typep c 'condition-25b) |
572 |
(typep c 'cond-25) |
(typep c 'condition-25) |
573 |
(eqt (cond-25a/s1 c) 'a) |
(eqt (condition-25a/s1 c) 'a) |
574 |
(eqt (cond-25b/s2 c) 'x) |
(eqt (condition-25b/s2 c) 'x) |
575 |
(eqt (cond-25/s3 c) 'c))) |
(eqt (condition-25/s3 c) 'c))) |
576 |
t) |
t) |
577 |
|
|
578 |
(deftest cond-25-slots.4 |
(deftest condition-25-slots.4 |
579 |
(let ((c (make-condition 'cond-25 :s3 'x))) |
(let ((c (make-condition 'condition-25 :s3 'x))) |
580 |
(and (typep c 'cond-25a) |
(and (typep c 'condition-25a) |
581 |
(typep c 'cond-25b) |
(typep c 'condition-25b) |
582 |
(typep c 'cond-25) |
(typep c 'condition-25) |
583 |
(eqt (cond-25a/s1 c) 'a) |
(eqt (condition-25a/s1 c) 'a) |
584 |
(eqt (cond-25b/s2 c) 'b) |
(eqt (condition-25b/s2 c) 'b) |
585 |
(eqt (cond-25/s3 c) 'x))) |
(eqt (condition-25/s3 c) 'x))) |
586 |
t) |
t) |
587 |
|
|
588 |
(deftest cond-25-slots.5 |
(deftest condition-25-slots.5 |
589 |
(let ((c (make-condition 'cond-25 :s3 'z :s2 'y :s1 'x))) |
(let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x))) |
590 |
(and (typep c 'cond-25a) |
(and (typep c 'condition-25a) |
591 |
(typep c 'cond-25b) |
(typep c 'condition-25b) |
592 |
(typep c 'cond-25) |
(typep c 'condition-25) |
593 |
(eqt (cond-25a/s1 c) 'x) |
(eqt (condition-25a/s1 c) 'x) |
594 |
(eqt (cond-25b/s2 c) 'y) |
(eqt (condition-25b/s2 c) 'y) |
595 |
(eqt (cond-25/s3 c) 'z))) |
(eqt (condition-25/s3 c) 'z))) |
596 |
t) |
t) |
597 |
|
|
598 |
;;; |
;;; |
599 |
|
|
600 |
(define-condition-with-tests cond-26a nil |
(define-condition-with-tests condition-26a nil |
601 |
((s1 :initarg :s1 :initform 'a :reader cond-26a/s1))) |
((s1 :initarg :s1 :initform 'a :reader condition-26a/s1))) |
602 |
|
|
603 |
(define-condition-with-tests cond-26b (cond-26a) nil) |
(define-condition-with-tests condition-26b (condition-26a) nil) |
604 |
(define-condition-with-tests cond-26c (cond-26a) nil) |
(define-condition-with-tests condition-26c (condition-26a) nil) |
605 |
(define-condition-with-tests cond-26 (cond-26b cond-26c) nil) |
(define-condition-with-tests condition-26 (condition-26b condition-26c) nil) |
606 |
|
|
607 |
(deftest cond-26-slots.1 |
(deftest condition-26-slots.1 |
608 |
(let ((c (make-condition 'cond-26))) |
(let ((c (make-condition 'condition-26))) |
609 |
(and (typep c 'cond-26a) |
(and (typep c 'condition-26a) |
610 |
(typep c 'cond-26b) |
(typep c 'condition-26b) |
611 |
(typep c 'cond-26c) |
(typep c 'condition-26c) |
612 |
(typep c 'cond-26) |
(typep c 'condition-26) |
613 |
(eqt (cond-26a/s1 c) 'a))) |
(eqt (condition-26a/s1 c) 'a))) |
614 |
t) |
t) |
615 |
|
|
616 |
(deftest cond-26-slots.2 |
(deftest condition-26-slots.2 |
617 |
(let ((c (make-condition 'cond-26 :s1 'x))) |
(let ((c (make-condition 'condition-26 :s1 'x))) |
618 |
(and (typep c 'cond-26a) |
(and (typep c 'condition-26a) |
619 |
(typep c 'cond-26b) |
(typep c 'condition-26b) |
620 |
(typep c 'cond-26c) |
(typep c 'condition-26c) |
621 |
(typep c 'cond-26) |
(typep c 'condition-26) |
622 |
(eqt (cond-26a/s1 c) 'x))) |
(eqt (condition-26a/s1 c) 'x))) |
623 |
t) |
t) |
624 |
|
|
625 |
|
|
626 |
;;; Test that a slot reader is truly a generic function |
;;; Test that a slot reader is truly a generic function |
627 |
|
|
628 |
(define-condition-with-tests cond-27a nil |
(define-condition-with-tests condition-27a nil |
629 |
((s0 :initarg :s0 :initform 10 :reader cond-27a/s0) |
((s0 :initarg :s0 :initform 10 :reader condition-27a/s0) |
630 |
(s1 :initarg :s1 :initform 'a :reader cond-27/s1))) |
(s1 :initarg :s1 :initform 'a :reader condition-27/s1))) |
631 |
|
|
632 |
(define-condition-with-tests cond-27b nil |
(define-condition-with-tests condition-27b nil |
633 |
((s1 :initarg :s1 :initform 'a :reader cond-27/s1) |
((s1 :initarg :s1 :initform 'a :reader condition-27/s1) |
634 |
(s2 :initarg :s2 :initform 16 :reader cond-27b/s2))) |
(s2 :initarg :s2 :initform 16 :reader condition-27b/s2))) |
635 |
|
|
636 |
(deftest cond-27-slots.1 |
(deftest condition-27-slots.1 |
637 |
(let ((c (make-condition 'cond-27a))) |
(let ((c (make-condition 'condition-27a))) |
638 |
(and (typep c 'cond-27a) |
(and (typep c 'condition-27a) |
639 |
(not (typep c 'cond-27b)) |
(not (typep c 'condition-27b)) |
640 |
(eqt (cond-27/s1 c) 'a))) |
(eqt (condition-27/s1 c) 'a))) |
641 |
t) |
t) |
642 |
|
|
643 |
(deftest cond-27-slots.2 |
(deftest condition-27-slots.2 |
644 |
(let ((c (make-condition 'cond-27b))) |
(let ((c (make-condition 'condition-27b))) |
645 |
(and (typep c 'cond-27b) |
(and (typep c 'condition-27b) |
646 |
(not (typep c 'cond-27a)) |
(not (typep c 'condition-27a)) |
647 |
(eqt (cond-27/s1 c) 'a))) |
(eqt (condition-27/s1 c) 'a))) |
648 |
t) |
t) |
649 |
|
|
650 |
(deftest cond-27-reader-is-generic |
(deftest condition-27-reader-is-generic |
651 |
(notnot-mv (typep #'cond-27/s1 'generic-function)) |
(notnot-mv (typep #'condition-27/s1 'generic-function)) |
652 |
t) |
t) |
653 |
|
|
654 |
;;; More inheritance |
;;; More inheritance |
659 |
;;; fully integrated into the standard.) |
;;; fully integrated into the standard.) |
660 |
|
|
661 |
#| |
#| |
662 |
(define-condition-with-tests cond-28a nil |
(define-condition-with-tests condition-28a nil |
663 |
((s1 :initarg :i1 :initform 'x :reader cond-28a/s1))) |
((s1 :initarg :i1 :initform 'x :reader condition-28a/s1))) |
664 |
|
|
665 |
(define-condition-with-tests cond-28 (cond-28a) |
(define-condition-with-tests condition-28 (condition-28a) |
666 |
((s1 :initarg :i1a :reader cond-28/s1))) |
((s1 :initarg :i1a :reader condition-28/s1))) |
667 |
|
|
668 |
(deftest cond-28-slots.1 |
(deftest condition-28-slots.1 |
669 |
(let ((c (make-condition 'cond-28))) |
(let ((c (make-condition 'condition-28))) |
670 |
(and (typep c 'cond-28a) |
(and (typep c 'condition-28a) |
671 |
(typep c 'cond-28) |
(typep c 'condition-28) |
672 |
(eqt (cond-28a/s1 c) 'x) |
(eqt (condition-28a/s1 c) 'x) |
673 |
(eqt (cond-28/s1 c) 'x))) |
(eqt (condition-28/s1 c) 'x))) |
674 |
t) |
t) |
675 |
|
|
676 |
(deftest cond-28-slots.2 |
(deftest condition-28-slots.2 |
677 |
(let ((c (make-condition 'cond-28 :i1 'z))) |
(let ((c (make-condition 'condition-28 :i1 'z))) |
678 |
(and (typep c 'cond-28a) |
(and (typep c 'condition-28a) |
679 |
(typep c 'cond-28) |
(typep c 'condition-28) |
680 |
(eqt (cond-28a/s1 c) 'z) |
(eqt (condition-28a/s1 c) 'z) |
681 |
(eqt (cond-28/s1 c) 'z))) |
(eqt (condition-28/s1 c) 'z))) |
682 |
t) |
t) |
683 |
|
|
684 |
(deftest cond-28-slots.3 |
(deftest condition-28-slots.3 |
685 |
(let ((c (make-condition 'cond-28 :i1a 'w))) |
(let ((c (make-condition 'condition-28 :i1a 'w))) |
686 |
(and (typep c 'cond-28a) |
(and (typep c 'condition-28a) |
687 |
(typep c 'cond-28) |
(typep c 'condition-28) |
688 |
(eqt (cond-28a/s1 c) 'w) |
(eqt (condition-28a/s1 c) 'w) |
689 |
(eqt (cond-28/s1 c) 'w))) |
(eqt (condition-28/s1 c) 'w))) |
690 |
t) |
t) |
691 |
|
|
692 |
(deftest cond-28-slots.4 |
(deftest condition-28-slots.4 |
693 |
(let ((c (make-condition 'cond-28 :i1 'y :i1a 'w))) |
(let ((c (make-condition 'condition-28 :i1 'y :i1a 'w))) |
694 |
(and (typep c 'cond-28a) |
(and (typep c 'condition-28a) |
695 |
(typep c 'cond-28) |
(typep c 'condition-28) |
696 |
(eqt (cond-28a/s1 c) 'y) |
(eqt (condition-28a/s1 c) 'y) |
697 |
(eqt (cond-28/s1 c) 'y))) |
(eqt (condition-28/s1 c) 'y))) |
698 |
t) |
t) |
699 |
|
|
700 |
(deftest cond-28-slots.5 |
(deftest condition-28-slots.5 |
701 |
(let ((c (make-condition 'cond-28 :i1a 'y :i1 'w))) |
(let ((c (make-condition 'condition-28 :i1a 'y :i1 'w))) |
702 |
(and (typep c 'cond-28a) |
(and (typep c 'condition-28a) |
703 |
(typep c 'cond-28) |
(typep c 'condition-28) |
704 |
(eqt (cond-28a/s1 c) 'y) |
(eqt (condition-28a/s1 c) 'y) |
705 |
(eqt (cond-28/s1 c) 'y))) |
(eqt (condition-28/s1 c) 'y))) |
706 |
t) |
t) |
707 |
|# |
|# |
708 |
|
|
710 |
;;; Documentation |
;;; Documentation |
711 |
|
|
712 |
;;; Pitman says this should have been in the spec, but it isn't really |
;;; Pitman says this should have been in the spec, but it isn't really |
713 |
;;; (define-condition-with-tests cond-29 nil |
;;; (define-condition-with-tests condition-29 nil |
714 |
;;; ((s1 :initarg :i1 :initform 'x |
;;; ((s1 :initarg :i1 :initform 'x |
715 |
;;; :documentation "This is slot s1 in condition cond-29"))) |
;;; :documentation "This is slot s1 in condition condition-29"))) |
716 |
|
|
717 |
(define-condition-with-tests cond-30 nil |
(define-condition-with-tests condition-30 nil |
718 |
((s1 :initarg :i1 :initform 'x)) |
((s1 :initarg :i1 :initform 'x)) |
719 |
(:documentation "This is class cond-30")) |
(:documentation "This is class condition-30")) |