ctypecase.lsp 3.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 23:05:10 2002
;;;; Contains: Tests of CTYPECASE

(in-package :cl-test)

(deftest ctypecase.1
  (let ((x 1))
    (ctypecase x (integer 'a) (t 'b)))
  a)

(deftest ctypecase.2
14
15
  (check-type-error #'(lambda (x) (ctypecase x (symbol 'a))) #'symbolp)
  nil)
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
60
61
62
63
64

(deftest ctypecase.3
  (let ((x 1))
    (ctypecase x (symbol 'a) (t 'b)))
  b)

(deftest ctypecase.4
  (let ((x 1))
    (ctypecase x (t (values)))))

(deftest ctypecase.5
  (let ((x 1))
    (ctypecase x (integer (values)) (t 'a))))

(deftest ctypecase.6
  (let ((x 1))
    (ctypecase x (bit 'a) (integer 'b)))
  a)

(deftest ctypecase.7
  (let ((x 1))
    (ctypecase x (t 'a)))
  a)

(deftest ctypecase.8
  (let ((x 1))
    (ctypecase x (t (values 'a 'b 'c))))
  a b c)

(deftest ctypecase.9
  (let ((x 1))
    (ctypecase x (integer (values 'a 'b 'c)) (t nil)))
  a b c)

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

(deftest ctypecase.11
  (let ((x 1))
    (ctypecase x (integer) (t 'a)))
  nil)

65
66
67
68
(deftest ctypecase.12
  (let ((x 1))
    (values
     (handler-bind
69
      ((type-error #'(lambda (c)
sds's avatar
sds committed
70
71
72
                       (assert (eql (type-error-datum c) 1))
                       (assert (not (typep 1 (type-error-expected-type c))))
                       (store-value 'a c))))
73
74
75
76
77
      (ctypecase x
       (symbol :good)
       (float :bad)))
     x))
  :good a)
78

79
;;; (deftest ctypecase.error.1
80
81
;;;  (signals-error (ctypecase) program-error)
;;;  t)
82
83
84


(deftest ctypecase.13
85
86
  (let ((x 'a))
    (ctypecase x
sds's avatar
sds committed
87
88
               (number 'bad)
               (#.(find-class 'symbol nil) 'good)))
89
90
  good)

91
92
93
94
95
(deftest ctypecase.14
  (block done
    (tagbody
     (let ((x 'a))
       (ctypecase x (symbol (go 10)
sds's avatar
sds committed
96
97
                            10
                            (return-from done 'bad))))
98
99
100
101
     10
     (return-from done 'good)))
  good)

102
103
104
105
106
107
108
109
110
;; Following tests (ctypecase.15 and ctypecase.16) are invalid, since
;; ctypecase provides restart, which evaluates to assignment to :foo,
;; which is constant. Both tests were transformed into valid ones and
;; moved to typecase.lsp (typecase.22 and typecase.23).
;;
;; Related discussion:
;; https://mailman.common-lisp.net/pipermail/ansi-test-devel/2012-January/000108.html

#+(or)
111
112
113
114
115
116
117
118
119
120
(deftest ctypecase.15
  (macrolet
   ((%m (z) z))
   (ctypecase
    (expand-in-current-env (%m :foo))
    (integer :bad1)
    (keyword :good)
    (symbol :bad2)))
  :good)

121
#+(or)
122
123
124
125
126
127
128
129
130
(deftest ctypecase.16
  (macrolet
   ((%m (z) z))
   (ctypecase :foo
    (integer (expand-in-current-env (%m :bad1)))
    (keyword (expand-in-current-env (%m :good)))
    (symbol (expand-in-current-env (%m :bad2)))))
  :good)

131
(deftest ctypecase.error.1
132
  (signals-error (funcall (macro-function 'ctypecase))
sds's avatar
sds committed
133
                 program-error)
134
  t)
135
136

(deftest ctypecase.error.2
137
  (signals-error (funcall (macro-function 'ctypecase)
sds's avatar
sds committed
138
139
                           '(ctypecase t))
                 program-error)
140
  t)
141
142

(deftest ctypecase.error.3
143
  (signals-error (funcall (macro-function 'ctypecase)
sds's avatar
sds committed
144
145
146
                           '(ctypecase t)
                           nil nil)
                 program-error)
147
  t)