etypecase.lsp 3.61 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Oct 18 23:02:23 2002
;;;; Contains: Tests of ETYPECASE

(in-package :cl-test)

8 9
(compile-and-load "types-aux.lsp")

10 11 12 13 14
(deftest etypecase.1
  (etypecase 1 (integer 'a) (t 'b))
  a)

(deftest etypecase.2
15
  (signals-type-error x 1 (etypecase x (symbol 'a)))
16
  t)
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

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

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

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

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

(deftest etypecase.7
  (etypecase 1 (t 'a))
  a)

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

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

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

(deftest etypecase.11
  (etypecase 1 (integer) (t 'a))
  nil)
57 58 59 60 61 62 63

(deftest etypecase.12
  (etypecase 'a
    (number 'bad)
    (#.(find-class 'symbol nil) 'good))
  good)

64 65 66 67 68
(deftest etypecase.13
  (block nil
    (tagbody
     (let ((x 'a))
       (etypecase x (symbol (go 10)
sds's avatar
sds committed
69 70
                            10
                            (return 'bad))))
71 72 73 74
     10
     (return 'good)))
  good)

75 76 77 78 79
(deftest etypecase.14
  (loop
   for x in '(1 a 1.3 "")
   collect
   (etypecase x (t :good) (integer :bad) (symbol :bad)
sds's avatar
sds committed
80
              (float :bad) (string :bad)))
81 82 83 84
  (:good :good :good :good))

(deftest etypecase.15
  (let* ((u (coerce *universe* 'vector))
sds's avatar
sds committed
85 86 87
         (len1 (length u))
         (types (coerce *cl-all-type-symbols* 'vector))
         (len2 (length types)))
88 89 90 91 92 93
    (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 = `(function
sds's avatar
sds committed
94 95 96 97 98 99 100 101 102 103 104
                  (lambda (x)
                    (handler-case
                     (etypecase x
                       ,@(loop for i from 0 for type in my-types collect `(,type ,i)))
                     (type-error (c)
                                 (assert (eql x (type-error-datum c)))
                                 (let* ((expected (type-error-expected-type c)))
                                   (let ((equiv (check-equivalence expected
                                                                   ',(cons 'or my-types))))
                                     (assert (null equiv) () "EQUIV = ~A" EQUIV)))
                                 nil))))
105 106 107 108 109 110
     for j = (funcall (eval form) val)
     repeat 200
     unless (eql i j)
     collect (list n my-types val i form j)))
  nil)

111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
;;; Test that explicit calls to macroexpand in subforms
;;; are done in the correct environment

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

(deftest etypecase.17
  (macrolet
   ((%m (z) z))
   (etypecase :foo
    (integer (expand-in-current-env (%m :bad1)))
    (keyword (expand-in-current-env (%m :good)))
    (symbol (expand-in-current-env (%m :bad2)))))
  :good)
132 133 134

;;; Error cases

135
(deftest etypecase.error.1
136
  (signals-error (funcall (macro-function 'etypecase))
sds's avatar
sds committed
137
                 program-error)
138
  t)
139 140

(deftest etypecase.error.2
141
  (signals-error (funcall (macro-function 'etypecase)
sds's avatar
sds committed
142 143
                           '(etypecase t))
                 program-error)
144
  t)
145 146

(deftest etypecase.error.3
147
  (signals-error (funcall (macro-function 'etypecase)
sds's avatar
sds committed
148 149
                           '(etypecase t) nil nil)
                 program-error)
150
  t)