From 041a2f861e6586741879d9777cd92d64dc29a61d Mon Sep 17 00:00:00 2001 From: pw <pw> Date: Thu, 22 Nov 2001 13:39:15 +0000 Subject: [PATCH] dtc's fix for (describe #c(1 1/2)). --- code/type.lisp | 45 ++++++++++++++++++++++++++------------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index 596481dd3..adbea1e3d 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) -- GitLab