125 |
|
|
126 |
(defun promoted-c-type (type) |
(defun promoted-c-type (type) |
127 |
(let ((type (coerce-to-one-value type))) |
(let ((type (coerce-to-one-value type))) |
128 |
(if (bounded-type type) |
(if (integer-typep type) |
129 |
(cond ;((subtypep type 'signed-char) 'signed-char) |
(cond ;((subtypep type 'signed-char) 'signed-char) |
130 |
((subtypep type 'fixnum) 'fixnum) |
((subtypep type 'fixnum) 'fixnum) |
131 |
((subtypep type 'integer) 'integer) |
((subtypep type 'integer) 'integer) |
132 |
(t (error "Cannot promote type ~S to C type~%" type))) |
(t (error "Cannot promote type ~S to C type~%" type))) |
133 |
type))) |
type))) |
134 |
|
|
|
(defun coerce-to-bounded-type (t1) |
|
|
(if (bounded-type t1) t1 |
|
|
(let ((t1 (si::normalize-type t1))) |
|
|
(if (bounded-type t1) t1)))) |
|
|
|
|
135 |
(defun ash-propagator (f t1 t2) |
(defun ash-propagator (f t1 t2) |
136 |
(and |
(and |
137 |
(type>= 'fixnum t1) |
(type>= 'fixnum t1) |
138 |
(type>= '(integer #.most-negative-fixnum #.(integer-length most-positive-fixnum)) t2) |
(type>= '(integer #.most-negative-fixnum #.(integer-length most-positive-fixnum)) t2) |
139 |
(super-range f t1 t2))) |
(super-range f t1 t2))) |
140 |
|
|
141 |
(defun floor-propagator (f t1 t2) |
(defun floor-propagator (f t1 &optional (t2 '(integer 1 1))) |
142 |
(let ((t1 (coerce-to-bounded-type t1)) |
(let ((t1 (coerce-to-integer-type t1)) |
143 |
(t2 (coerce-to-bounded-type t2))) |
(t2 (coerce-to-integer-type t2))) |
144 |
(and t2 (> (* (cadr t2) (caddr t2)) 0) |
(and t2 |
145 |
(let ((sr (super-range f t1 t2))) |
(let ((i21 (integerp (cadr t2))) |
146 |
(and sr |
(i22 (integerp (caddr t2)))) |
147 |
(list 'values sr |
(and i21 i22 (> (* (cadr t2) (caddr t2)) 0) |
148 |
(let ((outer (if (< (cadr t2) 0) (cadr t2) (caddr t2)))) |
(let ((sr (super-range f t1 t2))) |
149 |
(let ((a (cadr (multiple-value-list |
(and sr |
150 |
(funcall (symbol-function f) 1 outer)))) |
(list 'values sr |
151 |
(b (cadr (multiple-value-list |
(let ((outer (if (< (cadr t2) 0) (cadr t2) (caddr t2)))) |
152 |
(funcall (symbol-function f) -1 outer)))) |
(let ((a (cadr (multiple-value-list |
153 |
(c (cadr (multiple-value-list |
(funcall (symbol-function f) 1 outer)))) |
154 |
(funcall (symbol-function f) (1+ outer) outer)))) |
(b (cadr (multiple-value-list |
155 |
(d (cadr (multiple-value-list |
(funcall (symbol-function f) -1 outer)))) |
156 |
(funcall (symbol-function f) (1- outer) outer))))) |
(c (cadr (multiple-value-list |
157 |
(let ((p (min a b c d))) |
(funcall (symbol-function f) (1+ outer) outer)))) |
158 |
(if (< p 0) |
(d (cadr (multiple-value-list |
159 |
(list (car t2) p 0) |
(funcall (symbol-function f) (1- outer) outer))))) |
160 |
(list (car t2) 0 (max a b c d)))))))))))) |
(let ((p (min a b c d))) |
161 |
|
(if (< p 0) |
162 |
|
(list (car t2) p 0) |
163 |
|
(list (car t2) 0 (max a b c d)))))))))))))) |
164 |
|
|
165 |
|
|
166 |
(defun super-range (f ot1 ot2) |
(defun super-range (f t1 &optional (t2 nil t2p)) |
167 |
(let ((t1 (coerce-to-bounded-type ot1)) |
(let ((t1 (coerce-to-integer-type t1))) |
|
(t2 (coerce-to-bounded-type ot2))) |
|
168 |
(and t1 |
(and t1 |
169 |
(if ot2 |
(let ((i11 (integerp (cadr t1))) |
170 |
(and |
(i12 (integerp (caddr t1)))) |
171 |
t2 |
(if (and i11 i12) |
172 |
(eq (car t1) (car t2)) |
(if t2p |
173 |
(let ((a (funcall (symbol-function f) (cadr t1) (cadr t2))) |
(let ((t2 (coerce-to-integer-type t2))) |
174 |
(b (funcall (symbol-function f) (cadr t1) (caddr t2))) |
(and t2 (eq (car t1) (car t2)) |
175 |
(c (funcall (symbol-function f) (caddr t1) (cadr t2))) |
(let ((i21 (integerp (cadr t2))) |
176 |
(d (funcall (symbol-function f) (caddr t1) (caddr t2)))) |
(i22 (integerp (caddr t2)))) |
177 |
(list (car t1) (min a b c d) (max a b c d)))) |
(if (and i21 i22) |
178 |
(let ((a (funcall (symbol-function f) (cadr t1))) |
(let ((a (funcall (symbol-function f) (cadr t1) (cadr t2))) |
179 |
(b (funcall (symbol-function f) (caddr t1)))) |
(b (funcall (symbol-function f) (cadr t1) (caddr t2))) |
180 |
(list (car t1) (min a b) (max a b))))))) |
(c (funcall (symbol-function f) (caddr t1) (cadr t2))) |
181 |
|
(d (funcall (symbol-function f) (caddr t1) (caddr t2)))) |
182 |
|
(list (car t1) (min a b c d) (max a b c d))) |
183 |
|
(list (car t1) '* '*))))) |
184 |
|
(let ((a (funcall (symbol-function f) (cadr t1))) |
185 |
|
(b (funcall (symbol-function f) (caddr t1)))) |
186 |
|
(list (car t1) (min a b) (max a b)))) |
187 |
|
(list (car t1) '* '*)))))) |
188 |
|
|
189 |
(defun bounded-type (type) |
(defun integer-typep (type) |
190 |
(and (consp type) |
(and (consp type) |
|
(= (length type) 3) |
|
191 |
(member (car type) '(integer signed-byte unsigned-byte) :test #'eq) |
(member (car type) '(integer signed-byte unsigned-byte) :test #'eq) |
192 |
(integerp (cadr type)) |
(let ((l (length type))) |
193 |
(integerp (caddr type)))) |
(and (<= 1 l 3) |
194 |
|
(or (< l 2) (integerp (cadr type)) (eq (cadr type) '*)) |
195 |
|
(or (< l 3) (integerp (caddr type)) (eq (caddr type) '*))))))) |
196 |
|
|
197 |
|
(defun coerce-to-integer-type (t1) |
198 |
|
(if (integer-typep t1) t1 |
199 |
|
(let ((t1 (si::normalize-type t1))) |
200 |
|
(if (integer-typep t1) t1)))) |
201 |
|
|
202 |
|
(defun integer-type-and (type1 type2) |
203 |
|
(let ((ct1 (coerce-to-integer-type type1)) |
204 |
|
(ct2 (coerce-to-integer-type type2))) |
205 |
|
(and ct1 ct2 |
206 |
|
(eq (car ct1) (car ct2)) |
207 |
|
(let ((b1 (cadr ct1)) |
208 |
|
(e1 (caddr ct1)) |
209 |
|
(b2 (cadr ct2)) |
210 |
|
(e2 (caddr ct2))) |
211 |
|
(let ((i11 (integerp b1)) |
212 |
|
(i12 (integerp e1)) |
213 |
|
(i21 (integerp b2)) |
214 |
|
(i22 (integerp e2))) |
215 |
|
(let ((br (if i11 (if i21 (max b1 b2) b1) (if i21 b2 '*))) |
216 |
|
(er (if i12 (if i22 (min e1 e2) e1) (if i22 e2 '*)))) |
217 |
|
(let ((t12 (and (eql br b1) (eql er e1) type1)) |
218 |
|
(t21 (and (eql br b2) (eql er e2) type2))) |
219 |
|
(or (and t12 t21) |
220 |
|
t12 t21 |
221 |
|
(and (or (eq br '*) (eq er '*) (<= br er)) |
222 |
|
(list (car ct1) br er)))))))))) |
223 |
|
|
224 |
|
|
225 |
(defun type-and (type1 type2) |
(defun type-and (type1 type2) |
226 |
|
|
241 |
((eq type2 'object) type1) |
((eq type2 'object) type1) |
242 |
((eq type2 t) type1) |
((eq type2 t) type1) |
243 |
((eq type2 '*) type1) |
((eq type2 '*) type1) |
244 |
((or (bounded-type type1) (bounded-type type2)) |
((or (integer-typep type1) (integer-typep type2)) |
245 |
(let ((t12 (and (subtypep type1 type2) type1)) |
(integer-type-and type1 type2)) |
|
(t21 (and (subtypep type2 type1) type2))) |
|
|
(or (and t12 t21) |
|
|
t12 t21 |
|
|
(let ((ct1 (coerce-to-bounded-type type1)) |
|
|
(ct2 (coerce-to-bounded-type type2))) |
|
|
(and ct1 ct2 |
|
|
(eq (car ct1) (car ct2)) |
|
|
(list (car ct1) (max (cadr ct1) (cadr ct2)) (min (caddr ct1) (caddr ct2)))))))) |
|
246 |
((consp type1) |
((consp type1) |
247 |
(case (car type1) |
(case (car type1) |
248 |
(array |
(array |