diff --git a/code/numbers.lisp b/code/numbers.lisp index b5c36bc38bf4dbf71779d985c5e6f2a5676251ef..ee7d354c3f904d4c6408acf80fb7f6359b4a88f5 100644 --- a/code/numbers.lisp +++ b/code/numbers.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.12 1990/09/18 20:29:09 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.13 1990/10/01 15:02:58 ram Exp $ ;;; ;;; This file contains the definitions of most number functions. ;;; @@ -1193,288 +1193,3 @@ (frob minusp "Returns T if number < 0, NIL otherwise.") (frob oddp "Returns T if number is odd, NIL otherwise.") (frob evenp "Returns T if number is even, NIL otherwise.")) - - -;;; Float operations: - - -(defun float (number &optional (other () otherp)) - "Converts a number of any type to floating point. - If OTHER is not provided, it returns a SINGLE-FLOAT if NUMBER - is not already a FLOAT. If OTHER is provided, the result is - the same float format as OTHER." - (if otherp - (number-dispatch ((number real) (other float)) - (((foreach rational single-float double-float) - (foreach single-float double-float)) - (coerce number '(dispatch-type other)))) - (if (floatp number) - number - (coerce number 'single-float)))) - - -(macrolet ((frob (name type) - `(defun ,name (x) - (number-dispatch ((x real)) - (((foreach single-float double-float fixnum)) - (coerce x ',type)) - ((bignum) - (bignum-to-float x ',type)) - ((ratio) - (let ((num (numerator x)) - (den (denominator x))) - (if (and (fixnump num) (fixnump den)) - (/ (coerce num ',type) (coerce den ',type)) - (float-bignum-ratio x ',type)))))))) - (frob %single-float single-float) - (frob %double-float double-float)) - - -(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 - as float2." - (declare (float float1 float2)) - (float-sign float1 float2)) - -(defun float-format-digits (format) - (ecase format - ((short-float single-float) single-float-digits) - ((double-float long-float) double-float-digits))) - -(proclaim '(inline float-digits float-precision float-radix)) - -(defun float-digits (f) - "Returns a non-negative number of radix-b digits used in the - representation of it's argument. See Common Lisp: The Language - by Guy Steele for more details." - (number-dispatch ((f float)) - ((single-float) single-float-digits) - ((double-float) double-float-digits))) - -(defun float-precision (f) - "Returns a non-negative number of significant radix-b digits - in it's argument." - (declare (float f)) - (if (zerop f) - 0 - (float-digits f))) - -(defun float-radix (f) - "Returns (as an integer) the radix b of its floating-point - argument." - (declare (ignore f)) - 2) - - -(proclaim '(maybe-inline integer-decode-single-float - integer-decode-double-float)) - -(defun integer-decode-single-float (x) - (declare (single-float x)) - (let ((bits (single-float-bits (abs x)))) - (values (if (zerop x) - 0 - (logior (ldb single-float-significand-byte bits) - single-float-hidden-bit)) - (truly-the single-float-exponent - (- (ldb single-float-exponent-byte bits) - single-float-bias - (float-digits x))) - (if (minusp (float-sign x)) -1 1)))) - -(defun integer-decode-double-float (x) - (declare (double-float x)) - (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs))) - (values (if (zerop x) - 0 - (logior (ash (logior (ldb double-float-significand-byte hi) - double-float-hidden-bit) - 32) - lo)) - (truly-the double-float-exponent - (- (ldb double-float-exponent-byte hi) - double-float-bias - (float-digits x))) - (if (minusp (float-sign x)) -1 1)))) - - -(defun integer-decode-float (x) - "Returns three values: - 1) an integer-scaled version of the significand. - 2) an exponent to which b must be raised to produce - the appropriate power for division. - 3) -1 or 1 (i.e. the sign of the argument.)" - (number-dispatch ((x float)) - ((single-float) - (integer-decode-single-float x)) - ((double-float) - (integer-decode-double-float x)))) - - -(proclaim '(maybe-inline decode-single-float decode-double-float)) - -(defun decode-single-float (x) - (declare (single-float x)) - (let ((bits (single-float-bits (abs x)))) - (values (if (zerop x) - 0f0 - (make-single-float - (dpb single-float-bias single-float-exponent-byte bits))) - (truly-the single-float-exponent - (- (ldb single-float-exponent-byte bits) - single-float-bias)) - (float-sign x)))) - -(defun decode-double-float (x) - (declare (double-float x)) - (let* ((abs (abs x)) - (hi (double-float-high-bits abs)) - (lo (double-float-low-bits abs))) - (values (if (zerop x) - 0d0 - (make-double-float - (dpb double-float-bias double-float-exponent-byte hi) - lo)) - (truly-the double-float-exponent - (- (ldb double-float-exponent-byte hi) - double-float-bias)) - (float-sign x)))) - - -(defun decode-float (f) - "Returns three values: - 1) a floating-point number representing the - significand. - 2) an integer representing the exponent. - 3) -1.0 or 1.0 (i.e. the sign of the argument.)" - (number-dispatch ((f float)) - ((single-float) - (decode-single-float f)) - ((double-float) - (decode-double-float f)))) - - -(proclaim '(maybe-inline scale-single-float scale-double-float)) - -(defun scale-single-float (x exp) - (declare (single-float x) (fixnum exp)) - (if (zerop x) - x - (let* ((bits (single-float-bits x)) - (new-exp (+ (ldb single-float-exponent-byte bits) - exp))) - (unless (<= single-float-normal-exponent-min - new-exp - single-float-normal-exponent-max) - (error "Floating point over/underflow scaling ~S by ~S." x exp)) - - (make-single-float (dpb new-exp single-float-exponent-byte bits))))) - -(defun scale-double-float (x exp) - (declare (double-float x) (fixnum exp)) - (if (zerop x) - x - (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (let ((new-exp (+ (ldb double-float-exponent-byte hi) - exp))) - (unless (<= double-float-normal-exponent-min - new-exp - double-float-normal-exponent-max) - (error "Floating point over/underflow scaling ~S by ~S." x exp)) - - (make-double-float - (dpb new-exp double-float-exponent-byte hi) - lo))))) - -(defun scale-float (f ex) - "Returns the value (* f (expt (float b f) e))" - (number-dispatch ((f float)) - ((single-float) - (scale-single-float f ex)) - ((double-float) - (scale-double-float f ex)))) - - -;;; %UNARY-TRUNCATE -- Interface -;;; -;;; This function is called when we are doing a truncate without any funky -;;; divisor, i.e. converting a float or ratio to an integer. Note that we do -;;; *not* return the second value of truncate, so it must be computed by the -;;; caller if needed. -;;; -(defun %unary-truncate (number) - (number-dispatch ((number real)) - ((integer) number) - ((ratio) (truncate (numerator number) (denominator number))) - (((foreach single-float double-float)) - (if (<= (float most-negative-fixnum number) - number - (float most-positive-fixnum number)) - (truly-the fixnum (%unary-truncate number)) - (multiple-value-bind (bits exp) - (integer-decode-float number) - (let ((res (ash bits exp))) - (if (minusp number) - (- res) - res))))))) - - -(defun rational (x) - "Rational produces a rational number for any numeric argument. - It assumes that floating-point is completely accurate." - (number-dispatch ((x real)) - (((foreach single-float double-float)) - (multiple-value-bind (bits exp) - (integer-decode-float x) - (if (eql bits 0) - 0 - (let* ((int (if (minusp x) (- bits) bits)) - (digits (float-digits x)) - (ex (+ exp digits))) - (if (minusp ex) - (integer-/-integer int (ash 1 (+ digits (- ex)))) - (integer-/-integer (ash int ex) (ash 1 digits))))))) - ((rational) x))) - - -(defun rationalize (x) - "Converts any REAL to a RATIONAL. Floats are converted to a simple rational - representation exploiting the assumption that floats are only accurate to - their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: - (= x (float (rationalize x) x))" - (number-dispatch ((x real)) - (((foreach single-float double-float)) - ;; Thanks to Kim Fateman, who stole this function rationalize-float - ;; from macsyma's rational. Macsyma'a rationalize was written - ;; by the legendary Gosper (rwg). Gosper is now working for Symbolics. - ;; Guy Steele said about Gosper, "He has been called the - ;; only living 17th century mathematician and is also the best - ;; pdp-10 hacker I know." So, if you can understand or debug this - ;; code you win big. - (cond ((minusp x) (- (rationalize (- x)))) - ((zerop x) 0) - (t - (let ((eps (if (typep x 'single-float) - single-float-epsilon - double-float-epsilon)) - (y ()) - (a ())) - (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x))))) - (num (setq a (truncate x)) - (+ (* (setq a (truncate y)) num) onum)) - (den 1 (+ (* a den) oden)) - (onum 1 num) - (oden 0 den)) - ((and (not (zerop den)) - (not (> (abs (/ (- x (/ (float num x) - (float den x))) - x)) - eps))) - (integer-/-integer num den)) - (declare ((dispatch-type x) xx))))))) - ((rational) x))) -