130 |
(t (error "Cannot promote type ~S to C type~%" type))) |
(t (error "Cannot promote type ~S to C type~%" type))) |
131 |
type))) |
type))) |
132 |
|
|
133 |
(defun super-range (f t1 t2) |
(defun coerce-to-bounded-type (t1) |
134 |
(and |
(if (bounded-type t1) t1 |
135 |
(bounded-type t1) |
(let ((t1 (si::normalize-type t1))) |
136 |
(bounded-type t2) |
(if (bounded-type t1) t1)))) |
137 |
(eq (car t1) (car t2)) |
|
138 |
(let ((a (funcall (symbol-function f) (cadr t1) (cadr t2))) |
(defun super-range (f ot1 ot2) |
139 |
(b (funcall (symbol-function f) (cadr t1) (caddr t2))) |
(let ((t1 (coerce-to-bounded-type ot1)) |
140 |
(c (funcall (symbol-function f) (caddr t1) (cadr t2))) |
(t2 (coerce-to-bounded-type ot2))) |
141 |
(d (funcall (symbol-function f) (caddr t1) (caddr t2)))) |
(and t1 |
142 |
(list (car t1) (min a b c d) (max a b c d))))) |
(if ot2 |
143 |
|
(and |
144 |
|
t2 |
145 |
|
(eq (car t1) (car t2)) |
146 |
|
(let ((a (funcall (symbol-function f) (cadr t1) (cadr t2))) |
147 |
|
(b (funcall (symbol-function f) (cadr t1) (caddr t2))) |
148 |
|
(c (funcall (symbol-function f) (caddr t1) (cadr t2))) |
149 |
|
(d (funcall (symbol-function f) (caddr t1) (caddr t2)))) |
150 |
|
(list (car t1) (min a b c d) (max a b c d)))) |
151 |
|
(let ((a (funcall (symbol-function f) (cadr t1))) |
152 |
|
(b (funcall (symbol-function f) (caddr t1)))) |
153 |
|
(list (car t1) (min a b) (max a b))))))) |
154 |
|
|
155 |
(defun bounded-type (type) |
(defun bounded-type (type) |
156 |
(and (consp type) |
(and (consp type) |
157 |
(eql (length type) 3) |
(= (length type) 3) |
158 |
(member (car type) '(integer signed-byte unsigned-byte) :test #'eq) |
(member (car type) '(integer signed-byte unsigned-byte) :test #'eq) |
159 |
(integerp (cadr type)) |
(integerp (cadr type)) |
160 |
(integerp (caddr type)))) |
(integerp (caddr type)))) |
179 |
((eq type2 t) type1) |
((eq type2 t) type1) |
180 |
((eq type2 '*) type1) |
((eq type2 '*) type1) |
181 |
((or (bounded-type type1) (bounded-type type2)) |
((or (bounded-type type1) (bounded-type type2)) |
182 |
(cond ((subtypep type1 type2) type1) |
(let ((t12 (and (subtypep type1 type2) type1)) |
183 |
((subtypep type2 type1) type2) |
(t21 (and (subtypep type2 type1) type2))) |
184 |
(t nil))) |
(or (and t12 t21) |
185 |
|
t12 t21 |
186 |
|
(let ((ct1 (coerce-to-bounded-type type1)) |
187 |
|
(ct2 (coerce-to-bounded-type type2))) |
188 |
|
(and ct1 ct2 |
189 |
|
(eq (car ct1) (car ct2)) |
190 |
|
(list (car ct1) (max (cadr ct1) (cadr ct2)) (min (caddr ct1) (caddr ct2)))))))) |
191 |
((consp type1) |
((consp type1) |
192 |
(case (car type1) |
(case (car type1) |
193 |
(array |
(array |