86 |
(bit 'bit-vector) |
(bit 'bit-vector) |
87 |
(t (list 'vector element-type)))) |
(t (list 'vector element-type)))) |
88 |
(t (list 'array element-type)))) |
(t (list 'array element-type)))) |
89 |
(integer |
((integer signed-byte unsigned-byte) type) |
|
(if (si::sub-interval-p (cdr type) |
|
|
(list most-negative-fixnum |
|
|
most-positive-fixnum)) |
|
|
'fixnum |
|
|
'integer)) |
|
90 |
((short-float) 'short-float) |
((short-float) 'short-float) |
91 |
((long-float double-float single-float) 'long-float) |
((long-float double-float single-float) 'long-float) |
92 |
((stream) 'stream) |
((stream) 'stream) |
122 |
(t t))) |
(t t))) |
123 |
))))) |
))))) |
124 |
|
|
125 |
|
(defun promoted-c-type (type) |
126 |
|
(if (bounded-type type) |
127 |
|
(cond ;((subtypep type 'signed-char) 'signed-char) |
128 |
|
((subtypep type 'fixnum) 'fixnum) |
129 |
|
((subtypep type 'integer) 'integer) |
130 |
|
(t (error "Cannot promote type ~S to C type~%" type))) |
131 |
|
type))) |
132 |
|
|
133 |
|
(defun super-range (f t1 t2) |
134 |
|
(and |
135 |
|
(bounded-type t1) |
136 |
|
(bounded-type t2) |
137 |
|
(eq (car t1) (car t2)) |
138 |
|
(let ((a (funcall (symbol-function f) (cadr t1) (cadr t2))) |
139 |
|
(b (funcall (symbol-function f) (cadr t1) (caddr t2))) |
140 |
|
(c (funcall (symbol-function f) (caddr t1) (cadr t2))) |
141 |
|
(d (funcall (symbol-function f) (caddr t1) (caddr t2)))) |
142 |
|
(list (car t1) (min a b c d) (max a b c d))))) |
143 |
|
|
144 |
|
(defun bounded-type (type) |
145 |
|
(and (consp type) |
146 |
|
(eql (length type) 3) |
147 |
|
(member (car type) '(integer signed-byte unsigned-byte) :test #'eq) |
148 |
|
(integerp (cadr type)) |
149 |
|
(integerp (caddr type)))) |
150 |
|
|
151 |
(defun type-and (type1 type2) |
(defun type-and (type1 type2) |
152 |
|
|
167 |
((eq type2 'object) type1) |
((eq type2 'object) type1) |
168 |
((eq type2 t) type1) |
((eq type2 t) type1) |
169 |
((eq type2 '*) type1) |
((eq type2 '*) type1) |
170 |
|
((or (bounded-type type1) (bounded-type type2)) |
171 |
|
(cond ((subtypep type1 type2) type1) |
172 |
|
((subtypep type2 type1) type2) |
173 |
|
(t nil))) |
174 |
((consp type1) |
((consp type1) |
175 |
(case (car type1) |
(case (car type1) |
176 |
(array |
(array |
245 |
(cmpwarn "The type of the form ~s is not ~s." original-form type))) |
(cmpwarn "The type of the form ~s is not ~s." original-form type))) |
246 |
|
|
247 |
(defun default-init (type) |
(defun default-init (type) |
248 |
(case type |
(case (promoted-c-type type) |
249 |
(fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) |
(fixnum (cmpwarn "The default value of NIL is not FIXNUM.")) |
250 |
(character (cmpwarn "The default value of NIL is not CHARACTER.")) |
(character (cmpwarn "The default value of NIL is not CHARACTER.")) |
251 |
(long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) |
(long-float (cmpwarn "The default value of NIL is not LONG-FLOAT.")) |