/[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.5 by camm, Fri Dec 17 21:30:36 2004 UTC revision 1.6 by camm, Tue Dec 21 04:49:47 2004 UTC
# Line 50  Line 50 
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)))
# Line 123  Line 124 
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)))

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

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