diff --git a/code/type.lisp b/code/type.lisp index be46ff82f7e44be2c47d00c981f12180aa94fd7b..31cc801b6e86c1d236ac392af6996030d397b68c 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.56 2003/04/17 21:19:04 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.57 2003/04/23 15:19:41 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -446,6 +446,12 @@ ); eval-when (compile eval) +(declaim (inline reparse-unknown-type)) +(defun reparse-unknown-type (type) + (if (unknown-type-p type) + (specifier-type (type-specifier type)) + type)) + (declaim (inline swapped-args-fun)) (defun swapped-args-fun (fun) (declare (type function fun)) @@ -461,19 +467,6 @@ (equal-but-no-car-recursion (cdr x) (cdr y)))) (t nil))) -(defun hierarchical-intersection2 (type1 type2) - (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) - (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) - (cond (subtypep1 type1) - (subtypep2 type2) - ((and win1 win2) *empty-type*) - (t nil))))) - -(defun hierarchical-union2 (type1 type2) - (cond ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - (t nil))) - (defun any/type (op thing list) (declare (type function op)) (let ((certain? t)) @@ -1137,6 +1130,8 @@ :init-form cold-load-init) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-type type1)) + (setq type2 (reparse-unknown-type type2)) (cond ((eq type1 type2) type1) ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) @@ -1214,6 +1209,8 @@ :init-form cold-load-init) ((type1 eq) (type2 eq)) (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-type type1)) + (setq type2 (reparse-unknown-type type2)) (cond ((eq type1 type2) ;; FIXME: For some reason, this doesn't catch e.g. type1 = ;; type2 = (SPECIFIER-TYPE @@ -2840,16 +2837,17 @@ (def-type-translator member (&rest members) (if members - (let (ms numbers) + (collect ((non-numbers) (numbers)) (dolist (m (remove-duplicates members)) - (typecase m - (number (push (ctype-of m) numbers)) - (t (push m ms)))) + (if (and (numberp m) + (not (and (floatp m) (zerop m)))) + (numbers (ctype-of m)) + (non-numbers m))) (apply #'type-union - (if ms - (make-member-type :members ms) + (if (non-numbers) + (make-member-type :members (non-numbers)) *empty-type*) - (nreverse numbers))) + (numbers))) *empty-type*)) diff --git a/code/typedefs.lisp b/code/typedefs.lisp index 6809683d5c64492c22194dd9e2b6601b79dddfef..49df2042234920ecc270f44e9218b20ea2261476 100644 --- a/code/typedefs.lisp +++ b/code/typedefs.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.12 2001/03/04 20:12:44 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/typedefs.lisp,v 1.13 2003/04/23 15:19:41 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -161,12 +161,12 @@ ;; that class. If the result is a two-type union, then return NIL. ;; VANILLA-UNION returns whichever argument is a supertype of the other, or ;; NIL. - (simple-union #'vanilla-union :type function) + (simple-union #'hierarchical-union2 :type function) (complex-union nil :type (or function null)) ;; ;; The default intersection methods assume that if one type is a subtype of ;; the other, then that type is the intersection. - (simple-intersection #'vanilla-intersection :type function) + (simple-intersection #'hierarchical-intersection2 :type function) (complex-intersection nil :type (or function null)) ;; (simple-= #'must-supply-this :type function) @@ -389,6 +389,18 @@ ((csubtypep type2 type1) type1) (t nil))) +(defun hierarchical-intersection2 (type1 type2) + (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) + (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) + (cond (subtypep1 type1) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) + +(defun hierarchical-union2 (type1 type2) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t nil))) ;;; TYPE-CACHE-HASH -- Interface ;;;