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