50 |
(defun object-type (thing) |
(defun object-type (thing) |
51 |
(let ((type (type-of thing))) |
(let ((type (type-of thing))) |
52 |
(case type |
(case type |
53 |
((fixnum short-float long-float) type) |
((fixnum bignum) `(integer ,thing ,thing)) |
54 |
|
((short-float long-float) type) |
55 |
((string-char standard-char character) 'character) |
((string-char standard-char character) 'character) |
56 |
((string bit-vector) type) |
((string bit-vector) type) |
57 |
(vector (list 'vector (array-element-type thing))) |
(vector (list 'vector (array-element-type thing))) |
124 |
))))) |
))))) |
125 |
|
|
126 |
(defun promoted-c-type (type) |
(defun promoted-c-type (type) |
127 |
(if (bounded-type type) |
(let ((type (coerce-to-one-value type))) |
128 |
(cond ;((subtypep type 'signed-char) 'signed-char) |
(if (bounded-type type) |
129 |
((subtypep type 'fixnum) 'fixnum) |
(cond ;((subtypep type 'signed-char) 'signed-char) |
130 |
((subtypep type 'integer) 'integer) |
((subtypep type 'fixnum) 'fixnum) |
131 |
(t (error "Cannot promote type ~S to C type~%" type))) |
((subtypep type 'integer) 'integer) |
132 |
type))) |
(t (error "Cannot promote type ~S to C type~%" type))) |
133 |
|
type))) |
134 |
|
|
135 |
(defun coerce-to-bounded-type (t1) |
(defun coerce-to-bounded-type (t1) |
136 |
(if (bounded-type t1) t1 |
(if (bounded-type t1) t1 |
137 |
(let ((t1 (si::normalize-type t1))) |
(let ((t1 (si::normalize-type t1))) |
138 |
(if (bounded-type t1) t1)))) |
(if (bounded-type t1) t1)))) |
139 |
|
|
140 |
|
(defun ash-propagator (f t1 t2) |
141 |
|
(and |
142 |
|
(type>= 'fixnum t1) |
143 |
|
(type>= '(integer #.most-negative-fixnum #.(integer-length most-positive-fixnum)) t2) |
144 |
|
(super-range f t1 t2))) |
145 |
|
|
146 |
|
(defun floor-propagator (f t1 t2) |
147 |
|
(let ((t1 (coerce-to-bounded-type t1)) |
148 |
|
(t2 (coerce-to-bounded-type t2))) |
149 |
|
(and t2 (> (* (cadr t2) (caddr t2)) 0) |
150 |
|
(let ((sr (super-range f t1 t2))) |
151 |
|
(and sr |
152 |
|
(list 'values sr |
153 |
|
(let ((outer (if (< (cadr t2) 0) (cadr t2) (caddr t2)))) |
154 |
|
(let ((a (cadr (multiple-value-list |
155 |
|
(funcall (symbol-function f) 1 outer)))) |
156 |
|
(b (cadr (multiple-value-list |
157 |
|
(funcall (symbol-function f) -1 outer)))) |
158 |
|
(c (cadr (multiple-value-list |
159 |
|
(funcall (symbol-function f) (1+ outer) outer)))) |
160 |
|
(d (cadr (multiple-value-list |
161 |
|
(funcall (symbol-function f) (1- outer) outer))))) |
162 |
|
(let ((p (min a b c d))) |
163 |
|
(if (< p 0) |
164 |
|
(list (car t2) p 0) |
165 |
|
(list (car t2) 0 (max a b c d)))))))))))) |
166 |
|
|
167 |
|
|
168 |
|
|
169 |
(defun super-range (f ot1 ot2) |
(defun super-range (f ot1 ot2) |
170 |
(let ((t1 (coerce-to-bounded-type ot1)) |
(let ((t1 (coerce-to-bounded-type ot1)) |
171 |
(t2 (coerce-to-bounded-type ot2))) |
(t2 (coerce-to-bounded-type ot2))) |