deftype.lsp 7.5 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sun Apr 20 12:56:56 2003
;;;; Contains: Tests of DEFTYPE

(in-package :cl-test)

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
(compile-and-load "types-aux.lsp")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; deftype

(deftest deftype.1
  (typep 1 '(even-array integer (10)))
  nil)

(deftest deftype.2
  (typep nil '(even-array t (*)))
  nil)

(deftest deftype.3
  (notnot-mv (typep (make-array '(10)) '(even-array t (*))))
  t)

(deftest deftype.4
  (typep (make-array '(5)) '(even-array t (*)))
  nil)

(deftest deftype.5
  (notnot-mv (typep (make-string 10) '(even-array character (*))))
  t)

(deftest deftype.6
  (notnot-mv
   (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8))
sds's avatar
sds committed
36
          '(even-array (unsigned-byte 8))))
37 38
  t)

pfdietz's avatar
pfdietz committed
39 40 41 42 43 44 45 46 47 48 49 50 51 52
(deftest deftype.7
  (let ((sym (gensym)))
    (assert (eq (eval `(deftype ,sym () '(integer 0 10))) sym))
    (documentation sym 'type))
  nil)

(deftest deftype.8
  (let ((sym (gensym)))
    (assert (eq (eval `(deftype ,sym () "FOO" '(integer 0 10))) sym))
    (or (documentation sym 'type) "FOO"))
  "FOO")

(deftest deftype.9
  (let* ((sym (gensym))
sds's avatar
sds committed
53
         (form `(deftype ,sym (&optional x) `(integer 0 ,x))))
pfdietz's avatar
pfdietz committed
54 55 56 57 58 59 60
    (values
     (eqlt (eval form) sym)
     (multiple-value-list (subtypep* `(,sym) 'unsigned-byte))
     (multiple-value-list (subtypep* 'unsigned-byte `(,sym)))
     (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4)))
     (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4)))
     (loop for x in '(a -1 0 1 2 3 4 5 b)
sds's avatar
sds committed
61
           collect (notnot (typep x sym)))
pfdietz's avatar
pfdietz committed
62
     (loop for x in '(a -1 0 1 2 3 4 5 b)
sds's avatar
sds committed
63
           collect (notnot (typep x `(,sym 4))))
pfdietz's avatar
pfdietz committed
64 65 66 67 68 69 70
     ))
  t (t t) (t t) (t t) (t t)
  (nil nil t t t t t t nil)
  (nil nil t t t t t nil nil))

(deftest deftype.10
  (let* ((sym (gensym))
sds's avatar
sds committed
71
         (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x))))
pfdietz's avatar
pfdietz committed
72 73 74 75 76 77 78
    (values
     (eqlt (eval form) sym)
     (multiple-value-list (subtypep* `(,sym) '(integer 0 14)))
     (multiple-value-list (subtypep* '(integer 0 14) `(,sym)))
     (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4)))
     (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4)))
     (loop for x in '(a -1 0 1 2 3 4 5 14 15 b)
sds's avatar
sds committed
79
           collect (notnot (typep x sym)))
pfdietz's avatar
pfdietz committed
80
     (loop for x in '(a -1 0 1 2 3 4 5 14 15 b)
sds's avatar
sds committed
81
           collect (notnot (typep x `(,sym 4))))
pfdietz's avatar
pfdietz committed
82 83 84 85 86 87 88
     ))
  t (t t) (t t) (t t) (t t)
  (nil nil t t t t t t t nil nil)
  (nil nil t t t t t nil nil nil nil))

(deftest deftype.11
  (let* ((sym (gensym))
sds's avatar
sds committed
89
         (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar))))
pfdietz's avatar
pfdietz committed
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
    (values
     (eqlt (eval form) sym)
     (multiple-value-list (subtypep* `(,sym) 'integer))
     (multiple-value-list (subtypep* 'integer `(,sym)))

     (multiple-value-list (subtypep* `(,sym :allow-other-keys nil) 'integer))
     (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil)))
     (multiple-value-list (subtypep* `(,sym :xyz 17 :allow-other-keys t) 'integer))
     (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys t abc nil)))

     (multiple-value-list (subtypep* `(,sym :foo 3) '(integer 3)))
     (multiple-value-list (subtypep* '(integer 3) `(,sym :foo 3)))
     (multiple-value-list (subtypep* `(,sym :bar 10) '(integer * 10)))
     (multiple-value-list (subtypep* '(integer * 10) `(,sym :bar 10)))

     (multiple-value-list (subtypep* `(,sym :foo 3 :foo 4 :bar 6) '(integer 3 6)))
     (multiple-value-list (subtypep* '(integer 3 6) `(,sym :foo 3 :foo 4 :bar 6)))
     (multiple-value-list (subtypep* `(,sym :bar * :foo (1)) '(integer 2)))
     (multiple-value-list (subtypep* '(integer 2) `(,sym :bar * :foo (1))))
     ))
  t
  (t t) (t t)
  (t t) (t t) (t t) (t t)
  (t t) (t t) (t t) (t t)
  (t t) (t t) (t t) (t t)
  )

(deftest deftype.12
  (let* ((sym (gensym))
sds's avatar
sds committed
119
         (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar))))
pfdietz's avatar
pfdietz committed
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
    (values
     (eqlt (eval form) sym)
     (multiple-value-list (subtypep* `(,sym :xyz t) 'integer))
     (multiple-value-list (subtypep* 'integer `(,sym :xyz t)))

     (multiple-value-list (subtypep* `(,sym :allow-other-keys nil abc t) 'integer))
     (multiple-value-list (subtypep* 'integer `(,sym :allow-other-keys nil abc t)))
     (multiple-value-list (subtypep* `(,sym :foo -10 :bar 20) '(integer -10 20)))
     (multiple-value-list (subtypep* '(integer -10 20) `(,sym :foo -10 :bar 20)))
     ))
  t
  (t t) (t t)
  (t t) (t t) (t t) (t t)
  )

(deftest deftype.13
  (let* ((sym (gensym))
sds's avatar
sds committed
137
         (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil))))
pfdietz's avatar
pfdietz committed
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
    (values
     (eqlt (eval form) sym)
;;     (multiple-value-list (subtypep* sym nil))
;;     (multiple-value-list (subtypep* nil sym))
     (multiple-value-list (subtypep* `(,sym) nil))
     (multiple-value-list (subtypep* nil `(,sym)))
     (notnot (typep 'a `(,sym a)))
     (notnot (typep 'b `(,sym a)))
     (notnot (typep '* `(,sym a)))
     (notnot (typep 'a `(,sym a b)))
     (notnot (typep 'b `(,sym a b)))
     (notnot (typep 'c `(,sym a b)))))
  t
  (t t) (t t)
  t nil nil t t nil)

pfdietz's avatar
pfdietz committed
154 155 156 157
;;; I've removed this test, because EVAL can cause implicit compilation,
;;; and the semantic constraints on compilation forbid redefinition of
;;; of the types produced by DEFTYPE at runtime.
#|
pfdietz's avatar
pfdietz committed
158 159
(deftest deftype.14
  (let* ((sym (gensym))
sds's avatar
sds committed
160 161 162 163 164
         (*f* nil)
         (form `(let ((x 1))
                  (declare (special *f*))
                  (setf *f* #'(lambda (y) (setf x y)))
                  (deftype ,sym () `(integer 0 ,x)))))
pfdietz's avatar
pfdietz committed
165 166 167 168 169 170 171
    (declare (special *f*))
    (values
     (eqlt (eval form) sym)
     (loop for i from -1 to 3 collect (typep* i sym))
     (funcall *f* 2)
     (loop for i from -1 to 3 collect (typep* i sym))))
  t (nil t t nil nil) 2 (nil t t t nil))
pfdietz's avatar
pfdietz committed
172
|#
pfdietz's avatar
pfdietz committed
173 174 175

(deftest deftype.15
  (let* ((sym (gensym))
sds's avatar
sds committed
176 177 178 179
         (form `(let ((a 1))
                  (deftype ,sym (&optional (x a))
                    (declare (special a))
                    `(integer 0 ,x)))))
pfdietz's avatar
pfdietz committed
180 181 182 183 184 185 186 187 188 189 190
    (values
     (eqlt (eval form) sym)
     (let ((a 2))
       (declare (special a))
       (loop for i from -1 to 3 collect (typep* i `(,sym 1))))
     (let ((a 2))
       (declare (special a))
       (loop for i from -1 to 3 collect (typep* i sym)))))
  t
  (nil t t nil nil)
  (nil t t nil nil))
sds's avatar
sds committed
191

pfdietz's avatar
pfdietz committed
192 193
(deftest deftype.16
  (let* ((sym (gensym))
sds's avatar
sds committed
194
         (form `(deftype ,sym () (return-from ,sym 'integer))))
pfdietz's avatar
pfdietz committed
195 196 197 198 199 200 201 202
    (values
     (eqlt (eval form) sym)
     (subtypep* sym 'integer)
     (subtypep* 'integer sym)))
  t t t)

(deftest deftype.17
  (let* ((sym (gensym))
sds's avatar
sds committed
203
         (form `(deftype ,sym () (values 'integer t))))
pfdietz's avatar
pfdietz committed
204 205 206 207 208 209 210 211
    (values
     (eqlt (eval form) sym)
     (subtypep* sym 'integer)
     (subtypep* 'integer sym)))
  t t t)

(deftest deftype.18
  (let* ((sym (gensym))
sds's avatar
sds committed
212
         (form `(deftype ,sym ())))
pfdietz's avatar
pfdietz committed
213 214 215 216 217
    (values
     (eqlt (eval form) sym)
     (subtypep* sym nil)
     (subtypep* nil sym)))
  t t t)
218

pfdietz's avatar
pfdietz committed
219 220
(deftest deftype.19
  (let* ((sym (gensym))
sds's avatar
sds committed
221 222 223
         (form `(deftype ,sym ()
                  (declare (optimize speed safety debug compilation-speed space))
                  'integer)))
pfdietz's avatar
pfdietz committed
224 225 226 227 228
    (values
     (eqlt (eval form) sym)
     (subtypep* sym 'integer)
     (subtypep* 'integer sym)))
  t t t)
sds's avatar
sds committed
229

230
;;; Error tests
231

232
(deftest deftype.error.1
233
  (signals-error (funcall (macro-function 'deftype))
sds's avatar
sds committed
234
                 program-error)
235
  t)
236 237

(deftest deftype.error.2
238
  (signals-error (funcall (macro-function 'deftype)
sds's avatar
sds committed
239 240
                           '(deftype nonexistent-type () nil))
                 program-error)
241
  t)
242 243

(deftest deftype.error.3
244
  (signals-error (funcall (macro-function 'deftype)
sds's avatar
sds committed
245 246 247
                           '(deftype nonexistent-type () nil)
                           nil nil)
                 program-error)
248 249
  t)