+ (labels ((not-numeric ()
+ (error "The component type for COMPLEX is not numeric: ~S"
+ typespec))
+ (not-real ()
+ (error "The component type for COMPLEX is not real: ~S"
+ typespec))
+ (complex1 (component-type)
+ (unless (numeric-type-p component-type)
+ (not-numeric))
+ (when (eq (numeric-type-complexp component-type) :complex)
+ (not-real))
+ (modified-numeric-type component-type :complexp :complex))
+ (complex-union (component)
+ (unless (numberp component)
+ (not-numeric))
+ ;; KLUDGE: This TYPECASE more or less does
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF COMPONENT)),
+ ;; (plus a small hack to treat (EQL COMPONENT 0) specially)
+ ;; but uses logic cut and pasted from the DEFUN of
+ ;; UPGRADED-COMPLEX-PART-TYPE. That's fragile, because
+ ;; changing the definition of UPGRADED-COMPLEX-PART-TYPE
+ ;; would tend to break the code here. Unfortunately,
+ ;; though, reusing UPGRADED-COMPLEX-PART-TYPE here
+ ;; would cause another kind of fragility, because
+ ;; ANSI's definition of TYPE-OF is so weak that e.g.
+ ;; (UPGRADED-COMPLEX-PART-TYPE (TYPE-OF 1/2)) could
+ ;; end up being (UPGRADED-COMPLEX-PART-TYPE 'REAL)
+ ;; instead of (UPGRADED-COMPLEX-PART-TYPE 'RATIONAL).
+ ;; So using TYPE-OF would mean that ANSI-conforming
+ ;; maintenance changes in TYPE-OF could break the code here.
+ ;; It's not clear how best to fix this. -- WHN 2002-01-21,
+ ;; trying to summarize CSR's concerns in his patch
+ (typecase component
+ (complex (error "The component type for COMPLEX (EQL X) ~
+ is complex: ~S"
+ component))
+ ((eql 0) (specifier-type nil)) ; as required by ANSI
+ (single-float (specifier-type '(complex single-float)))
+ (double-float (specifier-type '(complex double-float)))
+ #!+long-float
+ (long-float (specifier-type '(complex long-float)))
+ (rational (specifier-type '(complex rational)))
+ (t (specifier-type '(complex real))))))
+ (let ((ctype (specifier-type typespec)))
+ (typecase ctype
+ (numeric-type (complex1 ctype))
+ (union-type (apply #'type-union
+ ;; FIXME: This code could suffer from
+ ;; (admittedly very obscure) cases of
+ ;; bug 145 e.g. when TYPE is
+ ;; (OR (AND INTEGER (SATISFIES ODDP))
+ ;; (AND FLOAT (SATISFIES FOO))
+ ;; and not even report the problem very well.
+ (mapcar #'complex1
+ (union-type-types ctype))))
+ ;; MEMBER-TYPE is almost the same as UNION-TYPE, but
+ ;; there's a gotcha: (COMPLEX (EQL 0)) is, according to
+ ;; ANSI, equal to type NIL, the empty set.
+ (member-type (apply #'type-union
+ (mapcar #'complex-union
+ (member-type-members ctype))))
+ (t
+ (multiple-value-bind (subtypep certainly)
+ (csubtypep ctype (specifier-type 'real))
+ (if (and (not subtypep) certainly)
+ (not-real)
+ ;; ANSI just says that TYPESPEC is any subtype of
+ ;; type REAL, not necessarily a NUMERIC-TYPE. In
+ ;; particular, at this point TYPESPEC could legally be
+ ;; an intersection type like (AND REAL (SATISFIES ODDP)),
+ ;; in which case we fall through the logic above and
+ ;; end up here, stumped.
+ (bug "~@<(known bug #145): The type ~S is too hairy to be
+ used for a COMPLEX component.~:@>"
+ typespec)))))))))