X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=1dacf8845f9ecbeb4ac9101b4a5a0291a94131ab;hb=b36697e233ff1ef1cc3ad2e687581520656d4755;hp=e6f99319d7422b2098c551421a098ae1c6895d41;hpb=bf27595fb567015495b7131707cc85af361567fe;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index e6f9931..1dacf88 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -1736,6 +1736,21 @@ (apply #'type-union (mapcar (lambda (x) (complex1 (ctype-of x))) (member-type-members ctype)))) + ((and (typep ctype 'intersection-type) + ;; FIXME: This is very much a + ;; not-quite-worst-effort, but we are required to do + ;; something here because of our representation of + ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must + ;; allow users to ask about (COMPLEX RATIO). This + ;; will of course fail to work right on such types + ;; as (AND INTEGER (SATISFIES ZEROP))... + (let ((numbers (remove-if-not + #'numeric-type-p + (intersection-type-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-type-complexp (car numbers)) :real) + (complex1 (car numbers)))))) (t (multiple-value-bind (subtypep certainly) (csubtypep ctype (specifier-type 'real)) @@ -1743,11 +1758,12 @@ (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 + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), 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))))))))) @@ -1820,38 +1836,92 @@ ;;; FIXME: It's probably necessary to do something to fix the ;;; analogous problem with INTEGER and RATIONAL types. Perhaps ;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER). -(defun coerce-bound (bound type inner-coerce-bound-fun) +(defun coerce-bound (bound type upperp inner-coerce-bound-fun) (declare (type function inner-coerce-bound-fun)) - (cond ((eql bound '*) - bound) - ((consp bound) - (destructuring-bind (inner-bound) bound - (list (funcall inner-coerce-bound-fun inner-bound type)))) - (t - (funcall inner-coerce-bound-fun bound type)))) -(defun inner-coerce-real-bound (bound type) - (ecase type - (rational (rationalize bound)) - (float (if (floatp bound) - bound - ;; Coerce to the widest float format available, to - ;; avoid unnecessary loss of precision: - (coerce bound 'long-float))))) -(defun coerced-real-bound (bound type) - (coerce-bound bound type #'inner-coerce-real-bound)) -(defun coerced-float-bound (bound type) - (coerce-bound bound type #'coerce)) + (if (eql bound '*) + bound + (funcall inner-coerce-bound-fun bound type upperp))) +(defun inner-coerce-real-bound (bound type upperp) + #+sb-xc-host (declare (ignore upperp)) + (let #+sb-xc-host () + #-sb-xc-host + ((nl (load-time-value (symbol-value 'sb!xc:most-negative-long-float))) + (pl (load-time-value (symbol-value 'sb!xc:most-positive-long-float)))) + (let ((nbound (if (consp bound) (car bound) bound)) + (consp (consp bound))) + (ecase type + (rational + (if consp + (list (rational nbound)) + (rational nbound))) + (float + (cond + ((floatp nbound) bound) + (t + ;; Coerce to the widest float format available, to avoid + ;; unnecessary loss of precision, but don't coerce + ;; unrepresentable numbers, except on the host where we + ;; shouldn't be making these types (but KLUDGE: can't even + ;; assert portably that we're not). + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound nl) (return-from inner-coerce-real-bound nl))) + ((t) + (when (> nbound pl) (return-from inner-coerce-real-bound pl)))) + (let ((result (coerce nbound 'long-float))) + (if consp (list result) result))))))))) +(defun inner-coerce-float-bound (bound type upperp) + #+sb-xc-host (declare (ignore upperp)) + (let #+sb-xc-host () + #-sb-xc-host + ((nd (load-time-value (symbol-value 'sb!xc:most-negative-double-float))) + (pd (load-time-value (symbol-value 'sb!xc:most-positive-double-float))) + (ns (load-time-value (symbol-value 'sb!xc:most-negative-single-float))) + (ps (load-time-value + (symbol-value 'sb!xc:most-positive-single-float)))) + (let ((nbound (if (consp bound) (car bound) bound)) + (consp (consp bound))) + (ecase type + (single-float + (cond + ((typep nbound 'single-float) bound) + (t + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound ns) (return-from inner-coerce-float-bound ns))) + ((t) + (when (> nbound ps) (return-from inner-coerce-float-bound ps)))) + (let ((result (coerce nbound 'single-float))) + (if consp (list result) result))))) + (double-float + (cond + ((typep nbound 'double-float) bound) + (t + #-sb-xc-host + (ecase upperp + ((nil) + (when (< nbound nd) (return-from inner-coerce-float-bound nd))) + ((t) + (when (> nbound pd) (return-from inner-coerce-float-bound pd)))) + (let ((result (coerce nbound 'double-float))) + (if consp (list result) result))))))))) +(defun coerced-real-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-real-bound)) +(defun coerced-float-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-float-bound)) (!def-type-translator real (&optional (low '*) (high '*)) - (specifier-type `(or (float ,(coerced-real-bound low 'float) - ,(coerced-real-bound high 'float)) - (rational ,(coerced-real-bound low 'rational) - ,(coerced-real-bound high 'rational))))) + (specifier-type `(or (float ,(coerced-real-bound low 'float nil) + ,(coerced-real-bound high 'float t)) + (rational ,(coerced-real-bound low 'rational nil) + ,(coerced-real-bound high 'rational t))))) (!def-type-translator float (&optional (low '*) (high '*)) (specifier-type - `(or (single-float ,(coerced-float-bound low 'single-float) - ,(coerced-float-bound high 'single-float)) - (double-float ,(coerced-float-bound low 'double-float) - ,(coerced-float-bound high 'double-float)) + `(or (single-float ,(coerced-float-bound low 'single-float nil) + ,(coerced-float-bound high 'single-float t)) + (double-float ,(coerced-float-bound low 'double-float nil) + ,(coerced-float-bound high 'double-float t)) #!+long-float ,(error "stub: no long float support yet")))) (defmacro !define-float-format (f)