20 |
|
|
21 |
(let ((name (symbol-name name-symbol))) |
(let ((name (symbol-name name-symbol))) |
22 |
`(eval-when (load eval compile) |
`(eval-when (load eval compile) |
23 |
(ignore-errors |
(ignore-errors (eval '(define-condition ,name-symbol ,parents |
24 |
(define-condition ,name-symbol ,parents ,slot-specs ,@options) |
,slot-specs ,@options))) |
25 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
26 |
collect |
collect |
27 |
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) |
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) |
28 |
(subtypep* ',name-symbol ',parent) |
(subtypep* ',name-symbol ',parent) |
29 |
t t)) |
t t)) |
30 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
31 |
collect |
collect |
32 |
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) |
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) |
33 |
(check-all-subtypep ',name-symbol ',parent) |
(check-all-subtypep ',name-symbol ',parent) |
34 |
nil)) |
nil)) |
35 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
36 |
collect |
collect |
37 |
`(deftest ,(make-def-cond-name name |
`(deftest ,(make-def-cond-name name |
38 |
"IS-NOT-SUPERTYPE-OF/" parent) |
"IS-NOT-SUPERTYPE-OF/" parent) |
39 |
(subtypep* ',parent ',name-symbol) |
(subtypep* ',parent ',name-symbol) |
40 |
nil t)) |
nil t)) |
41 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
42 |
collect |
collect |
43 |
`(deftest ,(make-def-cond-name name "IS-A/" parent) |
`(deftest ,(make-def-cond-name name "IS-A/" parent) |
44 |
(let ((c (make-condition ',name-symbol))) |
(let ((c (make-condition ',name-symbol))) |
45 |
(notnot-mv (typep c ',parent))) |
(notnot-mv (typep c ',parent))) |
46 |
t)) |
t)) |
47 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
48 |
collect |
collect |
49 |
`(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) |
`(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) |
50 |
(subtypep* (find-class ',name-symbol) |
(subtypep* (find-class ',name-symbol) |
51 |
(find-class ',parent)) |
(find-class ',parent)) |
52 |
t t)) |
t t)) |
53 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
54 |
collect |
collect |
55 |
`(deftest ,(make-def-cond-name name |
`(deftest ,(make-def-cond-name name |
56 |
"IS-NOT-SUPERCLASS-OF/" parent) |
"IS-NOT-SUPERCLASS-OF/" parent) |
57 |
(subtypep* (find-class ',parent) |
(subtypep* (find-class ',parent) |
58 |
(find-class ',name-symbol)) |
(find-class ',name-symbol)) |
59 |
nil t)) |
nil t)) |
60 |
,@(loop for parent in (adjoin 'condition parents) |
,@(loop for parent in (adjoin 'condition parents) |
61 |
collect |
collect |
62 |
`(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" |
`(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" |
63 |
parent) |
parent) |
64 |
(let ((c (make-condition ',name-symbol))) |
(let ((c (make-condition ',name-symbol))) |
65 |
(notnot-mv (typep c (find-class ',parent)))) |
(notnot-mv (typep c (find-class ',parent)))) |
66 |
t)) |
t)) |
67 |
(deftest ,(make-def-cond-name name "HANDLER-CASE-1") |
(deftest ,(make-def-cond-name name "HANDLER-CASE-1") |
68 |
(let ((c (make-condition ',name-symbol))) |
(let ((c (make-condition ',name-symbol))) |
69 |
(handler-case (signal c) |
(handler-case (signal c) |
70 |
(,name-symbol (c1) (eqt c c1)))) |
(,name-symbol (c1) (eqt c c1)))) |
71 |
t) |
t) |
72 |
(deftest ,(make-def-cond-name name "HANDLER-CASE-2") |
(deftest ,(make-def-cond-name name "HANDLER-CASE-2") |
73 |
(let ((c (make-condition ',name-symbol))) |
(let ((c (make-condition ',name-symbol))) |
74 |
(handler-case (signal c) |
(handler-case (signal c) |
75 |
(condition (c1) (eqt c c1)))) |
(condition (c1) (eqt c c1)))) |
76 |
t) |
t) |
77 |
,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) |
,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) |
78 |
`((deftest ,(make-def-cond-name name "HANDLER-CASE-3") |
`((deftest ,(make-def-cond-name name "HANDLER-CASE-3") |
79 |
(let ((c (make-condition ',name-symbol))) |
(let ((c (make-condition ',name-symbol))) |
80 |
(handler-case (signal c) |
(handler-case (signal c) |
81 |
(error () nil) |
(error () nil) |
82 |
(,name-symbol (c2) (eqt c c2)))) |
(,name-symbol (c2) (eqt c c2)))) |
83 |
t))) |
t))) |
84 |
)))) |
))) |
85 |
|
|
86 |
|
|
87 |
|
|