source: trunk/source/tests/ansi-tests/typecase.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: 3.2 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Fri Oct 18 22:51:25 2002
4;;;; Contains: Tests for TYPECASE
5
6(in-package :cl-test)
7
8(deftest typecase.1
9  (typecase 1 (integer 'a) (t 'b))
10  a)
11
12(deftest typecase.2
13  (typecase 1 (symbol 'a))
14  nil)
15
16(deftest typecase.3
17  (typecase 1 (symbol 'a) (t 'b))
18  b)
19
20(deftest typecase.4
21  (typecase 1 (t (values))))
22
23(deftest typecase.5
24  (typecase 1 (integer (values)) (t 'a)))
25
26(deftest typecase.6
27  (typecase 1 (bit 'a) (integer 'b))
28  a)
29
30(deftest typecase.7
31  (typecase 1 (otherwise 'a))
32  a)
33
34(deftest typecase.8
35   (typecase 1 (t (values 'a 'b 'c)))
36   a b c)
37
38(deftest typecase.9
39   (typecase 1 (integer (values 'a 'b 'c)) (t nil))
40   a b c)
41
42(deftest typecase.10
43  (let ((x 0))
44    (values
45     (typecase 1
46       (bit     (incf x)   'a)
47       (integer (incf x 2) 'b)
48       (t       (incf x 4) 'c))
49     x))
50  a 1)
51
52(deftest typecase.11
53   (typecase 1 (otherwise 'a))
54   a)
55
56(deftest typecase.12
57  (typecase 1 (integer) (t 'a))
58  nil)
59
60(deftest typecase.13
61  (typecase 1 (symbol 'a) (t))
62  nil)
63
64(deftest typecase.14
65  (typecase 1 (symbol 'a) (otherwise))
66  nil)
67
68(deftest typecase.15
69  (typecase 'a
70    (number 'bad)
71    (#.(find-class 'symbol nil) 'good))
72  good)
73
74(deftest typecase.16
75  (block done
76    (tagbody
77     (typecase 'a (symbol (go 10)
78                          10
79                          (return-from done 'bad)))
80     10
81     (return-from done 'good)))
82  good)
83
84(deftest typecase.17
85  (block done
86    (tagbody
87     (typecase 'a
88       (integer 'bad)
89       (t (go 10)
90          10
91          (return-from done 'bad)))
92     10
93     (return-from done 'good)))
94  good)
95
96(deftest typecase.18
97  (loop for x in '(a 1 1.4 "c")
98        collect (typecase x
99                  (t :good)
100                  (otherwise :bad)))
101  (:good :good :good :good))
102
103;;; A randomized test
104
105(deftest typecase.19
106  (let* ((u (coerce *universe* 'vector))
107         (len1 (length u))
108         (types (coerce *cl-all-type-symbols* 'vector))
109         (len2 (length types)))
110    (loop
111     for n = (random 10)
112     for my-types = (loop repeat n collect (elt types (random len2)))
113     for val = (elt u (random len1))
114     for i = (position val my-types :test #'typep)
115     for form = `(typecase ',val
116                   ,@(loop for i from 0 for type in my-types collect `(,type ,i))
117                   (otherwise nil))
118     for j = (eval form)
119     repeat 1000
120     unless (eql i j)
121     collect (list n my-types val i form j)))
122  nil)
123
124;;; Test that explicit calls to macroexpand in subforms
125;;; are done in the correct environment
126
127(deftest typecase.20
128  (macrolet
129   ((%m (z) z))
130   (typecase (expand-in-current-env (%m 2))
131             ((integer 0 1) :bad1)
132             ((integer 2 10) :good)
133             (t :bad2)))
134  :good)
135
136(deftest typecase.21
137  (macrolet
138   ((%m (z) z))
139   (typecase 2
140             ((integer 0 1) (expand-in-current-env (%m :bad1)))
141             ((integer 2 10) (expand-in-current-env (%m :good)))
142             (t (expand-in-current-env (%m :bad2)))))
143  :good)
144
145;;; Error cases
146
147(deftest typecase.error.1
148  (signals-error (funcall (macro-function 'typecase)) program-error)
149  t)
150
151(deftest typecase.error.2
152  (signals-error (funcall (macro-function 'typecase)
153                           '(typecase t)) program-error)
154  t)
155
156(deftest typecase.error.3
157  (signals-error (funcall (macro-function 'typecase)
158                           '(typecase t)
159                           nil nil) program-error)
160  t)
161
162
163
Note: See TracBrowser for help on using the repository browser.