/[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.3 by camm, Thu Sep 16 21:08:18 2004 UTC revision 1.4 by camm, Tue Dec 14 03:34:06 2004 UTC
# Line 86  Line 86 
86                           (bit 'bit-vector)                           (bit 'bit-vector)
87                           (t (list 'vector element-type))))                           (t (list 'vector element-type))))
88                        (t (list 'array element-type))))                        (t (list 'array element-type))))
89                 (integer                 ((integer signed-byte unsigned-byte) type)
                 (if (si::sub-interval-p (cdr type)  
                                         (list most-negative-fixnum  
                                               most-positive-fixnum))  
                     'fixnum  
                     'integer))  
90                 ((short-float) 'short-float)                 ((short-float) 'short-float)
91                 ((long-float double-float single-float) 'long-float)                 ((long-float double-float single-float) 'long-float)
92                 ((stream) 'stream)                 ((stream) 'stream)
# Line 127  Line 122 
122                          (t t)))                          (t t)))
123                 )))))                 )))))
124    
125    (defun promoted-c-type (type)
126      (if (bounded-type type)
127          (cond ;((subtypep type 'signed-char) 'signed-char)
128                ((subtypep type 'fixnum) 'fixnum)
129                ((subtypep type 'integer) 'integer)
130                (t  (error "Cannot promote type ~S to C type~%" type)))
131        type)))
132    
133    (defun super-range (f t1 t2)
134      (and
135       (bounded-type t1)
136       (bounded-type t2)
137       (eq (car t1) (car t2))
138       (let ((a (funcall (symbol-function f) (cadr t1) (cadr t2)))
139             (b (funcall (symbol-function f) (cadr t1) (caddr t2)))
140             (c (funcall (symbol-function f) (caddr t1) (cadr t2)))
141             (d (funcall (symbol-function f) (caddr t1) (caddr t2))))
142         (list (car t1) (min a b c d) (max a b c d)))))
143            
144    (defun bounded-type (type)
145      (and (consp type)
146           (eql (length type) 3)
147           (member (car type) '(integer signed-byte unsigned-byte) :test #'eq)
148           (integerp (cadr type))
149           (integerp (caddr type))))
150    
151  (defun type-and (type1 type2)  (defun type-and (type1 type2)
152        
# Line 148  Line 167 
167          ((eq type2 'object) type1)          ((eq type2 'object) type1)
168          ((eq type2 t) type1)          ((eq type2 t) type1)
169          ((eq type2 '*) type1)          ((eq type2 '*) type1)
170            ((or (bounded-type type1) (bounded-type type2))
171             (cond ((subtypep type1 type2) type1)
172                   ((subtypep type2 type1) type2)
173                   (t nil)))
174          ((consp type1)          ((consp type1)
175           (case (car type1)           (case (car type1)
176                 (array                 (array
# Line 222  Line 245 
245          (cmpwarn "The type of the form ~s is not ~s." original-form type)))          (cmpwarn "The type of the form ~s is not ~s." original-form type)))
246    
247  (defun default-init (type)  (defun default-init (type)
248    (case type    (case (promoted-c-type type)
249          (fixnum (cmpwarn "The default value of NIL is not FIXNUM."))          (fixnum (cmpwarn "The default value of NIL is not FIXNUM."))
250          (character (cmpwarn "The default value of NIL is not CHARACTER."))          (character (cmpwarn "The default value of NIL is not CHARACTER."))
251          (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT."))          (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT."))

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

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