/[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.17 by camm, Mon Sep 26 16:45:02 2005 UTC revision 1.18 by camm, Wed Oct 5 15:23:53 2005 UTC
# Line 63  Line 63 
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
# Line 79  Line 80 
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)))
# Line 284  Line 293 
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)))
# Line 291  Line 322 
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)

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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