63 |
|
|
64 |
(defvar *norm-tp-hash* (make-hash-table :test 'equal)) |
(defvar *norm-tp-hash* (make-hash-table :test 'equal)) |
65 |
(defvar *and-tp-hash* (make-hash-table :test 'equal)) |
(defvar *and-tp-hash* (make-hash-table :test 'equal)) |
66 |
|
(defvar *or-tp-hash* (make-hash-table :test 'equal)) |
67 |
|
|
68 |
(defun cmp-norm-tp (tp) |
(defun cmp-norm-tp (tp) |
69 |
(multiple-value-bind |
(multiple-value-bind |
80 |
(cond (f r) |
(cond (f r) |
81 |
((setf (gethash x *and-tp-hash*) (type-and-int t1 t2))))))) |
((setf (gethash x *and-tp-hash*) (type-and-int t1 t2))))))) |
82 |
|
|
83 |
|
(defun type-or1 (t1 t2) |
84 |
|
(let ((x (cons t1 t2))) |
85 |
|
(multiple-value-bind |
86 |
|
(r f) |
87 |
|
(gethash x *norm-tp-hash*) |
88 |
|
(cond (f r) |
89 |
|
((setf (gethash x *or-tp-hash*) (type-or1-int t1 t2))))))) |
90 |
|
|
91 |
;;FIXME -- this function needs a rewrite. CM 20050106 |
;;FIXME -- this function needs a rewrite. CM 20050106 |
92 |
(defun type-filter (type) |
(defun type-filter (type) |
93 |
(when (and (symbolp type) (get type 'si::deftype-definition) (not (get type 's-data)) (not (eq type 'string))) |
(when (and (symbolp type) (get type 'si::deftype-definition) (not (get type 's-data)) (not (eq type 'string))) |
293 |
(equal (type-and type1 type2) type1)) |
(equal (type-and type1 type2) type1)) |
294 |
|
|
295 |
|
|
296 |
|
(defun type-or1-int (type1 type2) |
297 |
|
(cond ((equal type1 type2) type2) |
298 |
|
((and (consp type2) (eq (car type2) 'values)) |
299 |
|
(if (and (consp type1) (eq (car type1) 'values)) |
300 |
|
(let ((r (list 'values))) |
301 |
|
(do ((t1 (cdr type1) (cdr t1)) |
302 |
|
(t2 (cdr type2) (cdr t2))) |
303 |
|
((not (and (consp t1) (consp t2))) (nreverse r)) |
304 |
|
(push (type-or1 (car t1) (car t2)) r))) |
305 |
|
(type-or1 type1 (second type2)))) |
306 |
|
((and (consp type1) (eq (car type1) 'values)) |
307 |
|
(type-or1 (second type1) type2)) |
308 |
|
((member type1 '(t object *)) type1) |
309 |
|
((member type2 '(t object *)) type2) |
310 |
|
((let* ((n (cmp-norm-tp `(or ,type1 ,type2))) |
311 |
|
(tem (cmp-norm-tp (car (si::nreconstruct-type (si::nprocess-type n)))))) |
312 |
|
(cond ((equal tem (caddr n)) type2) ;;FIXME centralize normalization |
313 |
|
((equal tem (cadr n)) type1) |
314 |
|
((not (car tem)) nil) |
315 |
|
((eq (car tem) t)) |
316 |
|
(tem)))))) |
317 |
|
|
318 |
(defun reset-info-type (info) |
(defun reset-info-type (info) |
319 |
(if (info-type info) |
(if (info-type info) |
320 |
(let ((info1 (copy-info info))) |
(let ((info1 (copy-info info))) |
322 |
info1) |
info1) |
323 |
info)) |
info)) |
324 |
|
|
325 |
|
;(defun reset-info-type (x) x) |
326 |
|
|
327 |
(defun and-form-type (type form original-form &aux type1) |
(defun and-form-type (type form original-form &aux type1) |
328 |
(setq type1 (type-and type (info-type (cadr form)))) |
(setq type1 (type-and type (info-type (cadr form)))) |
329 |
(when (null type1) |
(when (null type1) |