mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
Fix scale-float rounding for subnormals
Shifting right discards some set bits. Rely on the FPU multiplication instead.
This commit is contained in:
Stas Boukarev
parent
e251cf9c08
commit
673a3d8ab8
9
COPYING
9
COPYING
|
|
@ -112,3 +112,12 @@ Gerd Moellmann are retained.
|
|||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
|
||||
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
|
||||
;;; DAMAGE.
|
||||
|
||||
;;; ====================================================
|
||||
;;; Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
|
||||
;;;
|
||||
;;; Developed at SunPro, a Sun Microsystems, Inc. business.
|
||||
;;; Permission to use, copy, modify, and distribute this
|
||||
;;; software is freely granted, provided that this notice
|
||||
;;; is preserved.
|
||||
;;; ====================================================
|
||||
|
|
|
|||
|
|
@ -15,7 +15,8 @@
|
|||
(let ((initial-exponent (1- (ash 1 (1- n-exponent-bits))))
|
||||
(max-exponent (1- (ash 1 n-exponent-bits))))
|
||||
`(defun ,name (rational)
|
||||
(declare (type cl:rational rational))
|
||||
(declare (type cl:rational rational)
|
||||
(notinline ,bits-fun))
|
||||
(let ((sign (if (cl:= (cl:signum rational) -1) 1 0))
|
||||
(magnitude (cl:abs rational)))
|
||||
(when (cl:= magnitude 0)
|
||||
|
|
|
|||
|
|
@ -1521,5 +1521,77 @@ NOTE: This interface is experimental and subject to change."
|
|||
(<= (- exponent)
|
||||
;; count-trailing-zeros, but wider for 32-bit platforms
|
||||
(integer-length (ldb (byte 64 0) (lognor significand (- significand)))))))))
|
||||
|
||||
(defmacro make-defs (vars &body body)
|
||||
(labels ((subst-if-with (test tree)
|
||||
(labels ((s (subtree)
|
||||
(multiple-value-bind (new replace)
|
||||
(funcall test subtree)
|
||||
(cond (replace new)
|
||||
((comma-p subtree)
|
||||
(let ((new (s (comma-expr subtree))))
|
||||
(if (eq subtree new)
|
||||
subtree
|
||||
(unquote new (comma-kind subtree)))))
|
||||
((atom subtree) subtree)
|
||||
(t (let ((car (s (car subtree)))
|
||||
(cdr (s (cdr subtree))))
|
||||
(if (and (eq car (car subtree))
|
||||
(eq cdr (cdr subtree)))
|
||||
subtree
|
||||
(cond ((and (typep car '(cons symbol))
|
||||
(string= (car car) "$WHEN"))
|
||||
(if (eval (second car))
|
||||
(append (cddr car) cdr)
|
||||
cdr))
|
||||
((and (typep car '(cons symbol))
|
||||
(string= (car car) "$UNLESS"))
|
||||
(if (eval (second car))
|
||||
cdr
|
||||
(append (cddr car) cdr)))
|
||||
((and (typep car '(cons symbol))
|
||||
(string= (car car) "$IF"))
|
||||
(cons
|
||||
(if (eval (second car))
|
||||
(third car)
|
||||
(fourth car))
|
||||
cdr))
|
||||
(t
|
||||
(cons car cdr))))))))))
|
||||
(s tree)))
|
||||
(test (pattern with)
|
||||
(lambda (x)
|
||||
(when (symbolp x)
|
||||
(let* ((str (string x))
|
||||
(start (search pattern str)))
|
||||
(when start
|
||||
(values
|
||||
(if (equal str pattern)
|
||||
with
|
||||
(let ((package (position #\: str)))
|
||||
(if package
|
||||
(package-symbolicate (subseq str 0 package)
|
||||
(subseq str (1+ package) start)
|
||||
with
|
||||
(subseq str (+ start (length pattern))))
|
||||
(symbolicate (subseq str 0 start)
|
||||
with
|
||||
(subseq str (+ start (length pattern)))))))
|
||||
t))))))
|
||||
(gen (vars body)
|
||||
(if vars
|
||||
(loop for with in (cdar vars)
|
||||
append
|
||||
(gen (cdr vars)
|
||||
(let ((body body)
|
||||
(patterns (sort (loop for v in (ensure-list (caar vars))
|
||||
for w in (ensure-list with)
|
||||
collect (cons v w))
|
||||
#'> :key (lambda (x) (length (string (car x)))))))
|
||||
(loop for (v . w) in patterns
|
||||
do (setf body (subst-if-with (test (string v) w) body)))
|
||||
body)))
|
||||
body)))
|
||||
`(progn ,@(gen vars body))))
|
||||
|
||||
(defvar *top-level-form-p* nil)
|
||||
|
|
|
|||
|
|
@ -573,65 +573,131 @@
|
|||
|
||||
(declaim (maybe-inline scale-single-float scale-double-float))
|
||||
|
||||
;;; Scale a single or double float, calling the correct over/underflow
|
||||
;;; functions.
|
||||
(defun scale-single-float (x exp)
|
||||
(declare (single-float x) (integer exp))
|
||||
(etypecase exp
|
||||
(fixnum
|
||||
(let* ((bits (single-float-bits x))
|
||||
(old-exp (ldb sb-vm:single-float-exponent-byte bits))
|
||||
(new-exp (+ old-exp exp)))
|
||||
(cond
|
||||
((zerop x) x)
|
||||
((or (< old-exp sb-vm:single-float-normal-exponent-min)
|
||||
(< new-exp sb-vm:single-float-normal-exponent-min))
|
||||
(scale-single-float-maybe-underflow x exp))
|
||||
((or (> old-exp sb-vm:single-float-normal-exponent-max)
|
||||
(> new-exp sb-vm:single-float-normal-exponent-max))
|
||||
(scale-single-float-maybe-overflow x exp))
|
||||
(t
|
||||
(make-single-float (dpb new-exp
|
||||
sb-vm:single-float-exponent-byte
|
||||
bits))))))
|
||||
(unsigned-byte (scale-single-float-maybe-overflow x exp))
|
||||
((integer * 0) (scale-single-float-maybe-underflow x exp))))
|
||||
|
||||
(defun scale-double-float (x exp)
|
||||
(etypecase exp
|
||||
(fixnum
|
||||
;; ====================================================
|
||||
;; Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved.
|
||||
;;
|
||||
;; Developed at SunPro, a Sun Microsystems, Inc. business.
|
||||
;; Permission to use, copy, modify, and distribute this
|
||||
;; software is freely granted, provided that this notice
|
||||
;; is preserved.
|
||||
;; ====================================================
|
||||
(make-defs ((($type $make $tiny $huge $two^ $two^- $size)
|
||||
(single-float make-single-float
|
||||
1f-30 1f30 3.355443200f7 2.9802322388f-8 31)
|
||||
#+64-bit
|
||||
(let* ((bits (double-float-bits x))
|
||||
(old-exp (ldb sb-vm:double-float-exponent-byte bits))
|
||||
(new-exp (+ old-exp exp)))
|
||||
(double-float %make-double-float
|
||||
1d-300 1d300 1.80143985094819840000d16 5.55111512312578270212d-17 63)))
|
||||
(defun scale-$type (float n)
|
||||
(declare ($type float)
|
||||
(integer n)
|
||||
(optimize speed))
|
||||
(block scale-$type
|
||||
(let* ((1+digits (1+ sb-vm\:$type-digits))
|
||||
(two^digits $two^)
|
||||
(two^-digits $two^-)
|
||||
(tiny $tiny)
|
||||
(huge $huge)
|
||||
(bits ($type-bits float))
|
||||
(exp (ldb sb-vm\:$type-exponent-byte bits)))
|
||||
|
||||
;; 0 or subnormal x
|
||||
(when (zerop exp)
|
||||
(when (zerop (ldb (byte $size 0) bits))
|
||||
;; +-0
|
||||
(return-from scale-$type float))
|
||||
|
||||
(setf float (sb-xc:* float two^digits)
|
||||
bits ($type-bits float)
|
||||
exp (- (ldb sb-vm\:$type-exponent-byte bits)
|
||||
1+digits)))
|
||||
|
||||
;; NaN or Inf
|
||||
(when (= exp (1+ sb-vm\:$type-normal-exponent-max))
|
||||
(return-from scale-$type (sb-xc:+ float float)))
|
||||
|
||||
(if (typep n 'fixnum)
|
||||
(cond
|
||||
((zerop x) x)
|
||||
((or (< old-exp sb-vm:double-float-normal-exponent-min)
|
||||
(< new-exp sb-vm:double-float-normal-exponent-min))
|
||||
(scale-double-float-maybe-underflow x exp))
|
||||
((or (> old-exp sb-vm:double-float-normal-exponent-max)
|
||||
(> new-exp sb-vm:double-float-normal-exponent-max))
|
||||
(scale-double-float-maybe-overflow x exp))
|
||||
((> n 5000)
|
||||
(return-from scale-$type (sb-xc:* huge (float-sign float huge))))
|
||||
((< n -5000)
|
||||
(return-from scale-$type (sb-xc:* tiny (float-sign float tiny)))))
|
||||
(if (plusp n)
|
||||
(return-from scale-$type (sb-xc:* huge (float-sign float huge)))
|
||||
(return-from scale-$type (sb-xc:* tiny (float-sign float tiny)))))
|
||||
(let ((exp-new (+ exp n)))
|
||||
(declare (type fixnum exp-new))
|
||||
(cond ((plusp exp-new)
|
||||
(cond
|
||||
;; Overflow
|
||||
((> exp-new sb-vm\:$type-normal-exponent-max)
|
||||
(sb-xc:* huge (float-sign float huge)))
|
||||
;; normal result
|
||||
(t
|
||||
(%make-double-float (dpb new-exp sb-vm:double-float-exponent-byte bits)))))
|
||||
($make
|
||||
(dpb exp-new sb-vm\:$type-exponent-byte bits)))))
|
||||
((<= exp-new (- 1+digits))
|
||||
;; Underflow
|
||||
(sb-xc:* tiny (float-sign float tiny)))
|
||||
(t
|
||||
;; subnormal result
|
||||
(sb-xc:* ($make
|
||||
(dpb (+ exp-new 1+digits)
|
||||
sb-vm\:$type-exponent-byte
|
||||
bits))
|
||||
two^-digits))))))))
|
||||
|
||||
#-64-bit
|
||||
(let* ((hi (double-float-high-bits x))
|
||||
(lo (double-float-low-bits x))
|
||||
(old-exp (ldb sb-vm:double-float-hi-exponent-byte hi))
|
||||
(new-exp (+ old-exp exp)))
|
||||
(defun scale-double-float (float n)
|
||||
(declare (double-float float)
|
||||
(integer n))
|
||||
(block scale-double-float
|
||||
(let* ((1+digits (1+ sb-vm:double-float-digits))
|
||||
(two^digits 1.8014398509481984d16)
|
||||
(two^-digits 5.551115123125783d-17)
|
||||
(tiny 1.0d-300)
|
||||
(huge 1.0d300)
|
||||
(lo-bits (double-float-low-bits float))
|
||||
(hi-bits (double-float-high-bits float))
|
||||
(exp (ldb sb-vm:double-float-hi-exponent-byte hi-bits)))
|
||||
(when (zerop exp)
|
||||
(when (zerop (logior (ldb (byte 31 0) hi-bits) lo-bits))
|
||||
(return-from scale-double-float float))
|
||||
(setf float (sb-xc:* float two^digits)
|
||||
lo-bits (double-float-low-bits float)
|
||||
hi-bits (double-float-high-bits float)
|
||||
exp (- (ldb sb-vm:double-float-hi-exponent-byte hi-bits)
|
||||
1+digits)))
|
||||
(when (= exp (1+ sb-vm:double-float-normal-exponent-max))
|
||||
(return-from scale-double-float (sb-xc:+ float float)))
|
||||
(if (typep n 'fixnum)
|
||||
(cond
|
||||
((zerop x) x)
|
||||
((or (< old-exp sb-vm:double-float-normal-exponent-min)
|
||||
(< new-exp sb-vm:double-float-normal-exponent-min))
|
||||
(scale-double-float-maybe-underflow x exp))
|
||||
((or (> old-exp sb-vm:double-float-normal-exponent-max)
|
||||
(> new-exp sb-vm:double-float-normal-exponent-max))
|
||||
(scale-double-float-maybe-overflow x exp))
|
||||
((> n 5000)
|
||||
(return-from scale-double-float (sb-xc:* huge (float-sign float huge))))
|
||||
((< n -5000)
|
||||
(return-from scale-double-float (sb-xc:* tiny (float-sign float tiny)))))
|
||||
(if (plusp n)
|
||||
(return-from scale-double-float (sb-xc:* huge (float-sign float huge)))
|
||||
(return-from scale-double-float
|
||||
(sb-xc:* tiny (float-sign float tiny)))))
|
||||
(let ((exp-new (+ exp n)))
|
||||
(declare (type fixnum exp-new))
|
||||
(cond
|
||||
((plusp exp-new)
|
||||
(cond
|
||||
((> exp-new sb-vm:double-float-normal-exponent-max)
|
||||
(sb-xc:* huge (float-sign float huge)))
|
||||
(t
|
||||
(make-double-float (dpb new-exp sb-vm:double-float-hi-exponent-byte hi)
|
||||
lo)))))
|
||||
(unsigned-byte (scale-double-float-maybe-overflow x exp))
|
||||
((integer * 0) (scale-double-float-maybe-underflow x exp))))
|
||||
(make-double-float
|
||||
(dpb exp-new sb-vm:double-float-hi-exponent-byte hi-bits)
|
||||
lo-bits))))
|
||||
((<= exp-new (- 1+digits)) (sb-xc:* tiny (float-sign float tiny)))
|
||||
(t
|
||||
(sb-xc:*
|
||||
(make-double-float
|
||||
(dpb (+ exp-new 1+digits) sb-vm:double-float-hi-exponent-byte
|
||||
hi-bits)
|
||||
lo-bits)
|
||||
two^-digits)))))))
|
||||
|
||||
;;; Dispatch to the correct type-specific scale-float function.
|
||||
(defun scale-float (f ex)
|
||||
|
|
|
|||
|
|
@ -15,93 +15,6 @@
|
|||
|
||||
(in-package "SB-KERNEL")
|
||||
|
||||
;;; Handle float scaling where the X is denormalized or the result is
|
||||
;;; denormalized or underflows to 0.
|
||||
(macrolet ((def (type)
|
||||
`(defun ,(symbolicate 'scale- type '-maybe-underflow) (x exp)
|
||||
(declare (inline ,(symbolicate 'integer-decode- type)))
|
||||
(cond ((float-infinity-p x)
|
||||
x)
|
||||
((float-nan-p x)
|
||||
(when (and (float-trapping-nan-p x)
|
||||
(sb-vm:current-float-trap :invalid))
|
||||
(error 'floating-point-invalid-operation :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
x)
|
||||
(t
|
||||
(multiple-value-bind (sig old-exp sign) (,(symbolicate 'integer-decode- type) x)
|
||||
(let* ((digits (float-digits x))
|
||||
;; Normalize the significand if it's denormal
|
||||
(shift (- digits (integer-length sig)))
|
||||
(sig (truly-the ,(symbolicate type '-significand)
|
||||
(ash sig shift)))
|
||||
(old-exp (- old-exp shift))
|
||||
(new-exp (+ exp old-exp digits
|
||||
,(case type
|
||||
(single-float 'sb-vm:single-float-bias)
|
||||
(double-float 'sb-vm:double-float-bias))))
|
||||
;; convert decoded values {-1,+1} into {1,0} respectively
|
||||
(sign (if (minusp sign) 1 0)))
|
||||
(cond
|
||||
((< new-exp
|
||||
,(case type
|
||||
(single-float 'sb-vm:single-float-normal-exponent-min)
|
||||
(double-float 'sb-vm:double-float-normal-exponent-min)))
|
||||
(when (sb-vm:current-float-trap :inexact)
|
||||
(error 'floating-point-inexact :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
(when (sb-vm:current-float-trap :underflow)
|
||||
(error 'floating-point-underflow :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
(let ((shift (1- new-exp)))
|
||||
(if (< shift (- (1- digits)))
|
||||
(float-sign x ,(case type
|
||||
(single-float 0f0)
|
||||
(double-float 0d0)))
|
||||
,(case type
|
||||
(single-float '(single-from-bits sign 0 (ash sig shift)))
|
||||
(double-float '(double-from-bits sign 0 (ash sig shift)))))))
|
||||
(t
|
||||
,(case type
|
||||
(single-float '(single-from-bits sign new-exp sig))
|
||||
(double-float '(double-from-bits sign new-exp sig))))))))))))
|
||||
(def single-float)
|
||||
(def double-float))
|
||||
|
||||
;;; Called when scaling a float overflows, or the original float was a
|
||||
;;; NaN or infinity. If overflow errors are trapped, then error,
|
||||
;;; otherwise return the appropriate infinity. If a NaN, signal or not
|
||||
;;; as appropriate.
|
||||
(macrolet ((def (type)
|
||||
`(defun ,(symbolicate 'scale- type '-maybe-overflow) (x exp)
|
||||
(cond
|
||||
((float-infinity-p x)
|
||||
;; Infinity is infinity, no matter how small...
|
||||
x)
|
||||
((float-nan-p x)
|
||||
(when (and (float-trapping-nan-p x)
|
||||
(sb-vm:current-float-trap :invalid))
|
||||
(error 'floating-point-invalid-operation :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
x)
|
||||
(t
|
||||
(when (sb-vm:current-float-trap :overflow)
|
||||
(error 'floating-point-overflow :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
(when (sb-vm:current-float-trap :inexact)
|
||||
(error 'floating-point-inexact :operation 'scale-float
|
||||
:operands (list x exp)))
|
||||
(* (float-sign x)
|
||||
,(ecase type
|
||||
(single-float
|
||||
;; SINGLE-FLOAT-POSITIVE-INFINITY
|
||||
`(single-from-bits 0 (1+ sb-vm:single-float-normal-exponent-max) 0))
|
||||
(double-float
|
||||
;; DOUBLE-FLOAT-POSITIVE-INFINITY
|
||||
`(double-from-bits 0 (1+ sb-vm:double-float-normal-exponent-max) 0)))))))))
|
||||
(def single-float)
|
||||
(def double-float))
|
||||
|
||||
;;; This algorithm for RATIONALIZE, due to Bruno Haible, is included
|
||||
;;; with permission.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -162,8 +162,8 @@
|
|||
("src/code/debug-var-io")
|
||||
|
||||
("src/code/number-dispatch" :c-headers)
|
||||
("src/code/float" :c-headers)
|
||||
("src/code/cross-float-reader" :c-headers :not-target)
|
||||
("src/code/float" :c-headers)
|
||||
("src/code/cross-float" :c-headers :not-target)
|
||||
|
||||
;; 32-bit implementation of GET-INTERNAL-REAL-TIME needs some thread slots
|
||||
|
|
|
|||
|
|
@ -1992,12 +1992,13 @@
|
|||
(fold-p (fun-info-fold-p info)))
|
||||
(when (or (not fold-p)
|
||||
(apply fold-p args))
|
||||
(multiple-value-bind (values win) (careful-call (or folder
|
||||
(multiple-value-bind (values win ignore) (careful-call (or folder
|
||||
fun-name)
|
||||
args)
|
||||
(cond ((not win)
|
||||
;; Ignore errors from dedicated folders, in lieu of adding fun-info-fold-p.
|
||||
(unless folder
|
||||
(unless (or folder
|
||||
ignore)
|
||||
(setf (combination-kind call) :error
|
||||
(combination-info call)
|
||||
(list #'compiler-style-warn "Lisp error during constant folding:~%~A" values))
|
||||
|
|
|
|||
|
|
@ -3268,9 +3268,18 @@ is :ANY, the function name is not checked."
|
|||
(defun careful-call (function args)
|
||||
(declare (type (or symbol function) function)
|
||||
(type list args))
|
||||
(handler-case (values (multiple-value-list (apply (cross function) args)) t)
|
||||
(handler-case (apply (cross function) args)
|
||||
((or floating-point-overflow floating-point-inexact floating-point-underflow)
|
||||
(c)
|
||||
(values c nil t))
|
||||
(error (condition)
|
||||
(values condition nil))))
|
||||
(values condition nil))
|
||||
(:no-error (&rest results)
|
||||
(let ((first (first results)))
|
||||
(if (and (floatp first)
|
||||
(float-infinity-p first))
|
||||
(values results nil t)
|
||||
(values results t))))))
|
||||
|
||||
;;; Variations of SPECIFIER-TYPE for parsing possibly wrong
|
||||
;;; specifiers.
|
||||
|
|
|
|||
|
|
@ -1022,65 +1022,3 @@ specify bindings for printer control variables.")
|
|||
(nreverse (mapcar #'car *compiler-print-variable-alist*))
|
||||
(nreverse (mapcar #'cdr *compiler-print-variable-alist*))
|
||||
,@forms)))
|
||||
|
||||
(defmacro make-defs (vars &body body)
|
||||
(labels ((subst-if-with (test tree)
|
||||
(labels ((s (subtree)
|
||||
(multiple-value-bind (new replace)
|
||||
(funcall test subtree)
|
||||
(cond (replace new)
|
||||
((comma-p subtree)
|
||||
(let ((new (s (comma-expr subtree))))
|
||||
(if (eq subtree new)
|
||||
subtree
|
||||
(unquote new (comma-kind subtree)))))
|
||||
((atom subtree) subtree)
|
||||
(t (let ((car (s (car subtree)))
|
||||
(cdr (s (cdr subtree))))
|
||||
(if (and (eq car (car subtree))
|
||||
(eq cdr (cdr subtree)))
|
||||
subtree
|
||||
(cond ((and (typep car '(cons symbol))
|
||||
(string= (car car) "$WHEN"))
|
||||
(if (eval (second car))
|
||||
(append (cddr car) cdr)
|
||||
cdr))
|
||||
((and (typep car '(cons symbol))
|
||||
(string= (car car) "$UNLESS"))
|
||||
(if (eval (second car))
|
||||
cdr
|
||||
(append (cddr car) cdr)))
|
||||
((and (typep car '(cons symbol))
|
||||
(string= (car car) "$IF"))
|
||||
(cons
|
||||
(if (eval (second car))
|
||||
(third car)
|
||||
(fourth car))
|
||||
cdr))
|
||||
(t
|
||||
(cons car cdr))))))))))
|
||||
(s tree)))
|
||||
(test (pattern with)
|
||||
(lambda (x)
|
||||
(when (symbolp x)
|
||||
(let* ((str (string x))
|
||||
(start (search pattern str)))
|
||||
(when start
|
||||
(if (equal str pattern)
|
||||
(values with t)
|
||||
(values (symbolicate (subseq str 0 start)
|
||||
with
|
||||
(subseq str (+ start (length pattern))))
|
||||
t)))))))
|
||||
(gen (vars body)
|
||||
(if vars
|
||||
(loop for with in (cdar vars)
|
||||
append
|
||||
(gen (cdr vars)
|
||||
(let ((body body))
|
||||
(loop for v in (ensure-list (caar vars))
|
||||
for w in (ensure-list with)
|
||||
do (setf body (subst-if-with (test (string v) w) body)))
|
||||
body)))
|
||||
body)))
|
||||
`(progn ,@(gen vars body))))
|
||||
|
|
|
|||
|
|
@ -6024,16 +6024,10 @@
|
|||
((5.0f-9) #C(-4.123312f37 -0.0))))
|
||||
|
||||
(with-test (:name :reducing-constants.2)
|
||||
(let* ((style-warning-p nil)
|
||||
(fun (checked-compile `(lambda () (* 1.0 2 (expt 2 127)))
|
||||
:allow-style-warnings t
|
||||
:condition-transform (lambda (x)
|
||||
(when (typep x 'style-warning)
|
||||
(setf style-warning-p t))
|
||||
x))))
|
||||
(let* ((fun (checked-compile `(lambda () (* 1.0 2 (expt 2 127))))))
|
||||
(handler-case (funcall fun)
|
||||
(floating-point-overflow () (assert style-warning-p))
|
||||
(:no-error (x) (assert (not style-warning-p)) (assert (eql x sb-ext:single-float-positive-infinity))))))
|
||||
(floating-point-overflow ())
|
||||
(:no-error (x) (assert (eql x sb-ext:single-float-positive-infinity))))))
|
||||
|
||||
(with-test (:name (logbitp :past fixnum))
|
||||
(checked-compile-and-assert ()
|
||||
|
|
|
|||
|
|
@ -852,3 +852,7 @@ fractional bits."
|
|||
(when (typep ratio 'ratio)
|
||||
(check-ratio-to-float ratio 1f0)
|
||||
(check-ratio-to-float ratio 1d0))))))
|
||||
|
||||
(with-test (:name :scale-float-rounding)
|
||||
(assert (= (integer-decode-float (scale-float (opaque-identity 0.7836354097202904d0) -1032))
|
||||
(opaque-identity 3446464979698))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue