source: trunk/source/tests/ansi-tests/ctypecase.lsp @ 8991

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

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

File size: 2.7 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Oct 18 23:05:10 2002
4;;;; Contains: Tests of CTYPECASE
5
6(in-package :cl-test)
7
8(deftest ctypecase.1
9  (let ((x 1))
10    (ctypecase x (integer 'a) (t 'b)))
11  a)
12
13(deftest ctypecase.2
14  (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp)
15  nil)
16
17(deftest ctypecase.3
18  (let ((x 1))
19    (ctypecase x (symbol 'a) (t 'b)))
20  b)
21
22(deftest ctypecase.4
23  (let ((x 1))
24    (ctypecase x (t (values)))))
25
26(deftest ctypecase.5
27  (let ((x 1))
28    (ctypecase x (integer (values)) (t 'a))))
29
30(deftest ctypecase.6
31  (let ((x 1))
32    (ctypecase x (bit 'a) (integer 'b)))
33  a)
34
35(deftest ctypecase.7
36  (let ((x 1))
37    (ctypecase x (t 'a)))
38  a)
39
40(deftest ctypecase.8
41  (let ((x 1))
42    (ctypecase x (t (values 'a 'b 'c))))
43  a b c)
44
45(deftest ctypecase.9
46  (let ((x 1))
47    (ctypecase x (integer (values 'a 'b 'c)) (t nil)))
48  a b c)
49
50(deftest ctypecase.10
51  (let ((x 0) (y 1))
52    (values
53     (ctypecase y
54       (bit     (incf x)   'a)
55       (integer (incf x 2) 'b)
56       (t       (incf x 4) 'c))
57     x))
58  a 1)
59
60(deftest ctypecase.11
61  (let ((x 1))
62    (ctypecase x (integer) (t 'a)))
63  nil)
64
65(deftest ctypecase.12
66  (let ((x 1))
67    (values
68     (handler-bind
69      ((type-error #'(lambda (c)
70                       (assert (eql (type-error-datum c) 1))
71                       (assert (not (typep 1 (type-error-expected-type c))))
72                       (store-value 'a c))))
73      (ctypecase x
74       (symbol :good)
75       (float :bad)))
76     x))
77  :good a)
78
79;;; (deftest ctypecase.error.1
80;;;  (signals-error (ctypecase) program-error)
81;;;  t)
82
83
84(deftest ctypecase.13
85  (let ((x 'a))
86    (ctypecase x
87               (number 'bad)
88               (#.(find-class 'symbol nil) 'good)))
89  good)
90
91(deftest ctypecase.14
92  (block done
93    (tagbody
94     (let ((x 'a))
95       (ctypecase x (symbol (go 10)
96                            10
97                            (return-from done 'bad))))
98     10
99     (return-from done 'good)))
100  good)
101
102;;; Test that explicit calls to macroexpand in subforms
103;;; are done in the correct environment
104
105(deftest ctypecase.15
106  (macrolet
107   ((%m (z) z))
108   (ctypecase
109    (expand-in-current-env (%m :foo))
110    (integer :bad1)
111    (keyword :good)
112    (symbol :bad2)))
113  :good)
114
115(deftest ctypecase.16
116  (macrolet
117   ((%m (z) z))
118   (ctypecase :foo
119    (integer (expand-in-current-env (%m :bad1)))
120    (keyword (expand-in-current-env (%m :good)))
121    (symbol (expand-in-current-env (%m :bad2)))))
122  :good)
123
124(deftest ctypecase.error.1
125  (signals-error (funcall (macro-function 'ctypecase))
126                 program-error)
127  t)
128
129(deftest ctypecase.error.2
130  (signals-error (funcall (macro-function 'ctypecase)
131                           '(ctypecase t))
132                 program-error)
133  t)
134
135(deftest ctypecase.error.3
136  (signals-error (funcall (macro-function 'ctypecase)
137                           '(ctypecase t)
138                           nil nil)
139                 program-error)
140  t)
Note: See TracBrowser for help on using the repository browser.