| ... |
... |
@@ -5,7 +5,12 @@ |
|
5
|
5
|
|
|
6
|
6
|
(in-package "STANDARD-CHAR-TESTS")
|
|
7
|
7
|
|
|
|
8
|
+;; For the following tests, we generally want to use
|
|
|
9
|
+;; kernel::type-intersection and kernel::type-union directly to make
|
|
|
10
|
+;; sure we test the intersection and union methods for standard-char.
|
|
|
11
|
+
|
|
8
|
12
|
(define-test standard-char.typep
|
|
|
13
|
+ (:tag :issues)
|
|
9
|
14
|
(assert-true (typep #\a 'standard-char))
|
|
10
|
15
|
(assert-false (typep #\tab 'standard-char))
|
|
11
|
16
|
(assert-true (typep #\a 'standard-char))
|
| ... |
... |
@@ -25,6 +30,7 @@ |
|
25
|
30
|
(subtypep 'standard-char 'base-char)))
|
|
26
|
31
|
|
|
27
|
32
|
(define-test standard-char.etypecase-15
|
|
|
33
|
+ (:tag :issues)
|
|
28
|
34
|
(assert-equal (values t t)
|
|
29
|
35
|
(c::type=
|
|
30
|
36
|
(c::specifier-type
|
| ... |
... |
@@ -32,21 +38,24 @@ |
|
32
|
38
|
(c::specifier-type
|
|
33
|
39
|
'(not (or file-error character standard-object standard-char boolean pathname))))))
|
|
34
|
40
|
|
|
35
|
|
-
|
|
36
|
41
|
(define-test standard-char.identity
|
|
|
42
|
+ (:tag :issues)
|
|
37
|
43
|
(let ((a (c::specifier-type 'standard-char))
|
|
38
|
44
|
(b (c::specifier-type 'standard-char)))
|
|
39
|
45
|
;; Should be EQ due to internal caching.
|
|
40
|
46
|
(assert-eq a b)))
|
|
41
|
47
|
|
|
42
|
48
|
(define-test standard-char.parsing
|
|
|
49
|
+ (:tag :issues)
|
|
43
|
50
|
(assert-eq 'standard-char
|
|
44
|
51
|
(c::type-specifier (c::specifier-type 'standard-char))))
|
|
45
|
52
|
|
|
46
|
53
|
(define-test standard-char.predicate
|
|
|
54
|
+ (:tag :issues)
|
|
47
|
55
|
(assert-true (c::standard-char-type-p (c::specifier-type 'standard-char))))
|
|
48
|
56
|
|
|
49
|
57
|
(define-test standard-char.simple-subtypep
|
|
|
58
|
+ (:tag :issues)
|
|
50
|
59
|
(assert-equal (values t t)
|
|
51
|
60
|
(c::type= (c::specifier-type 'standard-char)
|
|
52
|
61
|
(c::specifier-type 'standard-char)))
|
| ... |
... |
@@ -54,6 +63,7 @@ |
|
54
|
63
|
(subtypep 'standard-char 'standard-char)))
|
|
55
|
64
|
|
|
56
|
65
|
(define-test standard-char.complex-subtype-arg1
|
|
|
66
|
+ (:tag :issues)
|
|
57
|
67
|
;; STANDARD-CHAR is a subtype of CHARACTER and T.
|
|
58
|
68
|
(assert-equal (values t t)
|
|
59
|
69
|
(subtypep 'standard-char 'character))
|
| ... |
... |
@@ -77,6 +87,7 @@ |
|
77
|
87
|
(subtypep 'standard-char '(member #\a))))
|
|
78
|
88
|
|
|
79
|
89
|
(define-test standard-char.complex-subtypep-arg
|
|
|
90
|
+ (:tag :issues)
|
|
80
|
91
|
;; All standard chars: subtype.
|
|
81
|
92
|
(assert-equal (values t t)
|
|
82
|
93
|
(subtypep '(member #\a) 'standard-char))
|
| ... |
... |
@@ -106,6 +117,7 @@ |
|
106
|
117
|
(subtypep 'character 'standard-char)))
|
|
107
|
118
|
|
|
108
|
119
|
(define-test standard-char.complex-union
|
|
|
120
|
+ (:tag :issues)
|
|
109
|
121
|
;; Absorbed by supertype.
|
|
110
|
122
|
(assert-equal (values t t)
|
|
111
|
123
|
(c::type= (c::type-union (c::specifier-type 'standard-char)
|
| ... |
... |
@@ -159,6 +171,7 @@ |
|
159
|
171
|
(>= (length (c::member-type-members result)) 90)))))
|
|
160
|
172
|
|
|
161
|
173
|
(define-test standard-char.complex-intersection
|
|
|
174
|
+ (:tag :issues)
|
|
162
|
175
|
;; Intersection with supertype is STANDARD-CHAR.
|
|
163
|
176
|
(assert-equal (values t t)
|
|
164
|
177
|
(c::type= (c::type-intersection (c::specifier-type 'standard-char)
|
| ... |
... |
@@ -202,6 +215,7 @@ |
|
202
|
215
|
|
|
203
|
216
|
|
|
204
|
217
|
(define-test standard-char.negation
|
|
|
218
|
+ (:tag :issues)
|
|
205
|
219
|
;; NOT STANDARD-CHAR catches non-standard characters.
|
|
206
|
220
|
(assert-true (typep #\Tab '(not standard-char)))
|
|
207
|
221
|
(assert-false (typep #\a '(not standard-char)))
|
| ... |
... |
@@ -216,19 +230,26 @@ |
|
216
|
230
|
(c::type= (c::specifier-type '(and standard-char (not (member #\a))))
|
|
217
|
231
|
(c::specifier-type '(and (not (member #\a)) standard-char)))))
|
|
218
|
232
|
|
|
219
|
|
-#+nil
|
|
220
|
233
|
(define-test standard-char.etypecase
|
|
221
|
|
- ;; This is the original failing test family — should now pass reliably.
|
|
222
|
|
- (loop repeat 100
|
|
223
|
|
- always (eql nil
|
|
224
|
|
- (handler-case
|
|
225
|
|
- (etypecase #\a
|
|
226
|
|
- (standard-char :ok)
|
|
227
|
|
- (number :wrong))
|
|
228
|
|
- (error () :error))
|
|
229
|
|
- :ok)))
|
|
|
234
|
+ (:tag :issues)
|
|
|
235
|
+ (let ((*random-state* (make-random-state)))
|
|
|
236
|
+ ;; Test etypecase with standard-char works correctly using random
|
|
|
237
|
+ ;; characters. To make this repeatable, use a fixed random-state,
|
|
|
238
|
+ ;; otherwise, it becomes hard to debug
|
|
|
239
|
+ (dotimes (k 200)
|
|
|
240
|
+ (let* ((ch (code-char (random char-code-limit)))
|
|
|
241
|
+ (expected (if (standard-char-p ch)
|
|
|
242
|
+ :is-standard :is-other))
|
|
|
243
|
+ (actual (handler-case
|
|
|
244
|
+ (etypecase ch
|
|
|
245
|
+ (standard-char :is-standard)
|
|
|
246
|
+ (character :is-other))
|
|
|
247
|
+ (error ()
|
|
|
248
|
+ :error))))
|
|
|
249
|
+ (assert-eql expected actual ch)))))
|
|
230
|
250
|
|
|
231
|
251
|
(define-test standard-char.caching
|
|
|
252
|
+ (:tag :issues)
|
|
232
|
253
|
;; Multiple specifier-type calls on `standard-char` return EQ.
|
|
233
|
254
|
(assert-eq (c::specifier-type 'standard-char)
|
|
234
|
255
|
(c::specifier-type 'standard-char))
|
| ... |
... |
@@ -237,3 +258,122 @@ |
|
237
|
258
|
(assert-eq (c::specifier-type 'standard-char)
|
|
238
|
259
|
(c::specifier-type 'standard-char)))
|
|
239
|
260
|
;
|
|
|
261
|
+
|
|
|
262
|
+(define-test standard-char.intersection-character-both-orderings
|
|
|
263
|
+ (:tag :issues)
|
|
|
264
|
+ ;; Standard-char intersect character = standard-char, regardless of argument order.
|
|
|
265
|
+ (assert-equality #'kernel::type=
|
|
|
266
|
+ (kernel::specifier-type 'standard-char)
|
|
|
267
|
+ (kernel::type-intersection (kernel::specifier-type 'standard-char)
|
|
|
268
|
+ (kernel::specifier-type 'character)))
|
|
|
269
|
+ (assert-equality #'kernel::type=
|
|
|
270
|
+ (kernel::specifier-type 'standard-char)
|
|
|
271
|
+ (kernel::type-intersection (kernel::specifier-type 'character)
|
|
|
272
|
+ (kernel::specifier-type 'standard-char))))
|
|
|
273
|
+
|
|
|
274
|
+(define-test standard-char.intersection-disjoint-both-orderings
|
|
|
275
|
+ (:tag :issues)
|
|
|
276
|
+ (assert-equality #'kernel::type=
|
|
|
277
|
+ kernel::*empty-type*
|
|
|
278
|
+ (kernel::type-intersection (kernel::specifier-type 'standard-char)
|
|
|
279
|
+ (kernel::specifier-type 'integer)))
|
|
|
280
|
+ (assert-equality #'kernel::type=
|
|
|
281
|
+ kernel::*empty-type*
|
|
|
282
|
+ (kernel::type-intersection (kernel::specifier-type 'integer)
|
|
|
283
|
+ (kernel::specifier-type 'standard-char))))
|
|
|
284
|
+
|
|
|
285
|
+(define-test standard-char.intersection-member-both-orderings
|
|
|
286
|
+ (:tag :issues)
|
|
|
287
|
+ ;; Filter member-type to standard chars only.
|
|
|
288
|
+ (assert-equality #'kernel::type=
|
|
|
289
|
+ (kernel::specifier-type '(member #\a #\b))
|
|
|
290
|
+ (kernel::type-intersection (kernel::specifier-type 'standard-char)
|
|
|
291
|
+ (kernel::specifier-type '(member #\a #\Tab #\b))))
|
|
|
292
|
+ (assert-equality #'kernel::type=
|
|
|
293
|
+ (kernel::specifier-type '(member #\a #\b))
|
|
|
294
|
+ (kernel::type-intersection (kernel::specifier-type '(member #\a #\Tab #\b))
|
|
|
295
|
+ (kernel::specifier-type 'standard-char))))
|
|
|
296
|
+
|
|
|
297
|
+(define-test standard-char.union-character-both-orderings
|
|
|
298
|
+ (:tag :issues)
|
|
|
299
|
+ ;; Standard-char union character = character.
|
|
|
300
|
+ (assert-equality #'kernel::type=
|
|
|
301
|
+ (kernel::specifier-type 'character)
|
|
|
302
|
+ (kernel::type-union (kernel::specifier-type 'standard-char)
|
|
|
303
|
+ (kernel::specifier-type 'character)))
|
|
|
304
|
+ (assert-equality #'kernel::type=
|
|
|
305
|
+ (kernel::specifier-type 'character)
|
|
|
306
|
+ (kernel::type-union (kernel::specifier-type 'character)
|
|
|
307
|
+ (kernel::specifier-type 'standard-char))))
|
|
|
308
|
+
|
|
|
309
|
+(define-test standard-char.union-member-of-standard-both-orderings
|
|
|
310
|
+ (:tag :issues)
|
|
|
311
|
+ ;; Standard-char absorbs all-standard member-type.
|
|
|
312
|
+ (assert-equality #'kernel::type=
|
|
|
313
|
+ (kernel::specifier-type 'standard-char)
|
|
|
314
|
+ (kernel::type-union (kernel::specifier-type 'standard-char)
|
|
|
315
|
+ (kernel::specifier-type '(member #\a #\b))))
|
|
|
316
|
+ (assert-equality #'kernel::type=
|
|
|
317
|
+ (kernel::specifier-type 'standard-char)
|
|
|
318
|
+ (kernel::type-union (kernel::specifier-type '(member #\a #\b))
|
|
|
319
|
+ (kernel::specifier-type 'standard-char))))
|
|
|
320
|
+
|
|
|
321
|
+(define-test standard-char.union-disjoint-stays-symbolic-both-orderings
|
|
|
322
|
+ (:tag :issues)
|
|
|
323
|
+ ;; (or boolean standard-char) and reverse — both should stay symbolic
|
|
|
324
|
+ ;; rather than collapsing into a giant member-type.
|
|
|
325
|
+ (let ((r1 (kernel::specifier-type '(or boolean standard-char)))
|
|
|
326
|
+ (r2 (kernel::specifier-type '(or standard-char boolean))))
|
|
|
327
|
+ (assert-true (kernel::union-type-p r1))
|
|
|
328
|
+ (assert-true (kernel::union-type-p r2))
|
|
|
329
|
+ (assert-equality #'kernel::type= r1 r2)
|
|
|
330
|
+ ;; Neither should contain a member-type with both characters
|
|
|
331
|
+ ;; and non-characters.
|
|
|
332
|
+ (dolist (m (kernel::union-type-types r1))
|
|
|
333
|
+ (assert-false (and (kernel::member-type-p m)
|
|
|
334
|
+ (some #'characterp (kernel::member-type-members m))
|
|
|
335
|
+ (some (complement #'characterp)
|
|
|
336
|
+ (kernel::member-type-members m)))))))
|
|
|
337
|
+
|
|
|
338
|
+(define-test standard-char.subtypep-bidirectional
|
|
|
339
|
+ (:tag :issues)
|
|
|
340
|
+ ;; arg1 path: standard-char subset of X?
|
|
|
341
|
+ (assert-equal (values t t) (subtypep 'standard-char 'character))
|
|
|
342
|
+ (assert-equal (values nil t) (subtypep 'standard-char 'integer))
|
|
|
343
|
+ ;; arg2 path: X subset of standard-char?
|
|
|
344
|
+ (assert-equal (values nil t) (subtypep 'character 'standard-char))
|
|
|
345
|
+ (assert-equal (values nil t) (subtypep 'integer 'standard-char))
|
|
|
346
|
+ ;; Both reflexively
|
|
|
347
|
+ (assert-equal (values t t) (subtypep 'standard-char 'standard-char)))
|
|
|
348
|
+
|
|
|
349
|
+(defun assert-commutative-union (type-a-spec type-b-spec)
|
|
|
350
|
+ "Assert that union(A, B) and union(B, A) produce type= results."
|
|
|
351
|
+ (assert-equality #'kernel::type=
|
|
|
352
|
+ (kernel::type-union (kernel::specifier-type type-a-spec)
|
|
|
353
|
+ (kernel::specifier-type type-b-spec))
|
|
|
354
|
+ (kernel::type-union (kernel::specifier-type type-b-spec)
|
|
|
355
|
+ (kernel::specifier-type type-a-spec))))
|
|
|
356
|
+
|
|
|
357
|
+(defun assert-commutative-intersection (type-a-spec type-b-spec)
|
|
|
358
|
+ (assert-equality #'kernel::type=
|
|
|
359
|
+ (kernel::type-intersection (kernel::specifier-type type-a-spec)
|
|
|
360
|
+ (kernel::specifier-type type-b-spec))
|
|
|
361
|
+ (kernel::type-intersection (kernel::specifier-type type-b-spec)
|
|
|
362
|
+ (kernel::specifier-type type-a-spec))))
|
|
|
363
|
+
|
|
|
364
|
+(define-test standard-char.commutativity
|
|
|
365
|
+ (:tag :issues)
|
|
|
366
|
+ (assert-commutative-union 'standard-char 'character)
|
|
|
367
|
+ (assert-commutative-union 'standard-char 'integer)
|
|
|
368
|
+ (assert-commutative-union 'standard-char '(member #\a #\b))
|
|
|
369
|
+ (assert-commutative-union 'standard-char '(member #\Tab))
|
|
|
370
|
+ (assert-commutative-union 'standard-char 'boolean)
|
|
|
371
|
+ (assert-commutative-union 'standard-char '(not character))
|
|
|
372
|
+ (assert-commutative-union 'standard-char 't)
|
|
|
373
|
+ (assert-commutative-intersection 'standard-char 'character)
|
|
|
374
|
+ (assert-commutative-intersection 'standard-char 'integer)
|
|
|
375
|
+ (assert-commutative-intersection 'standard-char '(member #\a #\b))
|
|
|
376
|
+ (assert-commutative-intersection 'standard-char '(member #\Tab))
|
|
|
377
|
+ (assert-commutative-intersection 'standard-char 'boolean)
|
|
|
378
|
+ (assert-commutative-intersection 'standard-char '(not character))
|
|
|
379
|
+ (assert-commutative-intersection 'standard-char 't)) |