typecase.lsp 3.77 KB
Newer Older
1 2 3 4 5
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 22:51:25 2002
;;;; Contains: Tests for TYPECASE

6

7 8 9 10 11 12 13 14 15 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

(deftest typecase.1
  (typecase 1 (integer 'a) (t 'b))
  a)

(deftest typecase.2
  (typecase 1 (symbol 'a))
  nil)

(deftest typecase.3
  (typecase 1 (symbol 'a) (t 'b))
  b)

(deftest typecase.4
  (typecase 1 (t (values))))

(deftest typecase.5
  (typecase 1 (integer (values)) (t 'a)))

(deftest typecase.6
  (typecase 1 (bit 'a) (integer 'b))
  a)

(deftest typecase.7
  (typecase 1 (otherwise 'a))
  a)

(deftest typecase.8
   (typecase 1 (t (values 'a 'b 'c)))
   a b c)

(deftest typecase.9
   (typecase 1 (integer (values 'a 'b 'c)) (t nil))
   a b c)

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

(deftest typecase.11
   (typecase 1 (otherwise 'a))
   a)

(deftest typecase.12
  (typecase 1 (integer) (t 'a))
  nil)

60 61 62 63 64 65 66
(deftest typecase.13
  (typecase 1 (symbol 'a) (t))
  nil)

(deftest typecase.14
  (typecase 1 (symbol 'a) (otherwise))
  nil)
67 68 69 70 71 72

(deftest typecase.15
  (typecase 'a
    (number 'bad)
    (#.(find-class 'symbol nil) 'good))
  good)
73 74 75 76 77

(deftest typecase.16
  (block done
    (tagbody
     (typecase 'a (symbol (go 10)
sds's avatar
sds committed
78 79
                          10
                          (return-from done 'bad)))
80 81 82 83 84 85 86 87 88 89
     10
     (return-from done 'good)))
  good)

(deftest typecase.17
  (block done
    (tagbody
     (typecase 'a
       (integer 'bad)
       (t (go 10)
sds's avatar
sds committed
90 91
          10
          (return-from done 'bad)))
92 93 94 95
     10
     (return-from done 'good)))
  good)

96 97
(deftest typecase.18
  (loop for x in '(a 1 1.4 "c")
sds's avatar
sds committed
98 99 100
        collect (typecase x
                  (t :good)
                  (otherwise :bad)))
101 102
  (:good :good :good :good))

103 104 105 106
;;; A randomized test

(deftest typecase.19
  (let* ((u (coerce *universe* 'vector))
sds's avatar
sds committed
107 108 109
         (len1 (length u))
         (types (coerce *cl-all-type-symbols* 'vector))
         (len2 (length types)))
110 111 112 113 114 115
    (loop
     for n = (random 10)
     for my-types = (loop repeat n collect (elt types (random len2)))
     for val = (elt u (random len1))
     for i = (position val my-types :test #'typep)
     for form = `(typecase ',val
sds's avatar
sds committed
116 117
                   ,@(loop for i from 0 for type in my-types collect `(,type ,i))
                   (otherwise nil))
118 119 120 121 122 123
     for j = (eval form)
     repeat 1000
     unless (eql i j)
     collect (list n my-types val i form j)))
  nil)

124 125 126 127 128 129 130
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

(deftest typecase.20
  (macrolet
   ((%m (z) z))
   (typecase (expand-in-current-env (%m 2))
sds's avatar
sds committed
131 132 133
             ((integer 0 1) :bad1)
             ((integer 2 10) :good)
             (t :bad2)))
134 135 136 137 138 139
  :good)

(deftest typecase.21
  (macrolet
   ((%m (z) z))
   (typecase 2
sds's avatar
sds committed
140 141 142
             ((integer 0 1) (expand-in-current-env (%m :bad1)))
             ((integer 2 10) (expand-in-current-env (%m :good)))
             (t (expand-in-current-env (%m :bad2)))))
143 144
  :good)

145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
(deftest typecase.22
  (macrolet
   ((%m (z) z))
   (typecase
    (expand-in-current-env (%m :foo))
    (integer :bad1)
    (keyword :good)
    (symbol :bad2)))
  :good)

(deftest typecase.23
  (macrolet
   ((%m (z) z))
   (typecase :foo
    (integer (expand-in-current-env (%m :bad1)))
    (keyword (expand-in-current-env (%m :good)))
    (symbol (expand-in-current-env (%m :bad2)))))
  :good)

164 165
;;; Error cases

166
(deftest typecase.error.1
167 168
  (signals-error (funcall (macro-function 'typecase)) program-error)
  t)
169 170

(deftest typecase.error.2
171
  (signals-error (funcall (macro-function 'typecase)
sds's avatar
sds committed
172
                           '(typecase t)) program-error)
173
  t)
174 175

(deftest typecase.error.3
176
  (signals-error (funcall (macro-function 'typecase)
sds's avatar
sds committed
177 178
                           '(typecase t)
                           nil nil) program-error)
179
  t)
180 181 182