From: Brian Mastenbrook Date: Fri, 12 Aug 2005 00:59:07 +0000 (+0000) Subject: 0.9.3.41: fix three MISC tests where type derivation attempted to X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=068edb68ca05bcb3c758150155b04cf8acc72ba1;p=sbcl.git 0.9.3.41: fix three MISC tests where type derivation attempted to coerce a large bignum to a float, and hopefully fix other potential similar problems in that area --- diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 6ec1446..abf2e8d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2025,7 +2025,18 @@ (if up-p (1+ cx) (1- cx)) (if up-p (ceiling cx) (floor cx)))) (float - (let ((res (if format (coerce cx format) (float cx)))) + (let ((res + (cond + ((and format (subtypep format 'double-float)) + (if (<= most-negative-double-float cx most-positive-double-float) + (coerce cx format) + (if (< x most-negative-double-float) + most-negative-double-float most-positive-double-float))) + (t + (if (<= most-negative-single-float cx most-positive-single-float) + (coerce cx format) + (if (< x most-negative-single-float) + most-negative-single-float most-positive-single-float)))))) (if (consp x) (list res) res))))) nil)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 2500787..5a1a358 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -333,10 +333,41 @@ (defmacro bound-binop (op x y) `(and ,x ,y (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero) - (set-bound (,op (type-bound-number ,x) - (type-bound-number ,y)) + (set-bound (safely-binop ,op (type-bound-number ,x) + (type-bound-number ,y)) (or (consp ,x) (consp ,y)))))) +(defun coerce-for-bound (val type) + (if (consp val) + (list (coerce-for-bound val)) + (cond + ((subtypep type 'double-float) + (if (<= most-negative-double-float val most-positive-double-float) + (coerce val type))) + ((or (subtypep type 'single-float) (subtypep type 'float)) + ;; coerce to float returns a single-float + (if (<= most-negative-single-float val most-positive-single-float) + (coerce val type))) + (t (coerce val type))))) + +(defun coerce-and-truncate-floats (val type) + (when val + (if (consp val) + (list (coerce-and-truncate-floats (car val) type)) + (cond + ((subtypep type 'double-float) + (if (<= most-negative-double-float val most-positive-double-float) + (coerce val type) + (if (< val most-negative-double-float) + most-negative-double-float most-positive-double-float))) + ((or (subtypep type 'single-float) (subtypep type 'float)) + ;; coerce to float returns a single-float + (if (<= most-negative-single-float val most-positive-single-float) + (coerce val type) + (if (< val most-negative-single-float) + most-negative-single-float most-positive-single-float))) + (t (coerce val type)))))) + ;;; Convert a numeric-type object to an interval object. (defun numeric-type->interval (x) (declare (type numeric-type x)) @@ -1229,8 +1260,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1262,8 +1293,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1295,8 +1326,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) @@ -1331,8 +1362,8 @@ (when (eq (numeric-type-class result-type) 'float) (setf result (interval-func #'(lambda (x) - (coerce x (or (numeric-type-format result-type) - 'float))) + (coerce-for-bound x (or (numeric-type-format result-type) + 'float))) result))) (make-numeric-type :class (numeric-type-class result-type) :format (numeric-type-format result-type) @@ -1475,8 +1506,8 @@ :class class :format format :complexp :real - :low (coerce-numeric-bound (interval-low abs-bnd) bound-type) - :high (coerce-numeric-bound + :low (coerce-and-truncate-floats (interval-low abs-bnd) bound-type) + :high (coerce-and-truncate-floats (interval-high abs-bnd) bound-type)))))) #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) @@ -1590,7 +1621,7 @@ (when (member rem-type '(float single-float double-float #!+long-float long-float)) (setf rem (interval-func #'(lambda (x) - (coerce x rem-type)) + (coerce-for-bound x rem-type)) rem))) (make-numeric-type :class class :format format @@ -1700,7 +1731,7 @@ ;; Make sure that the limits on the interval have ;; the right type. (setf rem (interval-func (lambda (x) - (coerce x result-type)) + (coerce-for-bound x result-type)) rem))) (make-numeric-type :class class :format format diff --git a/version.lisp-expr b/version.lisp-expr index b25c0e9..ec2c737 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.3.43" +"0.9.3.44"