source: trunk/source/tests/ansi-tests/define-condition-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 2.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Mar  9 05:40:13 2003
4;;;; Contains: Auxiliary functions for testing DEFINE-CONDITION
5
6(in-package :cl-test)
7
8(defun make-def-cond-name (name &rest suffixes)
9  (intern (apply #'concatenate 'string (string name) "/"
10                 (mapcar #'string suffixes))
11          :cl-test))
12
13(defmacro define-condition-with-tests (name-symbol
14                                       parents slot-specs &rest options)
15
16  "Create a condition and some associated tests."
17
18  (assert (symbolp name-symbol))
19  (dolist (parent parents) (assert (symbolp parent)))
20 
21  (let ((name (symbol-name name-symbol)))
22  `(eval-when (:load-toplevel :compile-toplevel :execute)
23     (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents
24                                     ,slot-specs ,@options)))
25     ,@(loop for parent in (adjoin 'condition parents)
26             collect
27             `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent)
28                (subtypep* ',name-symbol ',parent)
29                t t))
30     ,@(loop for parent in (adjoin 'condition parents)
31             collect
32             `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent)
33                (check-all-subtypep ',name-symbol ',parent)
34                nil))
35     ,@(loop for parent in (adjoin 'condition parents)
36             collect
37             `(deftest ,(make-def-cond-name name
38                                            "IS-NOT-SUPERTYPE-OF/" parent)
39                (subtypep* ',parent ',name-symbol)
40                nil t))
41     ,@(loop for parent in (adjoin 'condition parents)
42             collect
43             `(deftest ,(make-def-cond-name name "IS-A/" parent)
44                (let ((c (make-condition ',name-symbol)))
45                  (notnot-mv (typep c ',parent)))
46                t))
47     ,@(loop for parent in (adjoin 'condition parents)
48             collect
49             `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent)
50                (subtypep* (find-class ',name-symbol)
51                           (find-class ',parent))
52                t t))
53     ,@(loop for parent in (adjoin 'condition parents)
54             collect
55             `(deftest ,(make-def-cond-name name
56                                            "IS-NOT-SUPERCLASS-OF/" parent)
57                (subtypep* (find-class ',parent)
58                           (find-class ',name-symbol))
59                nil t))
60     ,@(loop for parent in (adjoin 'condition parents)
61             collect
62             `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/"
63                                            parent)
64                (let ((c (make-condition ',name-symbol)))
65                  (notnot-mv (typep c (find-class ',parent))))
66                t))
67     (deftest ,(make-def-cond-name name "HANDLER-CASE-1")
68       (let ((c (make-condition ',name-symbol)))
69         (handler-case (normally (signal c))
70                       (,name-symbol (c1) (eqt c c1))))
71       t)
72     (deftest ,(make-def-cond-name name "HANDLER-CASE-2")
73       (let ((c (make-condition ',name-symbol)))
74         (handler-case (normally (signal c))
75                       (condition (c1) (eqt c c1))))
76       t)
77     ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents)
78         `((deftest ,(make-def-cond-name name "HANDLER-CASE-3")
79             (let ((c (make-condition ',name-symbol)))
80               (handler-case (normally (signal c))
81                             (error () nil)
82                             (,name-symbol (c2) (eqt c c2))))
83             t)))
84     )))
Note: See TracBrowser for help on using the repository browser.