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