Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
ansi-test
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Karsten Poeck
ansi-test
Commits
66491a8d
Commit
66491a8d
authored
Apr 09, 2003
by
pfdietz
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Make the IGNORE-ERRORS form work properly around DEFINE-CONDITION.
parent
2b92c78a
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
62 additions
and
62 deletions
+62
-62
ansi-tests/define-condition-aux.lsp
ansi-tests/define-condition-aux.lsp
+62
-62
No files found.
ansi-tests/define-condition-aux.lsp
View file @
66491a8d
...
...
@@ -20,68 +20,68 @@
(let ((name (symbol-name name-symbol)))
`(eval-when (load eval compile)
(ignore-errors
(define-condition ,name-symbol ,parents ,slot-specs ,@options
)
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent)
(subtypep* ',name-symbol ',parent)
t t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent)
(check-all-subtypep ',name-symbol ',parent)
nil))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name
"IS-NOT-SUPERTYPE-OF/" parent)
(subtypep* ',parent ',name-symbol)
nil t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-A/" parent)
(let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c ',parent)))
t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent)
(subtypep* (find-class ',name-symbol)
(find-class ',parent))
t t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name
"IS-NOT-SUPERCLASS-OF/" parent)
(subtypep* (find-class ',parent)
(find-class ',name-symbol))
nil t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/"
parent)
(let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c (find-class ',parent))))
t))
(deftest ,(make-def-cond-name name "HANDLER-CASE-1")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(,name-symbol (c1) (eqt c c1))))
t)
(deftest ,(make-def-cond-name name "HANDLER-CASE-2")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(condition (c1) (eqt c c1))))
t)
,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents)
`((deftest ,(make-def-cond-name name "HANDLER-CASE-3")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(error () nil)
(,name-symbol (c2) (eqt c c2))))
t)))
)
)))
(ignore-errors
(eval '(define-condition ,name-symbol ,parents
,slot-specs ,@options))
)
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent)
(subtypep* ',name-symbol ',parent)
t t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent)
(check-all-subtypep ',name-symbol ',parent)
nil))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name
"IS-NOT-SUPERTYPE-OF/" parent)
(subtypep* ',parent ',name-symbol)
nil t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-A/" parent)
(let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c ',parent)))
t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent)
(subtypep* (find-class ',name-symbol)
(find-class ',parent))
t t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name
"IS-NOT-SUPERCLASS-OF/" parent)
(subtypep* (find-class ',parent)
(find-class ',name-symbol))
nil t))
,@(loop for parent in (adjoin 'condition parents)
collect
`(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/"
parent)
(let ((c (make-condition ',name-symbol)))
(notnot-mv (typep c (find-class ',parent))))
t))
(deftest ,(make-def-cond-name name "HANDLER-CASE-1")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(,name-symbol (c1) (eqt c c1))))
t)
(deftest ,(make-def-cond-name name "HANDLER-CASE-2")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(condition (c1) (eqt c c1))))
t)
,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents)
`((deftest ,(make-def-cond-name name "HANDLER-CASE-3")
(let ((c (make-condition ',name-symbol)))
(handler-case (signal c)
(error () nil)
(,name-symbol (c2) (eqt c c2))))
t)))
)))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment