diff --git a/code/type.lisp b/code/type.lisp index 596481dd35c4f1d1eb5ee4bada31b84cd039c1bb..adbea1e3dc8d2802177db97fade8f5be03bb11ac 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.38 2001/03/04 20:12:44 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.39 2001/11/22 13:39:15 pw Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2451,25 +2451,32 @@ (extract-function-type x))) (symbol (make-member-type :members (list x))) + (complex + (let ((real (realpart x)) + (imag (imagpart x))) + (make-numeric-type :class (etypecase real + (integer + (etypecase imag + (integer 'integer) + (rational 'rational))) + (rational 'rational) + (float 'float)) + :format (if (floatp real) + (float-format-name real) + nil) + :complexp :complex + :low (min real imag) + :high (max real imag)))) (number - (let* ((num (if (complexp x) (realpart x) x)) - (res (make-numeric-type - :class (etypecase num - (integer 'integer) - (rational 'rational) - (float 'float)) - :format (if (floatp num) - (float-format-name num) - nil)))) - (cond ((complexp x) - (setf (numeric-type-complexp res) :complex) - (let ((imag (imagpart x))) - (setf (numeric-type-low res) (min num imag)) - (setf (numeric-type-high res) (max num imag)))) - (t - (setf (numeric-type-low res) num) - (setf (numeric-type-high res) num))) - res)) + (make-numeric-type :class (etypecase x + (integer 'integer) + (rational 'rational) + (float 'float)) + :format (if (floatp x) + (float-format-name x) + nil) + :low x + :high x)) (array (let ((etype (specifier-type (array-element-type x)))) (make-array-type :dimensions (array-dimensions x)