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