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 |
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))) |
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)))) |
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)) |
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))) |
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)) |