source: trunk/tests/ansi-tests/etypecase.lsp @ 9045

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

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

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 = (let ((ccl::*suppress-compiler-warnings* t))
106               (funcall (eval form) val))
107     repeat 200
108     unless (eql i j)
109     collect (list n my-types val i form j)))
110  nil)
111
112;;; Test that explicit calls to macroexpand in subforms
113;;; are done in the correct environment
114
115(deftest etypecase.16
116  (macrolet
117   ((%m (z) z))
118   (etypecase
119    (expand-in-current-env (%m :foo))
120    (integer :bad1)
121    (keyword :good)
122    (symbol :bad2)))
123  :good)
124
125(deftest etypecase.17
126  (macrolet
127   ((%m (z) z))
128   (etypecase :foo
129    (integer (expand-in-current-env (%m :bad1)))
130    (keyword (expand-in-current-env (%m :good)))
131    (symbol (expand-in-current-env (%m :bad2)))))
132  :good)
133
134;;; Error cases
135
136(deftest etypecase.error.1
137  (signals-error (funcall (macro-function 'etypecase))
138                 program-error)
139  t)
140
141(deftest etypecase.error.2
142  (signals-error (funcall (macro-function 'etypecase)
143                           '(etypecase t))
144                 program-error)
145  t)
146
147(deftest etypecase.error.3
148  (signals-error (funcall (macro-function 'etypecase)
149                           '(etypecase t) nil nil)
150                 program-error)
151  t)
Note: See TracBrowser for help on using the repository browser.