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
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
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
|
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 20:43:55 2003
;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE
(in-package :cl-test)
(deftest upgraded-array-element-type.1
(let ((upgraded-bit (upgraded-array-element-type 'bit)))
(and (empirical-subtypep 'bit upgraded-bit)
(empirical-subtypep upgraded-bit 'bit)))
t)
(deftest upgraded-array-element-type.2
(let ((upgraded-base-char (upgraded-array-element-type 'base-char)))
(and (empirical-subtypep 'base-char upgraded-base-char)
(empirical-subtypep upgraded-base-char 'base-char)))
t)
(deftest upgraded-array-element-type.3
(let ((upgraded-character (upgraded-array-element-type 'character)))
(and (empirical-subtypep 'character upgraded-character)
(empirical-subtypep upgraded-character 'character)))
t)
(defparameter *upgraded-array-types-to-check*
`(boolean
base-char
character
t
,@(loop for i from 0 to 32 collect `(eql ,(ash 1 i)))
,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i))))
(eql -1)
,@(loop for i from 0 to 32
collect `(integer 0 (,(ash 1 i))))
symbol
,@(loop for i from 0 to 32
collect `(integer ,(- (ash 1 i)) (,(ash 1 i))))
(integer -10000000000000000000000000000000000
10000000000000000000000000000000000)
float
short-float
single-float
double-float
complex
rational
fixnum
function
sequence
list
cons
atom
symbol))
(deftest upgraded-array-element-type.4
(loop for type in *upgraded-array-types-to-check*
for upgraded-type = (upgraded-array-element-type type)
unless (empirical-subtypep type upgraded-type)
collect (list type upgraded-type))
nil)
;; Include an environment (NIL, denoting the default null lexical
;; environment)
(deftest upgraded-array-element-type.5
(loop for type in *upgraded-array-types-to-check*
for upgraded-type = (upgraded-array-element-type type nil)
unless (empirical-subtypep type upgraded-type)
collect (list type upgraded-type))
nil)
(deftest upgraded-array-element-type.6
(macrolet
((%foo (&environment env)
(empirical-subtypep
'bit
(upgraded-array-element-type 'bit env))))
(%foo))
t)
(deftest upgraded-array-element-type.7
(let ((upgraded-types (mapcar #'upgraded-array-element-type
*upgraded-array-types-to-check*)))
(loop for type in *upgraded-array-types-to-check*
for upgraded-type in upgraded-types
append
(loop for type2 in *upgraded-array-types-to-check*
for upgraded-type2 in upgraded-types
when (and (subtypep type type2)
(equal (subtypep* upgraded-type upgraded-type)
'(nil t)))
collect (list type type2))))
nil)
;;; Tests that if Tx is a subtype of Ty, then UAET(Tx) is a subtype
;;; of UAET(Ty) (see section 15.1.2.1, paragraph 3)
(deftest upgraded-array-element-type.8
(let ((upgraded-types (mapcar #'upgraded-array-element-type
*upgraded-array-types-to-check*)))
(loop for type1 in *upgraded-array-types-to-check*
for uaet1 in upgraded-types
append
(loop for type2 in *upgraded-array-types-to-check*
for uaet2 in upgraded-types
when (and (subtypep type1 type2)
(not (empirical-subtypep uaet1 uaet2)))
collect (list type1 type2))))
nil)
;;; Tests of upgrading NIL (it should be type equivalent to NIL)
(deftest upgraded-array-element-type.nil.1
(let ((uaet-nil (upgraded-array-element-type nil)))
(check-predicate (typef `(not ,uaet-nil))))
nil)
;;; Error tests
(deftest upgraded-array-element-type.error.1
(signals-error (upgraded-array-element-type) program-error)
t)
(deftest upgraded-array-element-type.error.2
(signals-error (upgraded-array-element-type 'bit nil nil) program-error)
t)
|
