typecase.lsp 3.79 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 22:51:25 2002
;;;; Contains: Tests for TYPECASE

(in-package :cl-test)

(deftest typecase.1
  (typecase 1 (integer 'a) (t 'b))
  a)

(deftest typecase.2
  (typecase 1 (symbol 'a))
  nil)

(deftest typecase.3
  (typecase 1 (symbol 'a) (t 'b))
  b)

(deftest typecase.4
  (typecase 1 (t (values))))

(deftest typecase.5
  (typecase 1 (integer (values)) (t 'a)))

(deftest typecase.6
  (typecase 1 (bit 'a) (integer 'b))
  a)

(deftest typecase.7
  (typecase 1 (otherwise 'a))
  a)

(deftest typecase.8
   (typecase 1 (t (values 'a 'b 'c)))
   a b c)

(deftest typecase.9
   (typecase 1 (integer (values 'a 'b 'c)) (t nil))
   a b c)

(deftest typecase.10
  (let ((x 0))
    (values
     (typecase 1
       (bit     (incf x)   'a)
       (integer (incf x 2) 'b)
       (t       (incf x 4) 'c))
     x))
  a 1)

(deftest typecase.11
   (typecase 1 (otherwise 'a))
   a)

(deftest typecase.12
  (typecase 1 (integer) (t 'a))
  nil)

60
61
62
63
64
65
66
(deftest typecase.13
  (typecase 1 (symbol 'a) (t))
  nil)

(deftest typecase.14
  (typecase 1 (symbol 'a) (otherwise))
  nil)
67
68
69
70
71
72

(deftest typecase.15
  (typecase 'a
    (number 'bad)
    (#.(find-class 'symbol nil) 'good))
  good)
73
74
75
76
77

(deftest typecase.16
  (block done
    (tagbody
     (typecase 'a (symbol (go 10)
sds's avatar
sds committed
78
79
                          10
                          (return-from done 'bad)))
80
81
82
83
84
85
86
87
88
89
     10
     (return-from done 'good)))
  good)

(deftest typecase.17
  (block done
    (tagbody
     (typecase 'a
       (integer 'bad)
       (t (go 10)
sds's avatar
sds committed
90
91
          10
          (return-from done 'bad)))
92
93
94
95
     10
     (return-from done 'good)))
  good)

96
97
(deftest typecase.18
  (loop for x in '(a 1 1.4 "c")
sds's avatar
sds committed
98
99
100
        collect (typecase x
                  (t :good)
                  (otherwise :bad)))
101
102
  (:good :good :good :good))

pfdietz's avatar
pfdietz committed
103
104
105
106
;;; A randomized test

(deftest typecase.19
  (let* ((u (coerce *universe* 'vector))
sds's avatar
sds committed
107
108
109
         (len1 (length u))
         (types (coerce *cl-all-type-symbols* 'vector))
         (len2 (length types)))
pfdietz's avatar
pfdietz committed
110
111
112
113
114
115
    (loop
     for n = (random 10)
     for my-types = (loop repeat n collect (elt types (random len2)))
     for val = (elt u (random len1))
     for i = (position val my-types :test #'typep)
     for form = `(typecase ',val
sds's avatar
sds committed
116
117
                   ,@(loop for i from 0 for type in my-types collect `(,type ,i))
                   (otherwise nil))
pfdietz's avatar
pfdietz committed
118
119
120
121
122
123
     for j = (eval form)
     repeat 1000
     unless (eql i j)
     collect (list n my-types val i form j)))
  nil)

124
125
126
127
128
129
130
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest typecase.20
  (macrolet
   ((%m (z) z))
   (typecase (expand-in-current-env (%m 2))
sds's avatar
sds committed
131
132
133
             ((integer 0 1) :bad1)
             ((integer 2 10) :good)
             (t :bad2)))
134
135
136
137
138
139
  :good)

(deftest typecase.21
  (macrolet
   ((%m (z) z))
   (typecase 2
sds's avatar
sds committed
140
141
142
             ((integer 0 1) (expand-in-current-env (%m :bad1)))
             ((integer 2 10) (expand-in-current-env (%m :good)))
             (t (expand-in-current-env (%m :bad2)))))
143
144
  :good)

145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
(deftest typecase.22
  (macrolet
   ((%m (z) z))
   (typecase
    (expand-in-current-env (%m :foo))
    (integer :bad1)
    (keyword :good)
    (symbol :bad2)))
  :good)

(deftest typecase.23
  (macrolet
   ((%m (z) z))
   (typecase :foo
    (integer (expand-in-current-env (%m :bad1)))
    (keyword (expand-in-current-env (%m :good)))
    (symbol (expand-in-current-env (%m :bad2)))))
  :good)

164
165
;;; Error cases

166
(deftest typecase.error.1
167
168
  (signals-error (funcall (macro-function 'typecase)) program-error)
  t)
169
170

(deftest typecase.error.2
171
  (signals-error (funcall (macro-function 'typecase)
sds's avatar
sds committed
172
                           '(typecase t)) program-error)
173
  t)
174
175

(deftest typecase.error.3
176
  (signals-error (funcall (macro-function 'typecase)
sds's avatar
sds committed
177
178
                           '(typecase t)
                           nil nil) program-error)
179
  t)
180
181
182