← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/define-condition-aux.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/define-condition-aux.lsp
 
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
     )))