58 |
(array (list 'array (array-element-type thing))) |
(array (list 'array (array-element-type thing))) |
59 |
(t t)))) ; 'unknown ;; I can't see any use of this |
(t t)))) ; 'unknown ;; I can't see any use of this |
60 |
|
|
61 |
|
;;FIXME -- this function needs a rewrite. CM 20050106 |
62 |
(defun type-filter (type) |
(defun type-filter (type) |
63 |
|
(when (and (symbolp type) (get type 'si::deftype-definition) (not (get type 's-data))) |
64 |
|
(return-from type-filter type)) |
65 |
(case type |
(case type |
66 |
((fixnum character short-float long-float) type) |
((character short-float long-float boolean) type) |
67 |
(single-float 'long-float) |
((single-float double-float) 'long-float) |
68 |
(boolean 'boolean) |
((nil t) t) |
69 |
(double-float 'long-float) |
(t (let ((type (si::normalize-type type)) element-type) |
70 |
((simple-string string) 'string) |
(case (car type) |
71 |
((simple-bit-vector bit-vector) 'bit-vector) |
((simple-array array) |
72 |
((nil t) t) |
(cond ((or (endp (cdr type)) |
73 |
(t (let ((type (si::normalize-type type)) element-type) |
(not (setq element-type |
74 |
(case (car type) |
(cond ((eq '* (cadr type)) nil) |
75 |
((simple-array array) |
((si::best-array-element-type |
76 |
(cond ((or (endp (cdr type)) |
(cadr type))) |
77 |
(not (setq element-type |
(t t))))) |
78 |
(cond ((eq '* (cadr type)) nil) |
t) ; I don't know. |
79 |
((si::best-array-element-type |
((and (not (endp (cddr type))) |
80 |
(cadr type))) |
(not (eq (caddr type) '*)) |
81 |
(t t))))) |
(or (eql (caddr type) 1) |
82 |
t) ; I don't know. |
(and (consp (caddr type)) |
83 |
((and (not (endp (cddr type))) |
(= (length (caddr type)) 1)))) |
84 |
(not (eq (caddr type) '*)) |
(case element-type |
85 |
(or (eql (caddr type) 1) |
(string-char 'string) |
86 |
(and (consp (caddr type)) |
(bit 'bit-vector) |
87 |
(= (length (caddr type)) 1)))) |
(t (list 'vector element-type)))) |
88 |
(case element-type |
(t (list 'array element-type)))) |
89 |
(string-char 'string) |
((integer signed-byte unsigned-byte) type) |
90 |
(bit 'bit-vector) |
((short-float) 'short-float) |
91 |
(t (list 'vector element-type)))) |
((long-float double-float single-float) 'long-float) |
92 |
(t (list 'array element-type)))) |
((stream) 'stream) |
93 |
((integer signed-byte unsigned-byte) type) |
(t (cond ((subtypep type 'fixnum) 'fixnum) |
94 |
((short-float) 'short-float) |
((subtypep type 'integer) 'integer) |
95 |
((long-float double-float single-float) 'long-float) |
((subtypep type 'character) 'character) |
96 |
((stream) 'stream) |
((subtypep type 'short-float) 'short-float) |
97 |
(t (cond ((subtypep type 'fixnum) 'fixnum) |
((subtypep type 'long-float) 'long-float) |
98 |
((subtypep type 'integer) 'integer) |
((subtypep type '(vector t)) '(vector t)) |
99 |
((subtypep type 'character) 'character) |
((subtypep type 'string) 'string) |
100 |
((subtypep type 'short-float) 'short-float) |
((subtypep type 'bit-vector) 'bit-vector) |
101 |
((subtypep type 'long-float) 'long-float) |
((subtypep type '(vector fixnum)) '(vector fixnum)) |
102 |
((subtypep type '(vector t)) '(vector t)) |
((subtypep type '(vector short-float)) |
103 |
((subtypep type 'string) 'string) |
'(vector short-float)) |
104 |
((subtypep type 'bit-vector) 'bit-vector) |
((subtypep type '(vector long-float)) |
105 |
((subtypep type '(vector fixnum)) '(vector fixnum)) |
'(vector long-float)) |
106 |
((subtypep type '(vector short-float)) |
((subtypep type '(array t)) '(array t)) |
107 |
'(vector short-float)) |
((subtypep type '(array string-char)) |
108 |
((subtypep type '(vector long-float)) |
'(array string-char)) |
109 |
'(vector long-float)) |
((subtypep type '(array bit)) '(array bit)) |
110 |
((subtypep type '(array t)) '(array t)) |
((subtypep type '(array fixnum)) '(array fixnum)) |
111 |
((subtypep type '(array string-char)) |
((subtypep type '(array short-float)) |
112 |
'(array string-char)) |
'(array short-float)) |
113 |
((subtypep type '(array bit)) '(array bit)) |
((subtypep type '(array long-float)) |
114 |
((subtypep type '(array fixnum)) '(array fixnum)) |
'(array long-float)) |
115 |
((subtypep type '(array short-float)) |
((eq (car type) 'values) |
116 |
'(array short-float)) |
(if (null (cddr type)) |
117 |
((subtypep type '(array long-float)) |
(list 'values (type-filter (second type))) |
118 |
'(array long-float)) |
t)) |
119 |
((eq (car type) 'values) |
((and (eq (car type) 'satisfies) |
120 |
(if (null (cddr type)) |
(symbolp (second type)) |
121 |
(list 'values (type-filter (second type))) |
(get (second type) 'type-filter))) |
122 |
t)) |
(t t))) |
123 |
((and (eq (car type) 'satisfies) |
))))) |
|
(symbolp (second type)) |
|
|
(get (second type) 'type-filter))) |
|
|
(t t))) |
|
|
))))) |
|
124 |
|
|
125 |
|
(defun type<= (t1 t2) (type>= t2 t1)) |
126 |
|
|
127 |
|
;;FIXME -- This function needs expansion on centralization. CM 20050106 |
128 |
(defun promoted-c-type (type) |
(defun promoted-c-type (type) |
129 |
(let ((type (coerce-to-one-value type))) |
(let ((type (coerce-to-one-value type))) |
130 |
(if (integer-typep type) |
(let ((ct (car (member type |
131 |
(cond ;((subtypep type 'signed-char) 'signed-char) |
; '(signed-char signed-short fixnum integer) |
132 |
((subtypep type 'fixnum) 'fixnum) |
; '(signed-char unsigned-char signed-short unsigned-short fixnum integer) |
133 |
((subtypep type 'integer) 'integer) |
'(fixnum integer) |
134 |
(t (error "Cannot promote type ~S to C type~%" type))) |
:test #'type<=)))) |
135 |
type))) |
(or ct type)))) |
136 |
|
; (if (integer-typep type) |
137 |
|
; (cond ;((subtypep type 'signed-char) 'signed-char) |
138 |
|
; ((subtypep type 'fixnum) 'fixnum) |
139 |
|
; ((subtypep type 'integer) 'integer) |
140 |
|
; (t (error "Cannot promote type ~S to C type~%" type))) |
141 |
|
; type))) |
142 |
|
|
143 |
|
(defun random-propagator (&rest r) |
144 |
|
(let ((tp (si::normalize-type (cadr r)))) |
145 |
|
(if (integer-typep tp) |
146 |
|
`(integer 0 ,(if (integerp (caddr tp)) (caddr tp) '*)) |
147 |
|
tp))) |
148 |
|
(si::putprop 'random (function random-propagator) 'type-propagator) |
149 |
|
|
150 |
(defun ash-propagator (f t1 t2) |
(defun ash-propagator (f t1 t2) |
151 |
(and |
(and |
207 |
(let ((l (length type))) |
(let ((l (length type))) |
208 |
(and (<= 1 l 3) |
(and (<= 1 l 3) |
209 |
(or (< l 2) (integerp (cadr type)) (eq (cadr type) '*)) |
(or (< l 2) (integerp (cadr type)) (eq (cadr type) '*)) |
210 |
(or (< l 3) (integerp (caddr type)) (eq (caddr type) '*))))))) |
(or (< l 3) (integerp (caddr type)) (eq (caddr type) '*)))))) |
211 |
|
|
212 |
(defun coerce-to-integer-type (t1) |
(defun coerce-to-integer-type (t1) |
213 |
(if (integer-typep t1) t1 |
(if (integer-typep t1) t1 |
235 |
t12 t21 |
t12 t21 |
236 |
(and (or (eq br '*) (eq er '*) (<= br er)) |
(and (or (eq br '*) (eq er '*) (<= br er)) |
237 |
(list (car ct1) br er)))))))))) |
(list (car ct1) br er)))))))))) |
|
|
|
238 |
|
|
239 |
|
;;FIXME -- this is awful. array and simple-array cannot be deftyped, |
240 |
|
;;-- the code for their processing needs to be centralized. CM 20050106 |
241 |
|
(defmacro array-wd (form) |
242 |
|
`(member ,form '(array simple-array) :test #'eq)) |
243 |
|
(defmacro array-tp (form) |
244 |
|
`(and (consp ,form) (array-wd (car ,form)))) |
245 |
|
|
246 |
|
;;FIXME -- centralize subtypep, normalzie-type, type>=, type-and. |
247 |
|
;;Consider traversing a static tree. CM 20050106 |
248 |
(defun type-and (type1 type2) |
(defun type-and (type1 type2) |
249 |
|
|
250 |
(cond ((equal type1 type2) type1) |
(let ((nt1 (si::normalize-type type1))) |
251 |
|
(unless (and (not (array-wd type1)) (equal nt1 (if (symbolp type1) (list type1) type1))) |
252 |
|
(let ((tem (type-and nt1 type2))) |
253 |
|
(return-from type-and (or (and (equal tem type2) type2) (and (equal tem nt1) type1) tem))))) |
254 |
|
(let ((nt2 (si::normalize-type type2))) |
255 |
|
(unless (and (not (array-wd type2)) (equal nt2 (if (symbolp type2) (list type2) type2))) |
256 |
|
(let ((tem (type-and type1 nt2))) |
257 |
|
(return-from type-and (if (equal tem nt2) type2 tem))))) |
258 |
|
|
259 |
|
(cond ((equal type1 type2) type2) |
260 |
((and (consp type2) (eq (car type2) 'values)) |
((and (consp type2) (eq (car type2) 'values)) |
261 |
(if (and (consp type1) (eq (car type1) 'values)) |
(if (and (consp type1) (eq (car type1) 'values)) |
262 |
(let ((r (list 'values))) |
(let ((r (list 'values))) |
266 |
(push (type-and (car t1) (car t2)) r))) |
(push (type-and (car t1) (car t2)) r))) |
267 |
(type-and type1 (second type2)))) |
(type-and type1 (second type2)))) |
268 |
((and (consp type1) (eq (car type1) 'values)) |
((and (consp type1) (eq (car type1) 'values)) |
269 |
(type-and (second type1) type2)) |
(type-and (second type1) type2)) |
270 |
((member type1 '(t * object) :test #'eq) type2) |
((eq type1 '*) type2) |
271 |
((member type2 '(t * object) :test #'eq) type1) |
((eq type2 '*) type1) |
272 |
|
((si::memq type1 '(t object)) type2) |
273 |
|
((si::memq type2 '(t object)) type1) |
274 |
((or (integer-typep type1) (integer-typep type2)) |
((or (integer-typep type1) (integer-typep type2)) |
275 |
(integer-type-and type1 type2)) |
(integer-type-and type1 type2)) |
276 |
((consp type1) |
((and (array-tp type1) (array-tp type2)) |
277 |
(case (car type1) |
(cond |
278 |
(array |
((eq (car type1) (car type2)) |
279 |
(case (cadr type1) |
(cond |
280 |
(string-char (if (eq type2 'string) type2 nil)) |
((null (cdr type1)) type2) |
281 |
(bit (if (eq type2 'bit-vector) type2 nil)) |
((null (cdr type2)) type1) |
282 |
(t (if (and (consp type2) |
((null (cddr type1)) |
283 |
(eq (car type2) 'vector) |
(cond |
284 |
(eq (cadr type1) (cadr type2))) |
((eq (cadr type1) '*) type2) |
285 |
type2 nil)))) |
((eq (cadr type1) (cadr type2)) type2) |
286 |
(vector |
((eq (cadr type2) '*) `(,(car type2) ,(cadr type1) ,@(cddr type2))))) |
287 |
(if (and (consp type2) (eq (car type2) 'array) |
((null (cddr type2)) |
288 |
(eq (cadr type1) (cadr type2))) |
(cond |
289 |
type1 nil)) |
((eq (cadr type2) '*) type1) |
290 |
(t nil))) |
((eq (cadr type2) (cadr type1)) type1) |
291 |
(t (case type1 |
((eq (cadr type1) '*) `(,(car type1) ,(cadr type2) ,@(cddr type1))))) |
292 |
(string |
(t |
293 |
(if (and (consp type2) (eq (car type2) 'array) |
(cond |
294 |
(eq (cadr type2) 'string-char)) |
((not (equal (caddr type1) (caddr type2))) nil) |
295 |
type1 nil)) |
((eq (cadr type1) '*) type2) |
296 |
(bit-vector |
((eq (cadr type1) (cadr type2)) type2) |
297 |
(if (and (consp type2) (eq (car type2) 'array) |
((eq (cadr type2) '*) type1))))) |
298 |
(eq (cadr type2) 'bit)) |
((eq (car type1) 'simple-array) |
299 |
type1 nil)) |
(type-and type1 `(simple-array ,@(cdr type2)))) |
300 |
(fixnum-float |
((eq (car type2) 'simple-array) |
301 |
(if (member type2 '(fixnum float short-float long-float)) |
(type-and `(simple-array ,@(cdr type1)) type2)))) |
302 |
type2 nil)) |
(t (case type1 |
303 |
(float |
(string |
304 |
(if (member type2 '(short-float long-float)) |
(if (and (consp type2) (eq (car type2) 'array) |
305 |
type2 nil)) |
(eq (cadr type2) 'string-char)) |
306 |
((long-float short-float) |
type1 nil)) |
307 |
(if (member type2 '(fixnum-float float)) |
(bit-vector |
308 |
type1 nil)) |
(if (and (consp type2) (eq (car type2) 'array) |
309 |
((signed-char unsigned-char signed-short) |
(eq (cadr type2) 'bit)) |
310 |
(if (eq type2 'fixnum) type1 nil)) |
type1 nil)) |
311 |
((unsigned-short) |
(fixnum-float |
312 |
(if (subtypep type1 type2) type1 nil)) |
(if (member type2 '(fixnum float short-float long-float)) |
313 |
(integer |
type2 nil)) |
314 |
(case type2 |
(float |
315 |
(fixnum type2))) |
(if (member type2 '(short-float long-float)) |
316 |
(fixnum |
type2 nil)) |
317 |
(case type2 |
((long-float short-float) |
318 |
((integer fixnum-float) 'fixnum) |
(if (member type2 '(fixnum-float float)) |
319 |
((signed-char unsigned-char signed-short bit) |
type1 nil)) |
320 |
type2) |
((signed-char unsigned-char signed-short) |
321 |
((unsigned-short) |
(if (eq type2 'fixnum) type1 nil)) |
322 |
(if (subtypep type2 type1) type2 nil)))) |
((unsigned-short) |
323 |
)))) |
(if (subtypep type1 type2) type1 nil)) |
324 |
|
(integer |
325 |
|
(case type2 |
326 |
|
(fixnum type2))) |
327 |
|
(fixnum |
328 |
|
(case type2 |
329 |
|
((integer fixnum-float) 'fixnum) |
330 |
|
((signed-char unsigned-char signed-short bit) |
331 |
|
type2) |
332 |
|
((unsigned-short) |
333 |
|
(if (subtypep type2 type1) type2 nil)))) |
334 |
|
)))) |
335 |
|
|
336 |
(defun type>= (type1 type2) |
(defun type>= (type1 type2) |
337 |
(equal (type-and type1 type2) type2)) |
(equal (type-and type1 type2) type2)) |
338 |
|
|