/[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.15 by camm, Wed Sep 7 02:41:57 2005 UTC revision 1.16 by camm, Sun Sep 18 01:58:02 2005 UTC
# Line 31  Line 31 
31  ;;;     FIXNUM  CHARACTER  SHORT-FLOAT  LONG-FLOAT  ;;;     FIXNUM  CHARACTER  SHORT-FLOAT  LONG-FLOAT
32  ;;;     (VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)  ;;;     (VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)
33  ;;;     (VECTOR SHORT-FLOAT)  (VECTOR LONG-FLOAT)  ;;;     (VECTOR SHORT-FLOAT)  (VECTOR LONG-FLOAT)
34  ;;;     (ARRAY T)  (ARRAY STRING-CHAR)  (ARRAY BIT)  ;;;     (ARRAY T)  (ARRAY CHARACTER)  (ARRAY BIT)
35  ;;;     (ARRAY FIXNUM)  ;;;     (ARRAY FIXNUM)
36  ;;;     (ARRAY SHORT-FLOAT)  (ARRAY LONG-FLOAT)  ;;;     (ARRAY SHORT-FLOAT)  (ARRAY LONG-FLOAT)
37  ;;;     UNKNOWN  ;;;     UNKNOWN
# Line 52  Line 52 
52    (let ((type (type-of thing)))    (let ((type (type-of thing)))
53      (case type      (case type
54        ((fixnum bignum) `(integer ,thing ,thing))        ((fixnum bignum) `(integer ,thing ,thing))
55        ((short-float long-float symbol) type)        ((short-float long-float symbol null boolean) type)
56        (cons `(cons ,(object-type (car thing)) ,(if (cdr thing) (object-type (cdr thing)) 'null)))        (cons `(cons ,(object-type (car thing)) ,(if (cdr thing) (object-type (cdr thing)) 'null)))
57        (keyword 'symbol)        (keyword 'symbol)
58        ((string-char standard-char character) 'character)        ((standard-char character) 'character)
59        ((string bit-vector) type)        ((string bit-vector) type)
60        (vector (list 'vector (array-element-type thing)))        (vector (list 'vector (array-element-type thing)))
61        (array (list 'array (array-element-type thing)))        (array (list 'array (array-element-type thing)))
# Line 86  Line 86 
86                              (and (consp (caddr type))                              (and (consp (caddr type))
87                                   (= (length (caddr type)) 1))))                                   (= (length (caddr type)) 1))))
88                     (case element-type                     (case element-type
 ;                    (string-char 'string)  
89                       (bit 'bit-vector)                       (bit 'bit-vector)
90                       (t (list 'vector element-type))))                       (t (list 'vector element-type))))
91                    (t (list 'array element-type))))                    (t (list 'array element-type))))
# Line 108  Line 107 
107                      ((subtypep type '(vector long-float))                      ((subtypep type '(vector long-float))
108                       '(vector long-float))                       '(vector long-float))
109                      ((subtypep type '(array t)) '(array t))                      ((subtypep type '(array t)) '(array t))
                     ((subtypep type '(array string-char))  
                      '(array string-char))  
110                      ((subtypep type '(array bit)) '(array bit))                      ((subtypep type '(array bit)) '(array bit))
111                      ((subtypep type '(array fixnum)) '(array fixnum))                      ((subtypep type '(array fixnum)) '(array fixnum))
112                      ((subtypep type '(array short-float))                      ((subtypep type '(array short-float))
# Line 263  Line 260 
260    
261  ;;FIXME -- centralize subtypep, normalzie-type, type>=, type-and.  ;;FIXME -- centralize subtypep, normalzie-type, type>=, type-and.
262  ;;Consider traversing a static tree.  CM 20050106  ;;Consider traversing a static tree.  CM 20050106
263  (defun type-and (type1 type2 &aux tem)  (defun type-and (type1 type2)
264    
265    (let ((nt1 (si::normalize-type type1)))  ;  (let ((nt1 (si::normalize-type type1)))
266      (unless (and (not (array-wd type1)) (equal nt1 (if (symbolp type1) (list type1) type1)))  ;    (unless (and (not (array-wd type1)) (equal nt1 (if (symbolp type1) (list type1) type1)))
267        (let ((tem (type-and nt1 type2)))  ;      (let ((tem (type-and nt1 type2)))
268          (return-from type-and (or (and (equal tem type2) type2) (and (equal tem nt1) type1) tem)))))  ;       (return-from type-and (or (and (equal tem type2) type2) (and (equal tem nt1) type1) tem)))))
269    (let ((nt2 (si::normalize-type type2)))  ;  (let ((nt2 (si::normalize-type type2)))
270      (unless (and (not (array-wd type2)) (equal nt2 (if (symbolp type2) (list type2) type2)))  ;    (unless (and (not (array-wd type2)) (equal nt2 (if (symbolp type2) (list type2) type2)))
271        (let ((tem (type-and type1 nt2)))  ;      (let ((tem (type-and type1 nt2)))
272          (return-from type-and (if (equal tem nt2) type2 tem)))))  ;       (return-from type-and (if (equal tem nt2) type2 tem)))))
273    
274    (cond ((equal type1 type2) type2)    (cond ;((equal type1 type2) type2)
275          ((and (consp type2) (eq (car type2) 'values))          ((and (consp type2) (eq (car type2) 'values))
276           (if (and (consp type1) (eq (car type1) 'values))           (if (and (consp type1) (eq (car type1) 'values))
277               (let ((r (list 'values)))               (let ((r (list 'values)))
# Line 285  Line 282 
282             (type-and type1 (second type2))))             (type-and type1 (second type2))))
283          ((and (consp type1) (eq (car type1) 'values))          ((and (consp type1) (eq (car type1) 'values))
284           (type-and (second type1) type2))           (type-and (second type1) type2))
285          ((eq type1 '*) type2)          ((member type1 '(t object *)) type2)
286          ((eq type2 '*) type1)          ((member type2 '(t object *)) type1)
287          ((si::memq type1 '(t object)) type2)          ((let* ((n (si::normalize-type-int `(and ,type1 ,type2) t))
288          ((si::memq type2 '(t object)) type1)                  (tem (si::normalize-type-int (car (si::nreconstruct-type (si::nprocess-type n))) t)))
289          ((setq tem (car (si::resolve-type `(and ,type1 ,type2))));FIXME             (cond ((equal tem (caddr n)) type2)
290           (let ((ntem (si::normalize-type tem)))                   ((equal tem (cadr n)) type1)
291             (cond ((equal ntem type1) type1)                   (tem))))))
                  ((equal ntem type2) type2)  
                  (tem))))  
         ((or (integer-typep type1) (integer-typep type2))  
          (integer-type-and type1 type2));FIXME  
         ((and (array-tp type1) (array-tp type2))  
          (cond  
           ((eq (car type1) (car type2))  
            (cond  
             ((null (cdr type1)) type2)  
             ((null (cdr type2)) type1)  
             ((null (cddr type1))  
              (cond  
               ((eq (cadr type1) '*) type2)  
               ((eq (cadr type1) (cadr type2)) type2)  
               ((eq (cadr type2) '*) `(,(car type2) ,(cadr type1) ,@(cddr type2)))))  
             ((null (cddr type2))  
              (cond  
               ((eq (cadr type2) '*) type1)  
               ((eq (cadr type2) (cadr type1)) type1)  
               ((eq (cadr type1) '*) `(,(car type1) ,(cadr type2) ,@(cddr type1)))))  
             (t  
              (cond  
               ((not (equal (caddr type1) (caddr type2))) nil)  
               ((eq (cadr type1) '*) type2)  
               ((eq (cadr type1) (cadr type2)) type2)  
               ((eq (cadr type2) '*) type1)))))  
           ((eq (car type1) 'simple-array)  
            (type-and type1 `(simple-array ,@(cdr type2))))  
           ((eq (car type2) 'simple-array)  
            (type-and `(simple-array ,@(cdr type1)) type2))))  
         (t (case type1  
              (string  
               (if (and (consp type2) (eq (car type2) 'array)  
                        (eq (cadr type2) 'string-char))  
                   type1 nil))  
              (bit-vector  
               (if (and (consp type2) (eq (car type2) 'array)  
                        (eq (cadr type2) 'bit))  
                   type1 nil))  
              (fixnum-float  
               (if (member type2 '(fixnum float short-float long-float))  
                   type2 nil))  
              (float  
               (if (member type2 '(short-float long-float))  
                               type2 nil))  
              ((long-float short-float)  
               (if (member type2 '(fixnum-float float))  
                   type1 nil))  
              ((signed-char unsigned-char signed-short)  
               (if (eq type2 'fixnum) type1 nil))  
              ((unsigned-short)  
               (if (subtypep type1 type2) type1 nil))  
              (integer  
               (case type2  
                     (fixnum type2)))  
              (fixnum  
               (case type2  
                     ((integer fixnum-float) 'fixnum)  
                     ((signed-char unsigned-char signed-short bit)  
                      type2)  
                     ((unsigned-short)  
                      (if (subtypep type2 type1) type2 nil))))  
              (otherwise  
               (if (subtypep type1 type2) type1 (if (subtypep type2 type1) type2 nil)))  
              ))))  
292                                    
293  (defun type>= (type1 type2)  (defun type>= (type1 type2)
294    (eq (type-and type1 type2) type2))    (eq (type-and type1 type2) type2))

Legend:
Removed from v.1.15  
changed lines
  Added in v.1.16

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