coerce.lsp 4.69 KB
Newer Older
1 2 3 4 5 6 7 8
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Fri Dec 13 20:48:04 2002
;;;; Contains: Tests for COERCE

(in-package :cl-test)

(deftest coerce.1
9
  (check-predicate #'(lambda (x)
sds's avatar
sds committed
10 11 12
                       (let ((type (type-of x)))
                         (or (and (consp type) (eqt (car type) 'function))
                             (eql (coerce x type) x)))))
13
  nil)
14 15

(deftest coerce.2
16 17
  (check-predicate #'(lambda (x) (eql (coerce x t) x)))
  nil)
18 19

(deftest coerce.3
20 21 22
  (check-predicate
   #'(lambda (x)
       (let ((class (class-of x)))
sds's avatar
sds committed
23
         (eql (coerce x class) x))))
24
  nil)
25 26 27

(deftest coerce.4
  (loop for x in '(() #() #*)
sds's avatar
sds committed
28
        never (coerce x 'list))
29 30 31 32
  t)

(deftest coerce.5
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
33
        always (equal (coerce x 'list) '(1 0)))
34 35 36 37
  t)

(deftest coerce.6
  (loop for x in '(() #() #*)
sds's avatar
sds committed
38
        always (equalp (coerce x 'vector) #()))
39 40 41 42
  t)

(deftest coerce.7
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
43 44 45
        for y = (coerce x 'vector)
        always (and (equalp y #(1 0))
                    (vectorp y)))
46 47 48 49
  t)

(deftest coerce.8
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
50 51 52
        for y = (coerce x '(vector *))
        always (and (equalp y #(1 0))
                    (vectorp y)))
53 54 55 56
  t)

(deftest coerce.9
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
57 58 59
        for y = (coerce x '(vector * 2))
        always (and (equalp y #(1 0))
                    (vectorp y)))
60 61 62 63
  t)

(deftest coerce.10
  (values (coerce #\A 'character)
sds's avatar
sds committed
64 65
          (coerce '|A| 'character)
          (coerce "A" 'character))
66 67 68 69
  #\A #\A #\A)

(deftest coerce.11
  (loop with class = (find-class 'vector)
sds's avatar
sds committed
70 71 72 73
        for x in '((1 0) #(1 0) #*10)
        for y = (coerce x class)
        always (and (equalp y #(1 0))
                    (vectorp y)))
74 75 76 77
  t)

(deftest coerce.12
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
78 79 80
        for y = (coerce x 'bit-vector)
        always (and (equalp y #*10)
                    (bit-vector-p y)))
81 82 83 84
  t)

(deftest coerce.13
  (loop for x in '((#\a #\b #\c) "abc")
sds's avatar
sds committed
85 86 87
        for y = (coerce x 'string)
        always (and (stringp y)
                    (string= y "abc")))
88 89 90 91
  t)

(deftest coerce.14
  (loop for x in '((#\a #\b #\c) "abc")
sds's avatar
sds committed
92 93 94
        for y = (coerce x 'simple-string)
        always (and (typep y 'simple-string)
                    (string= y "abc")))
95 96 97 98
  t)

(deftest coerce.15
  (loop for x in '((1 0) #(1 0) #*10)
sds's avatar
sds committed
99 100 101
        for y = (coerce x 'simple-vector)
        always (and (equalp y #(1 0))
                    (simple-vector-p y)))
102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
  t)

(deftest coerce.16
  (coerce 0 'integer)
  0)

(deftest coerce.17
  (coerce 0 'complex)
  0)

(deftest coerce.18
  (coerce 3 'complex)
  3)

(deftest coerce.19
  (coerce 5/3 'complex)
  5/3)

(deftest coerce.20
  (coerce 1.0 'complex)
  #c(1.0 0.0))

(deftest coerce.21
  (eqt (symbol-function 'car)
       (coerce 'car 'function))
  t)

(deftest coerce.22
  (funcall (coerce '(lambda () 10) 'function))
  10)

133
(deftest coerce.order.1
134 135 136
  (let ((i 0) a b)
    (values
     (coerce (progn (setf a (incf i)) 10)
sds's avatar
sds committed
137
             (progn (setf b (incf i)) 'single-float))
138 139 140
     i a b))
  10.0f0 2 1 2)

141 142 143 144
;;; Constant folding test
;;; If the coerce call is folded to a constant, this will fail
;;; when that constant is modified.

145 146 147
(def-fold-test coerce.fold.1 (coerce '(1 2 3) 'vector))
(def-fold-test coerce.fold.2 (coerce '(1 0 1) 'bit-vector))
(def-fold-test coerce.fold.3 (coerce '(#\a #\b #\c) 'string))
148

149 150
;;; Error tests

151
;;; (deftest coerce.error.1
152 153
;;;  (signals-error (coerce -1 '(integer 0 100)) type-error)
;;;  t)
154 155

(deftest coerce.error.2
156 157
  (signals-error (coerce '(a b c) '(vector * 2)) type-error)
  t)
158 159

(deftest coerce.error.3
160 161
  (signals-error (coerce '(a b c) '(vector * 4)) type-error)
  t)
162 163

(deftest coerce.error.4
164 165
  (signals-error (coerce nil 'cons) type-error)
  t)
166 167

(deftest coerce.error.5
168 169 170
  (handler-case
   (eval '(coerce 'not-a-bound-function 'function))
   (error () :caught))
171 172
  :caught)

173
(deftest coerce.error.6
174 175
  (signals-error (coerce) program-error)
  t)
176

177
(deftest coerce.error.7
178 179
  (signals-error (coerce t) program-error)
  t)
180

181
(deftest coerce.error.8
182 183
  (signals-error (coerce 'x t 'foo) program-error)
  t)
184 185

(deftest coerce.error.9
186 187 188
  (signals-error (locally (coerce nil 'cons) t) type-error)
  t)

189
(deftest coerce.error.10
pfdietz's avatar
pfdietz committed
190
  :notes (:result-type-element-type-by-subtype)
191
  (let* ((tp1 '(vector character))
sds's avatar
sds committed
192 193
         (tp2 `(vector t))
         (tp3 `(or ,tp1 ,tp2)))
194
    (if (not (subtypep tp3 'vector))
sds's avatar
sds committed
195
        t
196 197 198
      (handler-case
       (eval `(coerce '(#\a #\b #\c) ',tp3))
       (type-error (c)
sds's avatar
sds committed
199 200 201 202 203 204 205
         (cond
          ((typep (type-error-datum c)
                  (type-error-expected-type c))
           `((typep ',(type-error-datum c)
                    ',(type-error-expected-type c))
             "==>" true))
          (t t)))
206 207
       (error (c) (declare (ignore c)) t))))
  t)