/[gcl]/gcl/ansi-tests/define-condition-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/define-condition-aux.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by pfdietz, Sat Mar 15 19:21:13 2003 UTC revision 1.5 by pfdietz, Wed Apr 9 02:22:26 2003 UTC
# Line 20  Line 20 
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    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26