/[gcl]/gcl/cmpnew/gcl_cmptype.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmptype.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by camm, Tue Dec 21 04:49:47 2004 UTC revision 1.7 by camm, Mon Dec 27 22:16:54 2004 UTC
# Line 125  Line 125 
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        
# Line 209  Line 241 
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

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26