source: trunk/tests/ansi-tests/ctypecase.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: 2.8 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#+bogus-test  ;; first arg to ctypecase must be a "place"
106(deftest ctypecase.15
107  (macrolet
108   ((%m (z) z))
109   (ctypecase
110    (expand-in-current-env (%m :foo))
111    (integer :bad1)
112    (keyword :good)
113    (symbol :bad2)))
114  :good)
115
116(deftest ctypecase.16
117  (macrolet
118   ((%m (z) z))
119    (let ((place :foo))
120      (ctypecase place
121        (integer (expand-in-current-env (%m :bad1)))
122        (keyword (expand-in-current-env (%m :good)))
123        (symbol (expand-in-current-env (%m :bad2))))))
124  :good)
125
126(deftest ctypecase.error.1
127  (signals-error (funcall (macro-function 'ctypecase))
128                 program-error)
129  t)
130
131(deftest ctypecase.error.2
132  (signals-error (funcall (macro-function 'ctypecase)
133                           '(ctypecase t))
134                 program-error)
135  t)
136
137(deftest ctypecase.error.3
138  (signals-error (funcall (macro-function 'ctypecase)
139                           '(ctypecase t)
140                           nil nil)
141                 program-error)
142  t)
Note: See TracBrowser for help on using the repository browser.