define-condition.lsp 21.3 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Mar  8 22:38:53 2003
;;;; Contains: Tests of DEFINE-CONDITION (part 1)

6

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 17 18
(define-condition-with-tests condition-4 nil
  ((slot1 :initarg :slot1 :reader condition-4/slot-1)
   (slot2 :initarg :slot2 :reader condition-4/slot-2)))
19

20 21 22
(deftest condition-4-slots.1
  (let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b)))
    (and (typep c 'condition-4)
sds's avatar
sds committed
23 24
         (eqlt (condition-4/slot-1 c) 'a)
         (eqlt (condition-4/slot-2 c) 'b)))
25 26
  t)

27 28 29
(define-condition-with-tests condition-5 nil
  ((slot1 :initarg :slot1 :initform 'x :reader condition-5/slot-1)
   (slot2 :initarg :slot2 :initform 'y :reader condition-5/slot-2)))
30

31 32 33
(deftest condition-5-slots.1
  (let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
34 35
         (eqlt (condition-5/slot-1 c) 'a)
         (eqlt (condition-5/slot-2 c) 'b)))
36 37
  t)

38 39 40
(deftest condition-5-slots.2
  (let ((c (make-condition 'condition-5 :slot1 'a)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
41 42
         (eqlt (condition-5/slot-1 c) 'a)
         (eqlt (condition-5/slot-2 c) 'y)))
43 44
  t)

45 46 47
(deftest condition-5-slots.3
  (let ((c (make-condition 'condition-5 :slot2 'b)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
48 49
         (eqlt (condition-5/slot-1 c) 'x)
         (eqlt (condition-5/slot-2 c) 'b)))
50 51
  t)

52 53 54
(deftest condition-5-slots.4
  (let ((c (make-condition 'condition-5)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
55 56
         (eqlt (condition-5/slot-1 c) 'x)
         (eqlt (condition-5/slot-2 c) 'y)))
57 58
  t)

59
(define-condition-with-tests condition-6 nil
60
  ((slot1 :initarg :slot1 :initarg :both-slots
sds's avatar
sds committed
61
          :initform 'x :reader condition-6/slot-1)
62
   (slot2 :initarg :slot2 :initarg :both-slots
sds's avatar
sds committed
63
          :initform 'y :reader condition-6/slot-2)))
64

65 66 67
(deftest condition-6-slots.1
  (let ((c (make-condition 'condition-6 :both-slots 'a)))
    (and (typep c 'condition-6)
sds's avatar
sds committed
68 69
         (eqlt (condition-6/slot-1 c) 'a)
         (eqlt (condition-6/slot-2 c) 'a)))
70 71
  t)

72 73 74
(deftest condition-6-slots.2
  (let ((c (make-condition 'condition-6)))
    (and (typep c 'condition-6)
sds's avatar
sds committed
75 76
         (eqlt (condition-6/slot-1 c) 'x)
         (eqlt (condition-6/slot-2 c) 'y)))
77 78
  t)

79 80 81
(deftest condition-6-slots.3
  (let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b)))
    (and (typep c 'condition-6)
sds's avatar
sds committed
82 83
         (eqlt (condition-6/slot-1 c) 'a)
         (eqlt (condition-6/slot-2 c) 'b)))
84 85
  t)

86 87 88
(deftest condition-6-slots.4
  (let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a)))
    (and (typep c 'condition-6)
sds's avatar
sds committed
89 90
         (eqlt (condition-6/slot-1 c) 'a)
         (eqlt (condition-6/slot-2 c) 'b)))
91 92
  t)

93 94 95
(deftest condition-6-slots.5
  (let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd)))
    (and (typep c 'condition-6)
sds's avatar
sds committed
96 97
         (eqlt (condition-6/slot-1 c) 'a)
         (eqlt (condition-6/slot-2 c) 'a)))
98 99
  t)

100 101
(define-condition-with-tests condition-7 nil
  ((s :initarg :i1 :initarg :i2 :reader condition-7/s)))
102

103 104 105
(deftest condition-7-slots.1
  (let ((c (make-condition 'condition-7 :i1 'a)))
    (and (typep c 'condition-7)
sds's avatar
sds committed
106
         (eqlt (condition-7/s c) 'a)))
107 108
  t)

109 110 111
(deftest condition-7-slots.2
  (let ((c (make-condition 'condition-7 :i2 'a)))
    (and (typep c 'condition-7)
sds's avatar
sds committed
112
         (eqlt (condition-7/s c) 'a)))
113 114
  t)

115 116 117
(deftest condition-7-slots.3
  (let ((c (make-condition 'condition-7 :i1 'a :i2 'b)))
    (and (typep c 'condition-7)
sds's avatar
sds committed
118
         (eqlt (condition-7/s c) 'a)))
119 120
  t)

121 122 123
(deftest condition-7-slots.4
  (let ((c (make-condition 'condition-7 :i2 'a :i1 'b)))
    (and (typep c 'condition-7)
sds's avatar
sds committed
124
         (eqlt (condition-7/s c) 'a)))
125 126
  t)

127
(defparameter *condition-8-counter* 0)
128

129 130
(define-condition-with-tests condition-8 nil
  ((s :initarg :i1 :initform (incf *condition-8-counter*) :reader condition-8/s)))
131

132 133 134
(deftest condition-8-slots.1
  (let ((*condition-8-counter* 100))
    (declare (special *condition-8-counter*))
135
    (values
136 137
     (condition-8/s (make-condition 'condition-8))
     *condition-8-counter*))
138 139
  101 101)

140 141 142
(define-condition-with-tests condition-9 nil
  ((s1 :initarg :i1 :initform 15 :reader condition-9/s1)
   (s2 :initarg :i2 :initform 37 :reader condition-9/s2)))
143

144 145 146
(deftest condition-9-slots.1
  (let ((c (make-condition 'condition-9)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
147 148
            (condition-9/s1 c)
            (condition-9/s2 c)))
149 150
  t 15 37)

151 152 153
(deftest condition-9-slots.2
  (let ((c (make-condition 'condition-9 :i1 3)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
154 155
            (condition-9/s1 c)
            (condition-9/s2 c)))
156 157
  t 3 37)

158 159 160
(deftest condition-9-slots.3
  (let ((c (make-condition 'condition-9 :i2 3)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
161 162
            (condition-9/s1 c)
            (condition-9/s2 c)))
163 164
  t 15 3)

165 166 167
(deftest condition-9-slots.4
  (let ((c (make-condition 'condition-9 :i2 3 :i2 8)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
168 169
            (condition-9/s1 c)
            (condition-9/s2 c)))
170 171
  t 15 3)

172 173 174
(deftest condition-9-slots.5
  (let ((c (make-condition 'condition-9 :i1 3 :i2 8)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
175 176
            (condition-9/s1 c)
            (condition-9/s2 c)))
177 178
  t 3 8)

179 180 181
(deftest condition-9-slots.6
  (let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500)))
    (values (notnot (typep c 'condition-9))
sds's avatar
sds committed
182 183
            (condition-9/s1 c)
            (condition-9/s2 c)))
184 185
  t 3 8)

186 187
;;; (define-condition-with-tests condition-10 nil
;;;   ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r)))
sds's avatar
sds committed
188
;;;
189 190 191
;;; (deftest condition-10-slots.1
;;;   (let ((c (make-condition 'condition-10 :i1 11)))
;;;      (condition-10/s1-r c))
192
;;;   11)
sds's avatar
sds committed
193
;;;
194 195 196
;;; (deftest condition-10-slots.2
;;;   (let ((c (make-condition 'condition-10 :i1 11)))
;;;      (condition-10/s1-w 17 c))
197
;;;   17)
sds's avatar
sds committed
198
;;;
199 200 201 202
;;; (deftest condition-10-slots.3
;;;   (let ((c (make-condition 'condition-10 :i1 11)))
;;;      (condition-10/s1-w 107 c)
;;;      (condition-10/s1-r c))
203
;;;   107)
sds's avatar
sds committed
204
;;;
205 206
;;; (define-condition-with-tests condition-11 nil
;;;   ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r)))
sds's avatar
sds committed
207
;;;
208 209 210
;;; (deftest condition-11-slots.1
;;;   (let ((c (make-condition 'condition-11 :i1 11)))
;;;      (condition-11/r c))
211
;;;   11)
sds's avatar
sds committed
212
;;;
213 214 215
;;; (deftest condition-11-slots.2
;;;   (let ((c (make-condition 'condition-11 :i1 11)))
;;;      (setf (condition-11/w c) 17))
216
;;;   17)
sds's avatar
sds committed
217
;;;
218 219 220 221
;;; (deftest condition-11-slots.3
;;;   (let ((c (make-condition 'condition-11 :i1 11)))
;;;      (setf (condition-11/w c) 117)
;;;      (condition-11/r c))
222
;;;   117)
sds's avatar
sds committed
223
;;;
224 225
;;; (deftest condition-11-slots.4
;;;   (let ((c (make-condition 'condition-11 :i1 11)))
226
;;;     (values
227 228
;;;      (funcall #'(setf condition-11/w) 117 c)
;;;      (condition-11/r c)))
229 230
;;;   117 117)

231
;;; The condition-12 and condition-13 tests have been removed.  Duane Rettig
232 233
;;; convincingly argued that the feature being tested (non-symbol
;;; slot names) remains in the standard only because of editing errors.
234

235 236 237
;;; (define-condition-with-tests condition-12 nil
;;;   (((slot1) :initarg :slot1 :reader condition-12/slot-1)
;;;    ((slot2) :initarg :slot2 :reader condition-12/slot-2)))
sds's avatar
sds committed
238
;;;
239 240 241
;;; (deftest condition-12-slots.1
;;;   (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b)))
;;;     (and (typep c 'condition-12)
sds's avatar
sds committed
242 243
;;;      (eqlt (condition-12/slot-1 c) 'a)
;;;      (eqlt (condition-12/slot-2 c) 'b)))
244
;;;   t)
sds's avatar
sds committed
245
;;;
246 247
;;; (define-condition-with-tests condition-13 nil
;;;   (((slot1 10) :initarg :slot1 :reader condition-13/slot-1)))
sds's avatar
sds committed
248
;;;
249 250 251
;;; (deftest condition-13-slots.1
;;;   (let ((c (make-condition 'condition-13)))
;;;     (and (typep c 'condition-13)
sds's avatar
sds committed
252
;;;      (condition-13/slot-1 c)))
253
;;;   10)
sds's avatar
sds committed
254

255 256 257 258 259 260 261
(define-condition-with-tests condition-14 nil
  ((s1 :initarg :i1 :type fixnum :reader condition-14/s1)
   (s2 :initarg :i2 :type t :reader condition-14/s2)))

(deftest condition-14-slots.1
  (let ((c (make-condition 'condition-14 :i1 10)))
    (and (typep c 'condition-14)
sds's avatar
sds committed
262
         (condition-14/s1 c)))
263 264
  10)

265 266 267
(deftest condition-14-slots.2
  (let ((c (make-condition 'condition-14 :i2 'a)))
    (and (typep c 'condition-14)
sds's avatar
sds committed
268
         (condition-14/s2 c)))
269 270
  a)

271 272 273
(deftest condition-14-slots.3
  (let ((c (make-condition 'condition-14 :i1 10 :i2 'h)))
    (and (typep c 'condition-14)
sds's avatar
sds committed
274 275
         (eqlt (condition-14/s1 c) 10)
         (condition-14/s2 c)))
276 277
  h)

278
(define-condition-with-tests condition-15 nil
279 280
  ((s1 :type nil)))

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)
sds's avatar
sds committed
287
        (c (make-condition 'condition-16)))
288
    (with-output-to-string (s) (print-object c s)))
289
  "The report for condition-16")
290

291 292 293
(defun condition-17-report (c s)
  (format s "condition-17: ~A" (condition-17/s c)))

294 295 296
(define-condition-with-tests condition-17 nil
  ((s :initarg :i1 :reader condition-17/s ))
  (:report condition-17-report))
297

298
(deftest condition-17-report.1
299
  (let ((*print-escape* nil)
sds's avatar
sds committed
300
        (c (make-condition 'condition-17 :i1 1234)))
301
    (with-output-to-string (s) (print-object c s)))
302
  "condition-17: 1234")
303

304 305 306
(define-condition-with-tests condition-18 nil
  ((s :initarg :i1 :reader condition-18/s ))
  (: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)
sds's avatar
sds committed
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 316 317 318 319 320 321 322

;;;
;;; Tests of :default-initargs
;;;
;;; There is an inconsistency in the ANSI spec.  DEFINE-CONDITION
;;; says that in (:default-initargs . <foo>), <foo> is a list of pairs.
;;; However, DEFCLASS says it's a list whose alternate elements
;;; are initargs and initforms.  I have taken the second interpretation.
;;;

323 324 325
(define-condition-with-tests condition-19 nil
  ((s1 :reader condition-19/s1 :initarg :i1)
   (s2 :reader condition-19/s2 :initarg :i2))
326
  (:default-initargs :i1 10
sds's avatar
sds committed
327
                     :i2 20))
328

329 330
(deftest condition-19-slots.1
  (let ((c (make-condition 'condition-19)))
331
    (values
332 333 334
     (notnot (typep c 'condition-19))
     (condition-19/s1 c)
     (condition-19/s2 c)))
335 336
  t 10 20)

337 338
(deftest condition-19-slots.2
  (let ((c (make-condition 'condition-19 :i1 'a)))
339
    (values
340 341 342
     (notnot (typep c 'condition-19))
     (condition-19/s1 c)
     (condition-19/s2 c)))
343 344
  t a 20)

345 346
(deftest condition-19-slots.3
  (let ((c (make-condition 'condition-19 :i2 'a)))
347
    (values
348 349 350
     (notnot (typep c 'condition-19))
     (condition-19/s1 c)
     (condition-19/s2 c)))
351 352
  t 10 a)

353 354
(deftest condition-19-slots.4
  (let ((c (make-condition 'condition-19 :i1 'x :i2 'y)))
355
    (values
356 357 358
     (notnot (typep c 'condition-19))
     (condition-19/s1 c)
     (condition-19/s2 c)))
359 360
  t x y)

361 362
(deftest condition-19-slots.5
  (let ((c (make-condition 'condition-19 :i2 'y :i1 'x)))
363
    (values
364 365 366
     (notnot (typep c 'condition-19))
     (condition-19/s1 c)
     (condition-19/s2 c)))
367 368
  t x y)

369 370
(defparameter *condition-20/s1-val* 0)
(defparameter *condition-20/s2-val* 0)
371

372 373 374 375
(define-condition-with-tests condition-20 nil
  ((s1 :reader condition-20/s1 :initarg :i1)
   (s2 :reader condition-20/s2 :initarg :i2))
  (:default-initargs :i1 (incf *condition-20/s1-val*)
sds's avatar
sds committed
376
                     :i2 (incf *condition-20/s2-val*)))
377

378 379
(deftest condition-20-slots.1
  (let ((*condition-20/s1-val* 0)
sds's avatar
sds committed
380
        (*condition-20/s2-val* 10))
381 382
    (declare (special *condition-20/s1-val* *condition-20/s2-val*))
    (let ((c (make-condition 'condition-20)))
383
      (values
384 385 386 387 388
       (notnot (typep c 'condition-20))
       (condition-20/s1 c)
       (condition-20/s2 c)
       *condition-20/s1-val*
       *condition-20/s2-val*)))
389 390
  t 1 11 1 11)

391 392
(deftest condition-20-slots.2
  (let ((*condition-20/s1-val* 0)
sds's avatar
sds committed
393
        (*condition-20/s2-val* 10))
394 395
    (declare (special *condition-20/s1-val* *condition-20/s2-val*))
    (let ((c (make-condition 'condition-20 :i1 'x)))
396
      (values
397 398 399 400 401
       (notnot (typep c 'condition-20))
       (condition-20/s1 c)
       (condition-20/s2 c)
       *condition-20/s1-val*
       *condition-20/s2-val*)))
402 403
  t x 11 0 11)

404 405
(deftest condition-20-slots.3
  (let ((*condition-20/s1-val* 0)
sds's avatar
sds committed
406
        (*condition-20/s2-val* 10))
407 408
    (declare (special *condition-20/s1-val* *condition-20/s2-val*))
    (let ((c (make-condition 'condition-20 :i2 'y)))
409
      (values
410 411 412 413 414
       (notnot (typep c 'condition-20))
       (condition-20/s1 c)
       (condition-20/s2 c)
       *condition-20/s1-val*
       *condition-20/s2-val*)))
415 416
  t 1 y 1 10)

417 418
(deftest condition-20-slots.4
  (let ((*condition-20/s1-val* 0)
sds's avatar
sds committed
419
        (*condition-20/s2-val* 10))
420 421
    (declare (special *condition-20/s1-val* *condition-20/s2-val*))
    (let ((c (make-condition 'condition-20 :i2 'y :i1 'x)))
422
      (values
423 424 425 426 427
       (notnot (typep c 'condition-20))
       (condition-20/s1 c)
       (condition-20/s2 c)
       *condition-20/s1-val*
       *condition-20/s2-val*)))
428 429 430 431 432
  t x y 0 10)


;;;;;;;;; tests of inheritance

433
(define-condition-with-tests condition-21 (condition-4) nil)
434

435 436 437
(deftest condition-21-slots.1
  (let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b)))
    (and (typep c 'condition-4)
sds's avatar
sds committed
438 439 440
         (typep c 'condition-21)
         (eqlt (condition-4/slot-1 c) 'a)
         (eqlt (condition-4/slot-2 c) 'b)))
441 442
  t)

443 444 445
(define-condition-with-tests condition-22 (condition-4)
  ((slot3 :initarg :slot3 :reader condition-22/slot-3)
   (slot4 :initarg :slot4 :reader condition-22/slot-4)))
446

447 448
(deftest condition-22-slots.1
  (let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b
sds's avatar
sds committed
449
                           :slot3 'c :slot4 'd)))
450
    (and (typep c 'condition-4)
sds's avatar
sds committed
451 452 453 454 455 456
         (typep c 'condition-22)
         (eqlt (condition-4/slot-1 c) 'a)
         (eqlt (condition-4/slot-2 c) 'b)
         (eqlt (condition-22/slot-3 c) 'c)
         (eqlt (condition-22/slot-4 c) 'd)
         ))
457 458
  t)

459
(define-condition-with-tests condition-23 (condition-5) nil)
460

461 462 463
(deftest condition-23-slots.1
  (let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
464 465 466 467
         (typep c 'condition-23)
         (eqlt (condition-5/slot-1 c) 'a)
         (eqlt (condition-5/slot-2 c) 'b)
         ))
468 469
  t)

470 471 472
(deftest condition-23-slots.2
  (let ((c (make-condition 'condition-23 :slot1 'a)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
473 474 475 476
         (typep c 'condition-23)
         (eqlt (condition-5/slot-1 c) 'a)
         (eqlt (condition-5/slot-2 c) 'y)
         ))
477 478
  t)

479 480 481
(deftest condition-23-slots.3
  (let ((c (make-condition 'condition-23 :slot2 'b)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
482 483 484 485
         (typep c 'condition-23)
         (eqlt (condition-5/slot-1 c) 'x)
         (eqlt (condition-5/slot-2 c) 'b)
         ))
486 487
  t)

488 489 490
(deftest condition-23-slots.4
  (let ((c (make-condition 'condition-23)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
491 492 493 494
         (typep c 'condition-23)
         (eqlt (condition-5/slot-1 c) 'x)
         (eqlt (condition-5/slot-2 c) 'y)
         ))
495
  t)
496

497
(define-condition-with-tests condition-24 (condition-5)
498 499 500
  nil
  (:default-initargs :slot1 'z))

501 502 503
(deftest condition-24-slots.1
  (let ((c (make-condition 'condition-24)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
504 505 506 507
         (typep c 'condition-24)
         (eqlt (condition-5/slot-1 c) 'z)
         (eqlt (condition-5/slot-2 c) 'y)
         ))
508 509
  t)

510 511 512
(deftest condition-24-slots.2
  (let ((c (make-condition 'condition-24 :slot1 'a)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
513 514 515 516
         (typep c 'condition-24)
         (eqlt (condition-5/slot-1 c) 'a)
         (eqlt (condition-5/slot-2 c) 'y)
         ))
517 518
  t)

519 520 521
(deftest condition-24-slots.3
  (let ((c (make-condition 'condition-24 :slot2 'a)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
522 523 524 525
         (typep c 'condition-24)
         (eqlt (condition-5/slot-1 c) 'z)
         (eqlt (condition-5/slot-2 c) 'a)
         ))
526 527
  t)

528 529 530
(deftest condition-24-slots.4
  (let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a)))
    (and (typep c 'condition-5)
sds's avatar
sds committed
531 532 533 534
         (typep c 'condition-24)
         (eqlt (condition-5/slot-1 c) 'b)
         (eqlt (condition-5/slot-2 c) 'a)
         ))
535 536 537 538
  t)

;;; Multiple inheritance

539 540 541 542 543 544 545 546 547 548 549 550
(define-condition-with-tests condition-25a nil
  ((s1 :initarg :s1 :initform 'a :reader condition-25a/s1)))

(define-condition-with-tests condition-25b nil
  ((s2 :initarg :s2 :initform 'b :reader condition-25b/s2)))

(define-condition-with-tests condition-25 (condition-25a condition-25b)
  ((s3 :initarg :s3 :initform 'c :reader condition-25/s3)))

(deftest condition-25-slots.1
  (let ((c (make-condition 'condition-25)))
    (and (typep c 'condition-25a)
sds's avatar
sds committed
551 552 553 554 555
         (typep c 'condition-25b)
         (typep c 'condition-25)
         (eqlt (condition-25a/s1 c) 'a)
         (eqlt (condition-25b/s2 c) 'b)
         (eqlt (condition-25/s3 c) 'c)))
556 557 558 559 560
  t)

(deftest condition-25-slots.2
  (let ((c (make-condition 'condition-25 :s1 'x)))
    (and (typep c 'condition-25a)
sds's avatar
sds committed
561 562 563 564 565
         (typep c 'condition-25b)
         (typep c 'condition-25)
         (eqlt (condition-25a/s1 c) 'x)
         (eqlt (condition-25b/s2 c) 'b)
         (eqlt (condition-25/s3 c) 'c)))
566 567 568 569 570
  t)

(deftest condition-25-slots.3
  (let ((c (make-condition 'condition-25 :s2 'x)))
    (and (typep c 'condition-25a)
sds's avatar
sds committed
571 572 573 574 575
         (typep c 'condition-25b)
         (typep c 'condition-25)
         (eqlt (condition-25a/s1 c) 'a)
         (eqlt (condition-25b/s2 c) 'x)
         (eqlt (condition-25/s3 c) 'c)))
576 577 578 579 580
  t)

(deftest condition-25-slots.4
  (let ((c (make-condition 'condition-25 :s3 'x)))
    (and (typep c 'condition-25a)
sds's avatar
sds committed
581 582 583 584 585
         (typep c 'condition-25b)
         (typep c 'condition-25)
         (eqlt (condition-25a/s1 c) 'a)
         (eqlt (condition-25b/s2 c) 'b)
         (eqlt (condition-25/s3 c) 'x)))
586 587 588 589 590
  t)

(deftest condition-25-slots.5
  (let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x)))
    (and (typep c 'condition-25a)
sds's avatar
sds committed
591 592 593 594 595
         (typep c 'condition-25b)
         (typep c 'condition-25)
         (eqlt (condition-25a/s1 c) 'x)
         (eqlt (condition-25b/s2 c) 'y)
         (eqlt (condition-25/s3 c) 'z)))
596 597 598 599
  t)

;;;

600 601
(define-condition-with-tests condition-26a nil
  ((s1 :initarg :s1 :initform 'a :reader condition-26a/s1)))
602

603 604 605
(define-condition-with-tests condition-26b (condition-26a) nil)
(define-condition-with-tests condition-26c (condition-26a) nil)
(define-condition-with-tests condition-26 (condition-26b condition-26c) nil)
606

607 608 609
(deftest condition-26-slots.1
  (let ((c (make-condition 'condition-26)))
    (and (typep c 'condition-26a)
sds's avatar
sds committed
610 611 612 613
         (typep c 'condition-26b)
         (typep c 'condition-26c)
         (typep c 'condition-26)
         (eqlt (condition-26a/s1 c) 'a)))
614 615
  t)

616 617 618
(deftest condition-26-slots.2
  (let ((c (make-condition 'condition-26 :s1 'x)))
    (and (typep c 'condition-26a)
sds's avatar
sds committed
619 620 621 622
         (typep c 'condition-26b)
         (typep c 'condition-26c)
         (typep c 'condition-26)
         (eqlt (condition-26a/s1 c) 'x)))
623 624 625 626 627
  t)


;;; Test that a slot reader is truly a generic function

628 629 630
(define-condition-with-tests condition-27a nil
  ((s0 :initarg :s0 :initform 10 :reader condition-27a/s0)
   (s1 :initarg :s1 :initform 'a :reader condition-27/s1)))
631

632 633 634
(define-condition-with-tests condition-27b nil
  ((s1 :initarg :s1 :initform 'a :reader condition-27/s1)
   (s2 :initarg :s2 :initform 16 :reader condition-27b/s2)))
635

636 637 638
(deftest condition-27-slots.1
  (let ((c (make-condition 'condition-27a)))
    (and (typep c 'condition-27a)
sds's avatar
sds committed
639 640
         (not (typep c 'condition-27b))
         (eqlt (condition-27/s1 c) 'a)))
641 642
  t)

643 644 645
(deftest condition-27-slots.2
  (let ((c (make-condition 'condition-27b)))
    (and (typep c 'condition-27b)
sds's avatar
sds committed
646 647
         (not (typep c 'condition-27a))
         (eqlt (condition-27/s1 c) 'a)))
648 649
  t)

650 651
(deftest condition-27-reader-is-generic
  (notnot-mv (typep #'condition-27/s1 'generic-function))
652 653 654 655 656 657 658 659 660 661
  t)

;;; More inheritance

;;; These test that condition slots are inherited like CLOS
;;; slots.  It's not entirely clear to me if the standard
;;; demands this (one of the issues does, but that issue wasn't
;;; fully integrated into the standard.)

#|
662 663
(define-condition-with-tests condition-28a nil
  ((s1 :initarg :i1 :initform 'x :reader condition-28a/s1)))
664

665 666
(define-condition-with-tests condition-28 (condition-28a)
  ((s1 :initarg :i1a :reader condition-28/s1)))
667

668 669 670
(deftest condition-28-slots.1
  (let ((c (make-condition 'condition-28)))
    (and (typep c 'condition-28a)
sds's avatar
sds committed
671 672 673
         (typep c 'condition-28)
         (eqlt (condition-28a/s1 c) 'x)
         (eqlt (condition-28/s1 c) 'x)))
674 675
  t)

676 677 678
(deftest condition-28-slots.2
  (let ((c (make-condition 'condition-28 :i1 'z)))
    (and (typep c 'condition-28a)
sds's avatar
sds committed
679 680 681
         (typep c 'condition-28)
         (eqlt (condition-28a/s1 c) 'z)
         (eqlt (condition-28/s1 c) 'z)))
682 683
  t)

684 685 686
(deftest condition-28-slots.3
  (let ((c (make-condition 'condition-28 :i1a 'w)))
    (and (typep c 'condition-28a)
sds's avatar
sds committed
687 688 689
         (typep c 'condition-28)
         (eqlt (condition-28a/s1 c) 'w)
         (eqlt (condition-28/s1 c) 'w)))
690 691
  t)

692 693 694
(deftest condition-28-slots.4
  (let ((c (make-condition 'condition-28 :i1 'y :i1a 'w)))
    (and (typep c 'condition-28a)
sds's avatar
sds committed
695 696 697
         (typep c 'condition-28)
         (eqlt (condition-28a/s1 c) 'y)
         (eqlt (condition-28/s1 c) 'y)))
698 699
  t)

700 701 702
(deftest condition-28-slots.5
  (let ((c (make-condition 'condition-28 :i1a 'y :i1 'w)))
    (and (typep c 'condition-28a)
sds's avatar
sds committed
703 704 705
         (typep c 'condition-28)
         (eqlt (condition-28a/s1 c) 'y)
         (eqlt (condition-28/s1 c) 'y)))
706 707 708 709 710 711 712
  t)
|#


;;; Documentation

;;; 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"))