From e14ba2a55c36d96f378800efec651f5d626b9332 Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Mon, 21 Aug 2006 16:39:54 +0000 Subject: [PATCH] Some very basic support for signed zeroes for DOUBLE-DOUBLE-FLOAT. We can now read and print -0w0. code/float.lisp: o Adjust float-sign so that we get the correct sign when double-double-floats are used. o Adjust FLOAT-RATIO to call %MAKE-DOUBLE-DOUBLE-FLOAT so that we preserve the sign of the number. This is safe because the components are known to be properly scaled. compiler/float-tran.lisp: o Use %MAKE-DOUBLE-DOUBLE-FLOAT in %DOUBLE-DOUBLE-FLOAT to preserve the sign of the original float. This is safe because the components are known to be properly scaled. o Add a FLOAT-SIGN deftransform to handle DOUBLE-DOUBLE-FLOAT. --- code/float.lisp | 29 +++++++++++++++++++++++++++-- compiler/float-tran.lisp | 19 +++++++++++++++---- 2 files changed, 42 insertions(+), 6 deletions(-) diff --git a/code/float.lisp b/code/float.lisp index bcc5bb6a9..6eed2c3f9 100644 --- a/code/float.lisp +++ b/code/float.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.32 2006/06/30 18:41:22 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/float.lisp,v 1.33 2006/08/21 16:39:53 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -349,6 +349,7 @@ integer-decode-long-denorm))))) +#+nil (defun float-sign (float1 &optional (float2 (float 1 float1))) "Returns a floating-point number that has the same sign as float1 and, if float2 is given, has the same absolute value @@ -365,6 +366,30 @@ (float 1 float1)) (abs float2))) +(defun float-sign (float1 &optional float2) + "Returns a floating-point number that has the same sign as + float1 and, if float2 is given, has the same absolute value + as float2." + (declare (float float1) + (type (or null float) float2)) + (let ((f1-sign (if (etypecase float1 + (single-float (minusp (single-float-bits float1))) + (double-float (minusp (double-float-high-bits float1))) + #+long-float + (long-float (minusp (long-float-exp-bits float1))) + #+double-double + (double-double-float (minusp (float-sign (double-double-hi float1))))) + (float -1 float1) + (float 1 float1)))) + ;; Multiplication of double-double-float's doesn't preserve the + ;; sign of signed-zeroes, so we split the case of float2 this way + ;; so we can get the right sign. + (if float2 + (if (minusp f1-sign) + (- (abs float2)) + (abs float2)) + f1-sign))) + (defun float-format-digits (format) (ecase format ((short-float single-float) vm:single-float-digits) @@ -992,7 +1017,7 @@ (format t " scale = ~A~%" (1+ scale)) ||# (if f1 - (make-double-double-float + (%make-double-double-float (scale-float f0 (1+ scale)) (scale-float f1 (+ 1 scale #.(- vm:double-float-digits)))) (scale-float f0 (1+ scale))))) diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 42472d1b1..f724e047b 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.107 2006/07/07 18:26:43 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.108 2006/08/21 16:39:54 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -62,11 +62,11 @@ (defun %double-double-float (n) (typecase n (fixnum - (make-double-double-float (float n 1d0) 0d0)) + (%make-double-double-float (float n 1d0) 0d0)) (single-float - (make-double-double-float (float n 1d0) 0d0)) + (%make-double-double-float (float n 1d0) 0d0)) (double-float - (make-double-double-float (float n 1d0) 0d0)) + (%make-double-double-float (float n 1d0) 0d0)) (double-double-float n) (bignum @@ -332,6 +332,17 @@ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp))) '(if (minusp (double-float-high-bits float)) -1d0 1d0))) +(deftransform float-sign ((float &optional float2) + (double-double-float &optional double-double-float) *) + (if float2 + (let ((temp (gensym))) + `(let ((,temp (abs float2))) + (if (minusp (float-sign (double-double-hi float))) + (- ,temp) + ,temp))) + '(if (minusp (float-sign (double-double-hi float))) -1w0 1w0))) + + ;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, SCALE-FLOAT: ;;; -- GitLab