28 |
;; These should get removed when I get a more up to date |
;; These should get removed when I get a more up to date |
29 |
;; image for that platform -- pfd |
;; image for that platform -- pfd |
30 |
|
|
31 |
(defparameter *subtype-table* |
|
|
(let ((table |
|
|
'( |
|
|
(null symbol) |
|
|
(symbol t) |
|
|
#-(and cmu (not sparc)) (boolean symbol) |
|
|
(standard-object t) |
|
|
(function t) |
|
|
(compiled-function function) |
|
|
(generic-function function) |
|
|
(standard-generic-function generic-function) |
|
|
(class standard-object) |
|
|
(built-in-class class) |
|
|
(structure-class class) |
|
|
(standard-class class) |
|
|
(method standard-object) |
|
|
(standard-method method) |
|
|
(structure-object t) |
|
|
(method-combination t) |
|
|
(condition t) |
|
|
(serious-condition condition) |
|
|
(error serious-condition) |
|
|
(type-error error) |
|
|
(simple-type-error type-error) |
|
|
(simple-condition condition) |
|
|
(simple-type-error simple-condition) |
|
|
(parse-error error) |
|
|
(hash-table t) |
|
|
(cell-error error) |
|
|
(unbound-slot cell-error) |
|
|
(warning condition) |
|
|
(style-warning warning) |
|
|
(storage-condition serious-condition) |
|
|
(simple-warning warning) |
|
|
(simple-warning simple-condition) |
|
|
(keyword symbol) |
|
|
(unbound-variable cell-error) |
|
|
(control-error error) |
|
|
(program-error error) |
|
|
(undefined-function cell-error) |
|
|
(package t) |
|
|
(package-error error) |
|
|
(random-state t) |
|
|
(number t) |
|
|
(real number) |
|
|
(complex number) |
|
|
(float real) |
|
|
(short-float float) |
|
|
(single-float float) |
|
|
(double-float float) |
|
|
(long-float float) |
|
|
(rational real) |
|
|
(integer rational) |
|
|
(ratio rational) |
|
|
(signed-byte integer) |
|
|
(integer signed-byte) |
|
|
(unsigned-byte signed-byte) |
|
|
(bit unsigned-byte) |
|
|
(fixnum integer) |
|
|
(bignum integer) |
|
|
(bit fixnum) |
|
|
(arithmetic-error error) |
|
|
(division-by-zero arithmetic-error) |
|
|
(floating-point-invalid-operation arithmetic-error) |
|
|
(floating-point-inexact arithmetic-error) |
|
|
(floating-point-overflow arithmetic-error) |
|
|
(floating-point-underflow arithmetic-error) |
|
|
(character t) |
|
|
(base-char character) |
|
|
(standard-char base-char) |
|
|
(extended-char character) |
|
|
(sequence t) |
|
|
(list sequence) |
|
|
(null list) |
|
|
#-(and cmu (not sparc)) (null boolean) |
|
|
(cons list) |
|
|
(array t) |
|
|
(simple-array array) |
|
|
(vector sequence) |
|
|
(vector array) |
|
|
(string vector) |
|
|
(bit-vector vector) |
|
|
(simple-vector vector) |
|
|
(simple-vector simple-array) |
|
|
(simple-bit-vector bit-vector) |
|
|
(simple-bit-vector simple-array) |
|
|
(base-string string) |
|
|
(simple-string string) |
|
|
(simple-string simple-array) |
|
|
(simple-base-string base-string) |
|
|
(simple-base-string simple-string) |
|
|
(pathname t) |
|
|
(logical-pathname pathname) |
|
|
(file-error error) |
|
|
(stream t) |
|
|
(broadcast-stream stream) |
|
|
(concatenated-stream stream) |
|
|
(echo-stream stream) |
|
|
(file-stream stream) |
|
|
(string-stream stream) |
|
|
(synonym-stream stream) |
|
|
(two-way-stream stream) |
|
|
(stream-error error) |
|
|
(end-of-file stream-error) |
|
|
(print-not-readable error) |
|
|
(readtable t) |
|
|
(reader-error parse-error) |
|
|
(reader-error stream-error) |
|
|
))) |
|
|
(when (subtypep* 'character 'base-char) |
|
|
(setq table |
|
|
(append |
|
|
'((character base-char) |
|
|
(string base-string) |
|
|
(simple-string simple-base-string)) |
|
|
table))) |
|
|
|
|
|
table)) |
|
32 |
|
|
33 |
(deftest types-3 |
(deftest types-3 |
34 |
(count-if |
(count-if |
43 |
*subtype-table*) |
*subtype-table*) |
44 |
0) |
0) |
45 |
|
|
46 |
(defparameter +float-types+ |
(declaim (special +float-types+ *subtype-table*)) |
|
'(long-float double-float short-float single-float)) |
|
|
|
|
47 |
|
|
48 |
;;; This next test is all screwed up. Basically, it assumes |
;;; This next test is all screwed up. Basically, it assumes |
49 |
;;; incorrectly that certain subtype relationships that are |
;;; incorrectly that certain subtype relationships that are |
99 |
|
|
100 |
(declaim (special *disjoint-types-list*)) |
(declaim (special *disjoint-types-list*)) |
101 |
|
|
102 |
|
;;; Check that the disjoint types really are disjoint |
103 |
|
|
104 |
(deftest types-7 |
(deftest types-7 |
105 |
(loop |
(loop |
106 |
for tp in *disjoint-types-list* sum |
for tp in *disjoint-types-list* sum |
107 |
(loop for tp2 in *disjoint-types-list* count |
(loop for tp2 in *disjoint-types-list* count |
108 |
(and (not (eqt tp tp2)) |
(and (not (eqt tp tp2)) |
109 |
(subtypep* tp tp2)))) |
(subtypep* tp tp2)))) |
110 |
0) |
0) |
111 |
|
|
112 |
|
(deftest types-7a |
113 |
|
(loop |
114 |
|
for tp in *disjoint-types-list* sum |
115 |
|
(loop for tp2 in *disjoint-types-list* count |
116 |
|
(and (not (eqt tp tp2)) |
117 |
|
(multiple-value-bind (sub valid) |
118 |
|
(subtypep `(not ,tp) `(not ,tp2)) |
119 |
|
(and sub valid))))) |
120 |
|
0) |
121 |
|
|
122 |
|
(deftest types-7b |
123 |
|
(loop for e on *disjoint-types-list* |
124 |
|
for tp1 = (first e) |
125 |
|
append |
126 |
|
(loop for tp2 in (rest e) |
127 |
|
for result = (check-disjointness tp1 tp2) |
128 |
|
append result)) |
129 |
|
nil) |
130 |
|
|
131 |
|
|
132 |
(deftest types-8 |
(deftest types-8 |
133 |
(loop |
(loop |
134 |
for tp in *disjoint-types-list* count |
for tp in *disjoint-types-list* count |
135 |
(cond |
(cond |
136 |
((and (not (eqt tp 'cons)) |
((and (not (eqt tp 'cons)) |
137 |
(not (subtypep* tp 'atom))) |
(not (subtypep* tp 'atom))) |
138 |
(format t "~%Should be atomic, but isn't: ~S" tp) |
(format t "~%Should be atomic, but isn't: ~S" tp) |
139 |
t))) |
t))) |
140 |
0) |
0) |
141 |
|
|
142 |
(declaim (special *type-list* |
(declaim (special *type-list* |
150 |
;;; |
;;; |
151 |
|
|
152 |
(deftest types-9 |
(deftest types-9 |
153 |
(types-9-body) |
(types-9-body) |
154 |
nil) |
nil) |
155 |
|
|
156 |
;;; |
;;; |
166 |
;;; |
;;; |
167 |
|
|
168 |
(deftest types-9a |
(deftest types-9a |
169 |
(types-9a-body) |
(types-9a-body) |
170 |
0) |
0) |
171 |
|
|
172 |
;;; |
;;; |
181 |
collect (list e types)) |
collect (list e types)) |
182 |
nil) |
nil) |
183 |
|
|
184 |
|
(deftest integer-and-ratio-are-disjoint |
185 |
|
(check-disjointness 'integer 'ratio) |
186 |
|
nil) |
187 |
|
|
188 |
|
(deftest integer-and-float-are-disjoint |
189 |
|
(check-disjointness 'integer 'float) |
190 |
|
nil) |
191 |
|
|
192 |
|
(deftest ratio-and-float-are-disjoint |
193 |
|
(check-disjointness 'ratio 'float) |
194 |
|
nil) |
195 |
|
|
196 |
|
(deftest complex-and-float-are-disjoint |
197 |
|
(check-disjointness 'complex 'float) |
198 |
|
nil) |
199 |
|
|
200 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
201 |
;;; deftype |
;;; deftype |
202 |
|
|