From d54fedff3be9116fb53764e9070c94e821707e93 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Mon, 12 Aug 2002 21:13:54 +0000 Subject: [PATCH] Try to handle more component type specifiers for type COMPLEX. Still needs work, but should handle most common cases. --- code/type.lisp | 49 +++++++++++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 12 deletions(-) diff --git a/code/type.lisp b/code/type.lisp index 21a388174..9861f4e6d 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.40 2002/02/23 01:48:57 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.41 2002/08/12 21:13:54 toy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1414,17 +1414,42 @@ (def-type-translator complex (&optional spec) - (if (eq spec '*) - (make-numeric-type :complexp :complex) - (let ((type (specifier-type spec))) - (unless (numeric-type-p type) - (error "Component type for Complex is not numeric: ~S." spec)) - (when (eq (numeric-type-complexp type) :complex) - (error "Component type for Complex is complex: ~S." spec)) - - (let ((res (copy-numeric-type type))) - (setf (numeric-type-complexp res) :complex) - res)))) + (cond + ((eq spec '*) + (make-numeric-type :complexp :complex)) + (t + (flet ((complex-type-error (type) + (error "Component type for Complex is not real: ~S." spec))) + (let* ((type (specifier-type spec)) + (res (copy-numeric-type + (cond ((numeric-type-p type) + ;; For simple numeric types, try to preserve + ;; as much info as possible. + (when (eq (numeric-type-complexp type) :complex) + (complex-type-error spec)) + type) + ((csubtypep type (specifier-type 'rational)) + ;; This case also handles things like (eql + ;; 1), etc. + (specifier-type 'rational)) + ((csubtypep type (specifier-type 'single-float)) + (specifier-type 'single-float)) + ((csubtypep type (specifier-type 'double-float)) + (specifier-type 'double-float)) + ((csubtypep type (specifier-type 'float)) + (specifier-type 'float)) + ((csubtypep type (specifier-type 'real)) + (specifier-type 'real)) + ((kernel::hairy-type-p type) + ;; Do we really want to produce an error here? + (cerror "Assume type is a subtype of REAL anyway." + "Cannot determine if ~S is a subtype of REAL" + spec) + (specifier-type 'real)) + (t + (complex-type-error spec)))))) + (setf (numeric-type-complexp res) :complex) + res))))) ;;; Check-Bound -- Internal -- GitLab