Skip to content
Snippets Groups Projects
Commit 66491a8d authored by pfdietz's avatar pfdietz
Browse files

Make the IGNORE-ERRORS form work properly around DEFINE-CONDITION.

parent 2b92c78a
No related branches found
No related tags found
No related merge requests found
...@@ -20,68 +20,68 @@ ...@@ -20,68 +20,68 @@
(let ((name (symbol-name name-symbol))) (let ((name (symbol-name name-symbol)))
`(eval-when (load eval compile) `(eval-when (load eval compile)
(ignore-errors (ignore-errors (eval '(define-condition ,name-symbol ,parents
(define-condition ,name-symbol ,parents ,slot-specs ,@options) ,slot-specs ,@options)))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent)
(subtypep* ',name-symbol ',parent) (subtypep* ',name-symbol ',parent)
t t)) t t))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent)
(check-all-subtypep ',name-symbol ',parent) (check-all-subtypep ',name-symbol ',parent)
nil)) nil))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name `(deftest ,(make-def-cond-name name
"IS-NOT-SUPERTYPE-OF/" parent) "IS-NOT-SUPERTYPE-OF/" parent)
(subtypep* ',parent ',name-symbol) (subtypep* ',parent ',name-symbol)
nil t)) nil t))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name "IS-A/" parent) `(deftest ,(make-def-cond-name name "IS-A/" parent)
(let ((c (make-condition ',name-symbol))) (let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c ',parent))) (notnot-mv (typep c ',parent)))
t)) t))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent)
(subtypep* (find-class ',name-symbol) (subtypep* (find-class ',name-symbol)
(find-class ',parent)) (find-class ',parent))
t t)) t t))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name `(deftest ,(make-def-cond-name name
"IS-NOT-SUPERCLASS-OF/" parent) "IS-NOT-SUPERCLASS-OF/" parent)
(subtypep* (find-class ',parent) (subtypep* (find-class ',parent)
(find-class ',name-symbol)) (find-class ',name-symbol))
nil t)) nil t))
,@(loop for parent in (adjoin 'condition parents) ,@(loop for parent in (adjoin 'condition parents)
collect collect
`(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/"
parent) parent)
(let ((c (make-condition ',name-symbol))) (let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c (find-class ',parent)))) (notnot-mv (typep c (find-class ',parent))))
t)) t))
(deftest ,(make-def-cond-name name "HANDLER-CASE-1") (deftest ,(make-def-cond-name name "HANDLER-CASE-1")
(let ((c (make-condition ',name-symbol))) (let ((c (make-condition ',name-symbol)))
(handler-case (signal c) (handler-case (signal c)
(,name-symbol (c1) (eqt c c1)))) (,name-symbol (c1) (eqt c c1))))
t) t)
(deftest ,(make-def-cond-name name "HANDLER-CASE-2") (deftest ,(make-def-cond-name name "HANDLER-CASE-2")
(let ((c (make-condition ',name-symbol))) (let ((c (make-condition ',name-symbol)))
(handler-case (signal c) (handler-case (signal c)
(condition (c1) (eqt c c1)))) (condition (c1) (eqt c c1))))
t) t)
,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents)
`((deftest ,(make-def-cond-name name "HANDLER-CASE-3") `((deftest ,(make-def-cond-name name "HANDLER-CASE-3")
(let ((c (make-condition ',name-symbol))) (let ((c (make-condition ',name-symbol)))
(handler-case (signal c) (handler-case (signal c)
(error () nil) (error () nil)
(,name-symbol (c2) (eqt c c2)))) (,name-symbol (c2) (eqt c c2))))
t))) t)))
)))) )))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment