/[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.4 by camm, Tue Dec 14 03:34:06 2004 UTC revision 1.5 by camm, Fri Dec 17 21:30:36 2004 UTC
# Line 130  Line 130 
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))))
# Line 168  Line 179 
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

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

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