From 314e342e904d219f9fd505f18c6d52ba09c594a4 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 6 Dec 1990 18:47:44 +0000 Subject: [PATCH] Fixed scale-float to signal underflow and inexact at the right times. Changed decode-float to call plain ERROR when passed an infinity or NaN, instead of using ASSERT. --- code/float.lisp | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/code/float.lisp b/code/float.lisp index e55cecfb8..20476280a 100644 --- a/code/float.lisp +++ b/code/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.5 1990/12/02 13:24:07 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.6 1990/12/06 18:47:44 ram Exp $ ;;; ;;; This file contains the definitions of float specific number support ;;; (other than irrational stuff, which is in irrat.) There is code in here @@ -283,8 +283,8 @@ (sign (if (minusp (float-sign x)) -1 1)) (biased (- exp vm:single-float-bias vm:single-float-digits))) (declare (fixnum biased)) - (assert (<= exp vm:single-float-normal-exponent-max) () - "Can't decode NAN or infinity: ~S." x) + (unless (<= exp vm:single-float-normal-exponent-max) + (error "Can't decode NAN or infinity: ~S." x)) (cond ((and (zerop exp) (zerop sig)) (values 0 biased sign)) ((< exp vm:single-float-normal-exponent-min) @@ -343,8 +343,8 @@ (sign (if (minusp (float-sign x)) -1 1)) (biased (- exp vm:double-float-bias vm:double-float-digits))) (declare (fixnum biased)) - (assert (<= exp vm:double-float-normal-exponent-max) () - "Can't decode NAN or infinity: ~S." x) + (unless (<= exp vm:double-float-normal-exponent-max) + (error "Can't decode NAN or infinity: ~S." x)) (cond ((and (zerop exp) (zerop sig) (zerop lo)) (values 0 biased sign)) ((< exp vm:double-float-normal-exponent-min) @@ -405,9 +405,10 @@ (let* ((bits (single-float-bits (abs x))) (exp (ldb vm:single-float-exponent-byte bits)) (sign (float-sign x)) - (biased (truly-the single-float-exponent (- exp vm:single-float-bias)))) - (assert (<= exp vm:single-float-normal-exponent-max) () - "Can't decode NAN or infinity: ~S." x) + (biased (truly-the single-float-exponent + (- exp vm:single-float-bias)))) + (unless (<= exp vm:single-float-normal-exponent-max) + (error "Can't decode NAN or infinity: ~S." x)) (cond ((zerop x) (values 0.0f0 biased sign)) ((< exp vm:single-float-normal-exponent-min) @@ -448,9 +449,10 @@ (lo (double-float-low-bits abs)) (exp (ldb vm:double-float-exponent-byte hi)) (sign (float-sign x)) - (biased (truly-the double-float-exponent (- exp vm:double-float-bias)))) - (assert (<= exp vm:double-float-normal-exponent-max) () - "Can't decode NAN or infinity: ~S." x) + (biased (truly-the double-float-exponent + (- exp vm:double-float-bias)))) + (unless (<= exp vm:double-float-normal-exponent-max) + (error "Can't decode NAN or infinity: ~S." x)) (cond ((zerop x) (values 0.0d0 biased sign)) ((< exp vm:double-float-normal-exponent-min) @@ -502,21 +504,18 @@ (etypecase x (single-float vm:single-float-normal-exponent-min) (double-float vm:double-float-normal-exponent-min))) - (when (and (not (float-denormalized-p x)) - (vm:current-float-trap :inexact)) + (when (vm:current-float-trap :inexact) (error 'floating-point-inexact :operation 'scale-float :operands (list x exp))) + (when (vm:current-float-trap :underflow) + (error 'floating-point-underflow :operation 'scale-float + :operands (list x exp))) (let ((shift (1- new-exp))) - (cond - ((< shift (- (1- digits))) - (when (vm:current-float-trap :underflow) - (error 'floating-point-underflow :operation 'scale-float - :operands (list x exp))) - (float-sign x 0.0)) - (t - (etypecase x - (single-float (single-from-bits sign 0 (ash sig shift))) - (double-float (double-from-bits sign 0 (ash sig shift)))))))) + (if (< shift (- (1- digits))) + (float-sign x 0.0) + (etypecase x + (single-float (single-from-bits sign 0 (ash sig shift))) + (double-float (double-from-bits sign 0 (ash sig shift))))))) (t (etypecase x (single-float (single-from-bits sign new-exp sig)) -- GitLab