306 |
(c (make-condition 'cond-18 :i1 4321))) |
(c (make-condition 'cond-18 :i1 4321))) |
307 |
(with-output-to-string (s) (print-object c s))) |
(with-output-to-string (s) (print-object c s))) |
308 |
"cond-18: 4321") |
"cond-18: 4321") |
309 |
|
|
310 |
|
;;; |
311 |
|
;;; Tests of :default-initargs |
312 |
|
;;; |
313 |
|
;;; There is an inconsistency in the ANSI spec. DEFINE-CONDITION |
314 |
|
;;; says that in (:default-initargs . <foo>), <foo> is a list of pairs. |
315 |
|
;;; However, DEFCLASS says it's a list whose alternate elements |
316 |
|
;;; are initargs and initforms. I have taken the second interpretation. |
317 |
|
;;; |
318 |
|
|
319 |
|
(define-condition-with-tests cond-19 nil |
320 |
|
((s1 :reader cond-19/s1 :initarg :i1) |
321 |
|
(s2 :reader cond-19/s2 :initarg :i2)) |
322 |
|
(:default-initargs :i1 10 |
323 |
|
:i2 20)) |
324 |
|
|
325 |
|
(deftest cond-19-slots.1 |
326 |
|
(let ((c (make-condition 'cond-19))) |
327 |
|
(values |
328 |
|
(notnot (typep c 'cond-19)) |
329 |
|
(cond-19/s1 c) |
330 |
|
(cond-19/s2 c))) |
331 |
|
t 10 20) |
332 |
|
|
333 |
|
(deftest cond-19-slots.2 |
334 |
|
(let ((c (make-condition 'cond-19 :i1 'a))) |
335 |
|
(values |
336 |
|
(notnot (typep c 'cond-19)) |
337 |
|
(cond-19/s1 c) |
338 |
|
(cond-19/s2 c))) |
339 |
|
t a 20) |
340 |
|
|
341 |
|
(deftest cond-19-slots.3 |
342 |
|
(let ((c (make-condition 'cond-19 :i2 'a))) |
343 |
|
(values |
344 |
|
(notnot (typep c 'cond-19)) |
345 |
|
(cond-19/s1 c) |
346 |
|
(cond-19/s2 c))) |
347 |
|
t 10 a) |
348 |
|
|
349 |
|
(deftest cond-19-slots.4 |
350 |
|
(let ((c (make-condition 'cond-19 :i1 'x :i2 'y))) |
351 |
|
(values |
352 |
|
(notnot (typep c 'cond-19)) |
353 |
|
(cond-19/s1 c) |
354 |
|
(cond-19/s2 c))) |
355 |
|
t x y) |
356 |
|
|
357 |
|
(deftest cond-19-slots.5 |
358 |
|
(let ((c (make-condition 'cond-19 :i2 'y :i1 'x))) |
359 |
|
(values |
360 |
|
(notnot (typep c 'cond-19)) |
361 |
|
(cond-19/s1 c) |
362 |
|
(cond-19/s2 c))) |
363 |
|
t x y) |
364 |
|
|
365 |
|
(defparameter *cond-20/s1-val* 0) |
366 |
|
(defparameter *cond-20/s2-val* 0) |
367 |
|
|
368 |
|
(define-condition-with-tests cond-20 nil |
369 |
|
((s1 :reader cond-20/s1 :initarg :i1) |
370 |
|
(s2 :reader cond-20/s2 :initarg :i2)) |
371 |
|
(:default-initargs :i1 (incf *cond-20/s1-val*) |
372 |
|
:i2 (incf *cond-20/s2-val*))) |
373 |
|
|
374 |
|
(deftest cond-20-slots.1 |
375 |
|
(let ((*cond-20/s1-val* 0) |
376 |
|
(*cond-20/s2-val* 10)) |
377 |
|
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
378 |
|
(let ((c (make-condition 'cond-20))) |
379 |
|
(values |
380 |
|
(notnot (typep c 'cond-20)) |
381 |
|
(cond-20/s1 c) |
382 |
|
(cond-20/s2 c) |
383 |
|
*cond-20/s1-val* |
384 |
|
*cond-20/s2-val*))) |
385 |
|
t 1 11 1 11) |
386 |
|
|
387 |
|
(deftest cond-20-slots.2 |
388 |
|
(let ((*cond-20/s1-val* 0) |
389 |
|
(*cond-20/s2-val* 10)) |
390 |
|
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
391 |
|
(let ((c (make-condition 'cond-20 :i1 'x))) |
392 |
|
(values |
393 |
|
(notnot (typep c 'cond-20)) |
394 |
|
(cond-20/s1 c) |
395 |
|
(cond-20/s2 c) |
396 |
|
*cond-20/s1-val* |
397 |
|
*cond-20/s2-val*))) |
398 |
|
t x 11 0 11) |
399 |
|
|
400 |
|
(deftest cond-20-slots.3 |
401 |
|
(let ((*cond-20/s1-val* 0) |
402 |
|
(*cond-20/s2-val* 10)) |
403 |
|
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
404 |
|
(let ((c (make-condition 'cond-20 :i2 'y))) |
405 |
|
(values |
406 |
|
(notnot (typep c 'cond-20)) |
407 |
|
(cond-20/s1 c) |
408 |
|
(cond-20/s2 c) |
409 |
|
*cond-20/s1-val* |
410 |
|
*cond-20/s2-val*))) |
411 |
|
t 1 y 1 10) |
412 |
|
|
413 |
|
(deftest cond-20-slots.4 |
414 |
|
(let ((*cond-20/s1-val* 0) |
415 |
|
(*cond-20/s2-val* 10)) |
416 |
|
(declare (special *cond-20/s1-val* *cond-20/s2-val*)) |
417 |
|
(let ((c (make-condition 'cond-20 :i2 'y :i1 'x))) |
418 |
|
(values |
419 |
|
(notnot (typep c 'cond-20)) |
420 |
|
(cond-20/s1 c) |
421 |
|
(cond-20/s2 c) |
422 |
|
*cond-20/s1-val* |
423 |
|
*cond-20/s2-val*))) |
424 |
|
t x y 0 10) |
425 |
|
|
426 |
|
|
427 |
|
;;;;;;;;; tests of inheritance |
428 |
|
|
429 |
|
(define-condition-with-tests cond-21 (cond-4) nil) |
430 |
|
|
431 |
|
(deftest cond-21-slots.1 |
432 |
|
(let ((c (make-condition 'cond-21 :slot1 'a :slot2 'b))) |
433 |
|
(and (typep c 'cond-4) |
434 |
|
(typep c 'cond-21) |
435 |
|
(eqt (cond-4/slot-1 c) 'a) |
436 |
|
(eqt (cond-4/slot-2 c) 'b))) |
437 |
|
t) |
438 |
|
|
439 |
|
(define-condition-with-tests cond-22 (cond-4) |
440 |
|
((slot3 :initarg :slot3 :reader cond-22/slot-3) |
441 |
|
(slot4 :initarg :slot4 :reader cond-22/slot-4))) |
442 |
|
|
443 |
|
(deftest cond-22-slots.1 |
444 |
|
(let ((c (make-condition 'cond-22 :slot1 'a :slot2 'b |
445 |
|
:slot3 'c :slot4 'd))) |
446 |
|
(and (typep c 'cond-4) |
447 |
|
(typep c 'cond-22) |
448 |
|
(eqt (cond-4/slot-1 c) 'a) |
449 |
|
(eqt (cond-4/slot-2 c) 'b) |
450 |
|
(eqt (cond-22/slot-3 c) 'c) |
451 |
|
(eqt (cond-22/slot-4 c) 'd) |
452 |
|
)) |
453 |
|
t) |
454 |
|
|
455 |
|
(define-condition-with-tests cond-23 (cond-5) nil) |
456 |
|
|
457 |
|
(deftest cond-23-slots.1 |
458 |
|
(let ((c (make-condition 'cond-23 :slot1 'a :slot2 'b))) |
459 |
|
(and (typep c 'cond-5) |
460 |
|
(typep c 'cond-23) |
461 |
|
(eqt (cond-4/slot-1 c) 'a) |
462 |
|
(eqt (cond-4/slot-2 c) 'b) |
463 |
|
)) |
464 |
|
t) |
465 |
|
|
466 |
|
(deftest cond-23-slots.2 |
467 |
|
(let ((c (make-condition 'cond-23 :slot1 'a))) |
468 |
|
(and (typep c 'cond-5) |
469 |
|
(typep c 'cond-23) |
470 |
|
(eqt (cond-4/slot-1 c) 'a) |
471 |
|
(eqt (cond-4/slot-2 c) 'y) |
472 |
|
)) |
473 |
|
t) |
474 |
|
|
475 |
|
(deftest cond-23-slots.3 |
476 |
|
(let ((c (make-condition 'cond-23 :slot2 'b))) |
477 |
|
(and (typep c 'cond-5) |
478 |
|
(typep c 'cond-23) |
479 |
|
(eqt (cond-4/slot-1 c) 'x) |
480 |
|
(eqt (cond-4/slot-2 c) 'b) |
481 |
|
)) |
482 |
|
t) |
483 |
|
|
484 |
|
(deftest cond-23-slots.4 |
485 |
|
(let ((c (make-condition 'cond-23))) |
486 |
|
(and (typep c 'cond-5) |
487 |
|
(typep c 'cond-23) |
488 |
|
(eqt (cond-4/slot-1 c) 'x) |
489 |
|
(eqt (cond-4/slot-2 c) 'y) |
490 |
|
)) |
491 |
|
t) |
492 |
|
|
493 |
|
|
494 |
|
|
495 |
|
|