typep.lsp 3.55 KB
Newer Older
1 2 3 4 5 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
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon May 23 07:13:32 2005
;;;; Contains: Tests of TYPEP

(in-package :cl-test)

(deftest typep.error.1
  (signals-error (typep) program-error)
  t)

(deftest typep.error.2
  (signals-error (typep nil) program-error)
  t)

(deftest typep.error.3
  (signals-error (typep nil t nil nil) program-error)
  t)

(deftest typep.error.4
  (signals-error-always (typep nil 'values) error)
  t t)

(deftest typep.error.5
  (signals-error-always (typep nil '(values)) error)
  t t)

(deftest typep.error.6
  (signals-error-always (typep nil '(values t t t t)) error)
  t t)

(deftest typep.error.7
  (signals-error-always (typep nil '(function () t)) error)
  t t)

pfdietz's avatar
pfdietz committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54
;;; Non-error tests
;;; Many more tests use typep when testing other functions

(deftest typep-nil-null
  (notnot-mv (typep nil 'null))
  t)

(deftest typep-t-null
  (typep t 'null)
  nil)

;;; Tests of env arguments to typep

(deftest typep.env.1
  (notnot-mv (typep 0 'bit nil))
  t)

(deftest typep.env.2
  (macrolet ((%foo (&environment env)
sds's avatar
sds committed
55
                   (notnot-mv (typep 0 'bit env))))
pfdietz's avatar
pfdietz committed
56 57 58 59 60
    (%foo))
  t)

(deftest typep.env.3
  (macrolet ((%foo (&environment env)
sds's avatar
sds committed
61
                   (notnot-mv (typep env (type-of env)))))
pfdietz's avatar
pfdietz committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 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 119 120 121 122 123 124 125 126 127 128 129 130 131 132
    (%foo))
  t)

;;; Other typep tests

(deftest typep.1
  (notnot-mv (typep 'a '(eql a)))
  t)

(deftest typep.2
  (notnot-mv (typep 'a '(and (eql a))))
  t)

(deftest typep.3
  (notnot-mv (typep 'a '(or (eql a))))
  t)

(deftest typep.4
  (typep 'a '(eql b))
  nil)

(deftest typep.5
  (typep 'a '(and (eql b)))
  nil)

(deftest typep.6
  (typep 'a '(or (eql b)))
  nil)

(deftest typep.7
  (notnot-mv (typep 'a '(satisfies symbolp)))
  t)

(deftest typep.8
  (typep 10 '(satisfies symbolp))
  nil)

(deftest typep.9
  (let ((class (find-class 'symbol)))
    (notnot-mv (typep 'a class)))
  t)

(deftest typep.10
  (let ((class (find-class 'symbol)))
    (notnot-mv (typep 'a `(and ,class))))
  t)

(deftest typep.11
  (let ((class (find-class 'symbol)))
    (typep 10 class))
  nil)

(deftest typep.12
  (let ((class (find-class 'symbol)))
    (typep 10 `(and ,class)))
  nil)

(deftest typep.13
  (typep 'a '(and symbol integer))
  nil)

(deftest typep.14
  (notnot-mv (typep 'a '(or symbol integer)))
  t)

(deftest typep.15
  (notnot-mv (typep 'a '(or integer symbol)))
  t)

(deftest typep.16
  (let ((c1 (find-class 'number))
sds's avatar
sds committed
133
        (c2 (find-class 'symbol)))
pfdietz's avatar
pfdietz committed
134 135 136 137 138
    (notnot-mv (typep 'a `(or ,c1 ,c2))))
  t)

(deftest typep.17
  (let ((c1 (find-class 'number))
sds's avatar
sds committed
139
        (c2 (find-class 'symbol)))
pfdietz's avatar
pfdietz committed
140 141 142 143 144 145 146 147 148
    (notnot-mv (typep 'a `(or ,c2 ,c1))))
  t)

(deftest typep.18
  (let ((i 0))
    (values
     (notnot (typep (incf i) '(and (integer 0 10) (integer -5 6))))
     i))
  t 1)
149 150 151 152

(defun typep.19-fn (reps &optional (prob .5))
  (let* ((vec "abcdefghijklmnopqrstuvwxyz"))
    (flet ((%make-random-type
sds's avatar
sds committed
153 154 155 156 157
            ()
            `(and character (member ,@(loop for e across vec
                                            when (< (random 1.0) prob)
                                            collect e)))))
      (loop
158 159 160 161
       for t1 = (%make-random-type)
       for t2 = (%make-random-type)
       for t3 = `(and ,t1 ,t2)
       for result1 = (loop for e across vec
sds's avatar
sds committed
162 163 164 165
                           when (if (typep e t3)
                                    (or (not (typep e t1)) (not (typep e t2)))
                                  (and (typep e t1) (typep e t2)))
                           collect e)
166 167 168 169 170 171 172 173
       repeat reps
       when result1
       nconc (list result1 t1 t2 t3)))))

(eval-when (:load-toplevel) (compile 'typep.19-fn))

(deftest typep.19 (typep.19-fn 1000) nil)

sds's avatar
sds committed
174 175