- (let* ((bits (ash bits -1))
- (len (integer-length bits)))
- (cond ((> len digits)
- (aver (= len (the fixnum (1+ digits))))
- (scale-float (floatit (ash bits -1)) (1+ scale)))
- (t
- (scale-float (floatit bits) scale)))))
- (floatit (bits)
- (let ((sign (if plusp 0 1)))
- (case format
- (single-float
- (single-from-bits sign sb!vm:single-float-bias bits))
- (double-float
- (double-from-bits sign sb!vm:double-float-bias bits))
- #!+long-float
- (long-float
- (long-from-bits sign sb!vm:long-float-bias bits))))))
- (loop
- (multiple-value-bind (fraction-and-guard rem)
- (truncate shifted-num den)
- (let ((extra (- (integer-length fraction-and-guard) digits)))
- (declare (fixnum extra))
- (cond ((/= extra 1)
- (aver (> extra 1)))
- ((oddp fraction-and-guard)
- (return
- (if (zerop rem)
- (float-and-scale
- (if (zerop (logand fraction-and-guard 2))
- fraction-and-guard
- (1+ fraction-and-guard)))
- (float-and-scale (1+ fraction-and-guard)))))
- (t
- (return (float-and-scale fraction-and-guard)))))
- (setq shifted-num (ash shifted-num -1))
- (incf scale)))))))
-
-#|
-These might be useful if we ever have a machine without float/integer
-conversion hardware. For now, we'll use special ops that
-uninterruptibly frob the rounding modes & do ieee round-to-integer.
-
-;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE
-;;; and the result is known to be a fixnum. We can avoid some generic
-;;; arithmetic in this case.
-(defun %unary-truncate-single-float/fixnum (x)
- (declare (single-float x) (values fixnum))
- (locally (declare (optimize (speed 3) (safety 0)))
- (let* ((bits (single-float-bits x))
- (exp (ldb sb!vm:single-float-exponent-byte bits))
- (frac (logior (ldb sb!vm:single-float-significand-byte bits)
- sb!vm:single-float-hidden-bit))
- (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias)))
- (when (> exp sb!vm:single-float-normal-exponent-max)
- (error 'floating-point-invalid-operation :operator 'truncate
- :operands (list x)))
- (if (<= shift (- sb!vm:single-float-digits))
- 0
- (let ((res (ash frac shift)))
- (declare (type (unsigned-byte 31) res))
- (if (minusp bits)
- (- res)
- res))))))
-
-;;; Double-float version of this operation (see above single op).
-(defun %unary-truncate-double-float/fixnum (x)
- (declare (double-float x) (values fixnum))
- (locally (declare (optimize (speed 3) (safety 0)))
- (let* ((hi-bits (double-float-high-bits x))
- (exp (ldb sb!vm:double-float-exponent-byte hi-bits))
- (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits)
- sb!vm:double-float-hidden-bit))
- (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits)
- sb!vm:double-float-bias)))
- (when (> exp sb!vm:double-float-normal-exponent-max)
- (error 'floating-point-invalid-operation :operator 'truncate
- :operands (list x)))
- (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits))
- 0
- (let* ((res-hi (ash frac shift))
- (res (if (plusp shift)
- (logior res-hi
- (the fixnum
- (ash (double-float-low-bits x)
- (- shift sb!vm:n-word-bits))))
- res-hi)))
- (declare (type (unsigned-byte 31) res-hi res))
- (if (minusp hi-bits)
- (- res)
- res))))))
-|#
+ (let* ((bits (ash bits -1))
+ (len (integer-length bits)))
+ (cond ((> len digits)
+ (aver (= len (the fixnum (1+ digits))))
+ (scale-float (floatit (ash bits -1)) (1+ scale)))
+ (t
+ (scale-float (floatit bits) scale)))))
+ (floatit (bits)
+ (let ((sign (if plusp 0 1)))
+ (case format
+ (single-float
+ (single-from-bits sign sb!vm:single-float-bias bits))
+ (double-float
+ (double-from-bits sign sb!vm:double-float-bias bits))
+ #!+long-float
+ (long-float
+ (long-from-bits sign sb!vm:long-float-bias bits))))))
+ (loop
+ (multiple-value-bind (fraction-and-guard rem)
+ (truncate shifted-num den)
+ (let ((extra (- (integer-length fraction-and-guard) digits)))
+ (declare (fixnum extra))
+ (cond ((/= extra 1)
+ (aver (> extra 1)))
+ ((oddp fraction-and-guard)
+ (return
+ (if (zerop rem)
+ (float-and-scale
+ (if (zerop (logand fraction-and-guard 2))
+ fraction-and-guard
+ (1+ fraction-and-guard)))
+ (float-and-scale (1+ fraction-and-guard)))))
+ (t
+ (return (float-and-scale fraction-and-guard)))))
+ (setq shifted-num (ash shifted-num -1))
+ (incf scale)))))))
+
+;;; These might be useful if we ever have a machine without float/integer
+;;; conversion hardware. For now, we'll use special ops that
+;;; uninterruptibly frob the rounding modes & do ieee round-to-integer.
+#+nil
+(progn
+ ;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE
+ ;; and the result is known to be a fixnum. We can avoid some generic
+ ;; arithmetic in this case.
+ (defun %unary-truncate-single-float/fixnum (x)
+ (declare (single-float x) (values fixnum))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (let* ((bits (single-float-bits x))
+ (exp (ldb sb!vm:single-float-exponent-byte bits))
+ (frac (logior (ldb sb!vm:single-float-significand-byte bits)
+ sb!vm:single-float-hidden-bit))
+ (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias)))
+ (when (> exp sb!vm:single-float-normal-exponent-max)
+ (error 'floating-point-invalid-operation :operator 'truncate
+ :operands (list x)))
+ (if (<= shift (- sb!vm:single-float-digits))
+ 0
+ (let ((res (ash frac shift)))
+ (declare (type (unsigned-byte 31) res))
+ (if (minusp bits)
+ (- res)
+ res))))))
+ ;; Double-float version of this operation (see above single op).
+ (defun %unary-truncate-double-float/fixnum (x)
+ (declare (double-float x) (values fixnum))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (let* ((hi-bits (double-float-high-bits x))
+ (exp (ldb sb!vm:double-float-exponent-byte hi-bits))
+ (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits)
+ sb!vm:double-float-hidden-bit))
+ (shift (- exp (- sb!vm:double-float-digits sb!vm:n-word-bits)
+ sb!vm:double-float-bias)))
+ (when (> exp sb!vm:double-float-normal-exponent-max)
+ (error 'floating-point-invalid-operation :operator 'truncate
+ :operands (list x)))
+ (if (<= shift (- sb!vm:n-word-bits sb!vm:double-float-digits))
+ 0
+ (let* ((res-hi (ash frac shift))
+ (res (if (plusp shift)
+ (logior res-hi
+ (the fixnum
+ (ash (double-float-low-bits x)
+ (- shift sb!vm:n-word-bits))))
+ res-hi)))
+ (declare (type (unsigned-byte 31) res-hi res))
+ (if (minusp hi-bits)
+ (- res)
+ res)))))))