/[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.8 by camm, Tue Dec 28 22:24:18 2004 UTC revision 1.9 by camm, Fri Jan 7 17:58:33 2005 UTC
# Line 58  Line 58 
58        (array (list 'array (array-element-type thing)))        (array (list 'array (array-element-type thing)))
59        (t t))))   ;   'unknown ;; I can't see any use of this        (t t))))   ;   'unknown ;; I can't see any use of this
60    
61    ;;FIXME -- this function needs a rewrite.  CM 20050106
62  (defun type-filter (type)  (defun type-filter (type)
63      (when (and (symbolp type) (get type 'si::deftype-definition) (not (get type 's-data)))
64        (return-from type-filter type))
65    (case type    (case type
66          ((fixnum character short-float long-float) type)      ((character short-float long-float boolean) type)
67          (single-float 'long-float)      ((single-float double-float) 'long-float)
68          (boolean 'boolean)      ((nil t) t)
69          (double-float 'long-float)      (t (let ((type (si::normalize-type type)) element-type)
70          ((simple-string string) 'string)           (case (car type)
71          ((simple-bit-vector bit-vector) 'bit-vector)             ((simple-array array)
72          ((nil t) t)              (cond ((or (endp (cdr type))
73          (t (let ((type (si::normalize-type type)) element-type)                         (not (setq element-type
74               (case (car type)                                    (cond ((eq '*  (cadr type)) nil)
75                 ((simple-array array)                                          ((si::best-array-element-type
76                  (cond ((or (endp (cdr type))                                            (cadr type)))
77                             (not (setq element-type                                          (t t)))))
78                                        (cond ((eq '*  (cadr type)) nil)                     t)   ; I don't know.
79                                              ((si::best-array-element-type                    ((and (not (endp (cddr type)))
80                                                 (cadr type)))                          (not (eq (caddr type) '*))
81                                              (t t)))))                          (or (eql (caddr type) 1)
82                         t)       ; I don't know.                              (and (consp (caddr type))
83                        ((and (not (endp (cddr type)))                                   (= (length (caddr type)) 1))))
84                              (not (eq (caddr type) '*))                     (case element-type
85                              (or (eql (caddr type) 1)                       (string-char 'string)
86                                  (and (consp (caddr type))                       (bit 'bit-vector)
87                                       (= (length (caddr type)) 1))))                       (t (list 'vector element-type))))
88                         (case element-type                    (t (list 'array element-type))))
89                           (string-char 'string)             ((integer signed-byte unsigned-byte) type)
90                           (bit 'bit-vector)             ((short-float) 'short-float)
91                           (t (list 'vector element-type))))             ((long-float double-float single-float) 'long-float)
92                        (t (list 'array element-type))))             ((stream) 'stream)
93                 ((integer signed-byte unsigned-byte) type)             (t (cond ((subtypep type 'fixnum) 'fixnum)
94                 ((short-float) 'short-float)                      ((subtypep type 'integer) 'integer)
95                 ((long-float double-float single-float) 'long-float)                      ((subtypep type 'character) 'character)
96                 ((stream) 'stream)                      ((subtypep type 'short-float) 'short-float)
97                 (t (cond ((subtypep type 'fixnum) 'fixnum)                      ((subtypep type 'long-float) 'long-float)
98                          ((subtypep type 'integer) 'integer)                      ((subtypep type '(vector t)) '(vector t))
99                          ((subtypep type 'character) 'character)                      ((subtypep type 'string) 'string)
100                          ((subtypep type 'short-float) 'short-float)                      ((subtypep type 'bit-vector) 'bit-vector)
101                          ((subtypep type 'long-float) 'long-float)                      ((subtypep type '(vector fixnum)) '(vector fixnum))
102                          ((subtypep type '(vector t)) '(vector t))                      ((subtypep type '(vector short-float))
103                          ((subtypep type 'string) 'string)                       '(vector short-float))
104                          ((subtypep type 'bit-vector) 'bit-vector)                      ((subtypep type '(vector long-float))
105                          ((subtypep type '(vector fixnum)) '(vector fixnum))                       '(vector long-float))
106                          ((subtypep type '(vector short-float))                      ((subtypep type '(array t)) '(array t))
107                           '(vector short-float))                      ((subtypep type '(array string-char))
108                          ((subtypep type '(vector long-float))                       '(array string-char))
109                           '(vector long-float))                      ((subtypep type '(array bit)) '(array bit))
110                          ((subtypep type '(array t)) '(array t))                      ((subtypep type '(array fixnum)) '(array fixnum))
111                          ((subtypep type '(array string-char))                      ((subtypep type '(array short-float))
112                           '(array string-char))                       '(array short-float))
113                          ((subtypep type '(array bit)) '(array bit))                      ((subtypep type '(array long-float))
114                          ((subtypep type '(array fixnum)) '(array fixnum))                       '(array long-float))
115                          ((subtypep type '(array short-float))                      ((eq (car type) 'values)
116                           '(array short-float))                       (if  (null (cddr type))
117                          ((subtypep type '(array long-float))                           (list 'values (type-filter (second type)))
118                           '(array long-float))                         t))
119                          ((eq (car type) 'values)                      ((and (eq (car type) 'satisfies)
120                           (if  (null (cddr type))                            (symbolp (second type))
121                               (list 'values (type-filter (second type)))                            (get (second type) 'type-filter)))
122                             t))                      (t t)))
123                          ((and (eq (car type) 'satisfies)             )))))
                             (symbolp (second type))  
                             (get (second type) 'type-filter)))  
                         (t t)))  
                )))))  
124    
125    (defun type<= (t1 t2) (type>= t2 t1))
126    
127    ;;FIXME -- This function needs expansion on centralization.  CM 20050106
128  (defun promoted-c-type (type)  (defun promoted-c-type (type)
129    (let ((type (coerce-to-one-value type)))    (let ((type (coerce-to-one-value type)))
130      (if (integer-typep type)      (let ((ct (car (member type
131          (cond ;((subtypep type 'signed-char) 'signed-char)  ;                          '(signed-char signed-short fixnum integer)
132           ((subtypep type 'fixnum) 'fixnum)  ;                          '(signed-char unsigned-char signed-short unsigned-short fixnum integer)
133           ((subtypep type 'integer) 'integer)                             '(fixnum integer)
134           (t  (error "Cannot promote type ~S to C type~%" type)))                             :test #'type<=))))
135        type)))        (or ct type))))
136    ;      (if (integer-typep type)
137    ;       (cond ;((subtypep type 'signed-char) 'signed-char)
138    ;        ((subtypep type 'fixnum) 'fixnum)
139    ;        ((subtypep type 'integer) 'integer)
140    ;        (t  (error "Cannot promote type ~S to C type~%" type)))
141    ;      type)))
142    
143    (defun random-propagator (&rest r)
144      (let ((tp (si::normalize-type (cadr r))))
145        (if (integer-typep tp)
146            `(integer 0 ,(if (integerp (caddr tp)) (caddr tp) '*))
147          tp)))
148    (si::putprop 'random (function random-propagator) 'type-propagator)
149    
150  (defun ash-propagator (f t1 t2)  (defun ash-propagator (f t1 t2)
151    (and    (and
# Line 192  Line 207 
207         (let ((l (length type)))         (let ((l (length type)))
208           (and (<= 1 l 3)           (and (<= 1 l 3)
209                (or (< l 2) (integerp (cadr type)) (eq (cadr type) '*))                (or (< l 2) (integerp (cadr type)) (eq (cadr type) '*))
210                (or (< l 3) (integerp (caddr type)) (eq (caddr type) '*)))))))                (or (< l 3) (integerp (caddr type)) (eq (caddr type) '*))))))
211    
212  (defun coerce-to-integer-type (t1)  (defun coerce-to-integer-type (t1)
213    (if (integer-typep t1) t1    (if (integer-typep t1) t1
# Line 220  Line 235 
235                           t12 t21                           t12 t21
236                           (and (or (eq br '*) (eq er '*) (<= br er))                           (and (or (eq br '*) (eq er '*) (<= br er))
237                                (list (car ct1) br er))))))))))                                (list (car ct1) br er))))))))))
       
238    
239    ;;FIXME -- this is awful.  array and simple-array cannot be deftyped,
240    ;;-- the code for their processing needs to be centralized. CM 20050106
241    (defmacro array-wd (form)
242      `(member ,form '(array simple-array) :test #'eq))
243    (defmacro array-tp (form)
244      `(and (consp ,form) (array-wd (car ,form))))
245    
246    ;;FIXME -- centralize subtypep, normalzie-type, type>=, type-and.
247    ;;Consider traversing a static tree.  CM 20050106
248  (defun type-and (type1 type2)  (defun type-and (type1 type2)
249      
250    (cond ((equal type1 type2) type1)    (let ((nt1 (si::normalize-type type1)))
251        (unless (and (not (array-wd type1)) (equal nt1 (if (symbolp type1) (list type1) type1)))
252          (let ((tem (type-and nt1 type2)))
253            (return-from type-and (or (and (equal tem type2) type2) (and (equal tem nt1) type1) tem)))))
254      (let ((nt2 (si::normalize-type type2)))
255        (unless (and (not (array-wd type2)) (equal nt2 (if (symbolp type2) (list type2) type2)))
256          (let ((tem (type-and type1 nt2)))
257            (return-from type-and (if (equal tem nt2) type2 tem)))))
258    
259      (cond ((equal type1 type2) type2)
260          ((and (consp type2) (eq (car type2) 'values))          ((and (consp type2) (eq (car type2) 'values))
261           (if (and (consp type1) (eq (car type1) 'values))           (if (and (consp type1) (eq (car type1) 'values))
262               (let ((r (list 'values)))               (let ((r (list 'values)))
# Line 234  Line 266 
266                   (push (type-and (car t1) (car t2)) r)))                   (push (type-and (car t1) (car t2)) r)))
267             (type-and type1 (second type2))))             (type-and type1 (second type2))))
268          ((and (consp type1) (eq (car type1) 'values))          ((and (consp type1) (eq (car type1) 'values))
269             (type-and (second type1) type2))           (type-and (second type1) type2))
270          ((member type1 '(t * object) :test #'eq) type2)          ((eq type1 '*) type2)
271          ((member type2 '(t * object) :test #'eq) type1)          ((eq type2 '*) type1)
272            ((si::memq type1 '(t object)) type2)
273            ((si::memq type2 '(t object)) type1)
274          ((or (integer-typep type1) (integer-typep type2))          ((or (integer-typep type1) (integer-typep type2))
275           (integer-type-and type1 type2))           (integer-type-and type1 type2))
276          ((consp type1)          ((and (array-tp type1) (array-tp type2))
277           (case (car type1)           (cond
278                 (array            ((eq (car type1) (car type2))
279                  (case (cadr type1)             (cond
280                        (string-char (if (eq type2 'string) type2 nil))              ((null (cdr type1)) type2)
281                        (bit (if (eq type2 'bit-vector) type2 nil))              ((null (cdr type2)) type1)
282                        (t (if (and (consp type2)              ((null (cddr type1))
283                                    (eq (car type2) 'vector)               (cond
284                                    (eq (cadr type1) (cadr type2)))                ((eq (cadr type1) '*) type2)
285                               type2 nil))))                ((eq (cadr type1) (cadr type2)) type2)
286                 (vector                ((eq (cadr type2) '*) `(,(car type2) ,(cadr type1) ,@(cddr type2)))))
287                  (if (and (consp type2) (eq (car type2) 'array)              ((null (cddr type2))
288                           (eq (cadr type1) (cadr type2)))               (cond
289                      type1 nil))                ((eq (cadr type2) '*) type1)
290                 (t nil)))                ((eq (cadr type2) (cadr type1)) type1)
291          (t (case type1                ((eq (cadr type1) '*) `(,(car type1) ,(cadr type2) ,@(cddr type1)))))
292                   (string              (t
293                    (if (and (consp type2) (eq (car type2) 'array)               (cond
294                             (eq (cadr type2) 'string-char))                ((not (equal (caddr type1) (caddr type2))) nil)
295                        type1 nil))                ((eq (cadr type1) '*) type2)
296                   (bit-vector                ((eq (cadr type1) (cadr type2)) type2)
297                    (if (and (consp type2) (eq (car type2) 'array)                ((eq (cadr type2) '*) type1)))))
298                             (eq (cadr type2) 'bit))            ((eq (car type1) 'simple-array)
299                        type1 nil))             (type-and type1 `(simple-array ,@(cdr type2))))
300                   (fixnum-float            ((eq (car type2) 'simple-array)
301                    (if (member type2 '(fixnum float short-float long-float))             (type-and `(simple-array ,@(cdr type1)) type2))))
302                        type2 nil))          (t (case type1
303                   (float               (string
304                    (if (member type2 '(short-float long-float))                (if (and (consp type2) (eq (car type2) 'array)
305                        type2 nil))                                     (eq (cadr type2) 'string-char))
306                   ((long-float short-float)                                type1 nil))
307                    (if (member type2 '(fixnum-float float))                           (bit-vector
308                        type1 nil))                            (if (and (consp type2) (eq (car type2) 'array)
309                   ((signed-char unsigned-char signed-short)                                     (eq (cadr type2) 'bit))
310                    (if (eq type2 'fixnum) type1 nil))                                type1 nil))
311                   ((unsigned-short)                           (fixnum-float
312                    (if (subtypep type1 type2) type1 nil))                            (if (member type2 '(fixnum float short-float long-float))
313                   (integer                                type2 nil))
314                    (case type2                           (float
315                      (fixnum type2)))                            (if (member type2 '(short-float long-float))
316                   (fixnum                                type2 nil))
317                     (case type2                           ((long-float short-float)
318                       ((integer fixnum-float) 'fixnum)                            (if (member type2 '(fixnum-float float))
319                       ((signed-char unsigned-char signed-short bit)                                type1 nil))
320                        type2)                           ((signed-char unsigned-char signed-short)
321                       ((unsigned-short)                            (if (eq type2 'fixnum) type1 nil))
322                        (if (subtypep type2 type1) type2 nil))))                           ((unsigned-short)
323                   ))))                            (if (subtypep type1 type2) type1 nil))
324                             (integer
325                              (case type2
326                                (fixnum type2)))
327                             (fixnum
328                              (case type2
329                                ((integer fixnum-float) 'fixnum)
330                                ((signed-char unsigned-char signed-short bit)
331                                 type2)
332                                ((unsigned-short)
333                                 (if (subtypep type2 type1) type2 nil))))
334                             ))))
335                    
336  (defun type>= (type1 type2)  (defun type>= (type1 type2)
337    (equal (type-and type1 type2) type2))    (equal (type-and type1 type2) type2))
338    

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

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