define-condition-aux.lsp 2.91 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Mar  9 05:40:13 2003
;;;; Contains: Auxiliary functions for testing DEFINE-CONDITION

(in-package :cl-test)

(defun make-def-cond-name (name &rest suffixes)
  (intern (apply #'concatenate 'string (string name) "/"
		 (mapcar #'string suffixes))
	  :cl-test))

(defmacro define-condition-with-tests (name-symbol
				       parents slot-specs &rest options)

  "Create a condition and some associated tests."

  (assert (symbolp name-symbol))
  (dolist (parent parents) (assert (symbolp parent)))
  
  (let ((name (symbol-name name-symbol)))
22
23
  `(eval-when #+gcl (load eval compile)
	      #-gcl (:load-toplevel :compile-toplevel :execute)
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
     (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)))
70
	 (handler-case (normally (signal c))
71
72
73
74
		       (,name-symbol (c1) (eqt c c1))))
       t)
     (deftest ,(make-def-cond-name name "HANDLER-CASE-2")
       (let ((c (make-condition ',name-symbol)))
75
	 (handler-case (normally (signal c))
76
77
78
79
80
		       (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)))
81
	       (handler-case (normally (signal c))
82
83
84
85
			     (error () nil)
			     (,name-symbol (c2) (eqt c c2))))
	     t)))
     )))