ctypecase.lsp 3.18 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 23:05:10 2002
;;;; Contains: Tests of CTYPECASE

6

7 8 9 10 11 12 13

(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)