- ;; 0 - not an integer
- ;; 1 - an odd int
- ;; 2 - an even int
- (isint (ihi lo)
- (declare (type (unsigned-byte 31) ihi)
- (type (unsigned-byte 32) lo)
- (optimize (speed 3) (safety 0)))
- (let ((isint 0))
- (declare (type fixnum isint))
- (cond ((>= ihi #x43400000) ; exponent >= 53
- (setq isint 2))
- ((>= ihi #x3ff00000)
- (let ((k (- (ash ihi -20) #x3ff))) ; exponent
- (declare (type (mod 53) k))
- (cond ((> k 20)
- (let* ((shift (- 52 k))
- (j (logand (ash lo (- shift))))
- (j2 (ash j shift)))
- (declare (type (mod 32) shift)
- (type (unsigned-byte 32) j j2))
- (when (= j2 lo)
- (setq isint (- 2 (logand j 1))))))
- ((= lo 0)
- (let* ((shift (- 20 k))
- (j (ash ihi (- shift)))
- (j2 (ash j shift)))
- (declare (type (mod 32) shift)
- (type (unsigned-byte 31) j j2))
- (when (= j2 ihi)
- (setq isint (- 2 (logand j 1))))))))))
- isint))
- (real-expt (x y rtype)
- (let ((x (coerce x 'double-float))
- (y (coerce y 'double-float)))
- (declare (double-float x y))
- (let* ((x-hi (sb!kernel:double-float-high-bits x))
- (x-lo (sb!kernel:double-float-low-bits x))
- (x-ihi (logand x-hi #x7fffffff))
- (y-hi (sb!kernel:double-float-high-bits y))
- (y-lo (sb!kernel:double-float-low-bits y))
- (y-ihi (logand y-hi #x7fffffff)))
- (declare (type (signed-byte 32) x-hi y-hi)
- (type (unsigned-byte 31) x-ihi y-ihi)
- (type (unsigned-byte 32) x-lo y-lo))
- ;; y==zero: x**0 = 1
- (when (zerop (logior y-ihi y-lo))
- (return-from real-expt (coerce 1d0 rtype)))
- ;; +-NaN return x+y
- (when (or (> x-ihi #x7ff00000)
- (and (= x-ihi #x7ff00000) (/= x-lo 0))
- (> y-ihi #x7ff00000)
- (and (= y-ihi #x7ff00000) (/= y-lo 0)))
- (return-from real-expt (coerce (+ x y) rtype)))
- (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0)))
- (declare (type fixnum yisint))
- ;; special value of y
- (when (and (zerop y-lo) (= y-ihi #x7ff00000))
- ;; y is +-inf
- (return-from real-expt
- (cond ((and (= x-ihi #x3ff00000) (zerop x-lo))
- ;; +-1**inf is NaN
- (coerce (- y y) rtype))
- ((>= x-ihi #x3ff00000)
- ;; (|x|>1)**+-inf = inf,0
- (if (>= y-hi 0)
- (coerce y rtype)
- (coerce 0 rtype)))
- (t
- ;; (|x|<1)**-,+inf = inf,0
- (if (< y-hi 0)
- (coerce (- y) rtype)
- (coerce 0 rtype))))))
+ ;; 0 - not an integer
+ ;; 1 - an odd int
+ ;; 2 - an even int
+ (isint (ihi lo)
+ (declare (type (unsigned-byte 31) ihi)
+ (type (unsigned-byte 32) lo)
+ (optimize (speed 3) (safety 0)))
+ (let ((isint 0))
+ (declare (type fixnum isint))
+ (cond ((>= ihi #x43400000) ; exponent >= 53
+ (setq isint 2))
+ ((>= ihi #x3ff00000)
+ (let ((k (- (ash ihi -20) #x3ff))) ; exponent
+ (declare (type (mod 53) k))
+ (cond ((> k 20)
+ (let* ((shift (- 52 k))
+ (j (logand (ash lo (- shift))))
+ (j2 (ash j shift)))
+ (declare (type (mod 32) shift)
+ (type (unsigned-byte 32) j j2))
+ (when (= j2 lo)
+ (setq isint (- 2 (logand j 1))))))
+ ((= lo 0)
+ (let* ((shift (- 20 k))
+ (j (ash ihi (- shift)))
+ (j2 (ash j shift)))
+ (declare (type (mod 32) shift)
+ (type (unsigned-byte 31) j j2))
+ (when (= j2 ihi)
+ (setq isint (- 2 (logand j 1))))))))))
+ isint))
+ (real-expt (x y rtype)
+ (let ((x (coerce x 'double-float))
+ (y (coerce y 'double-float)))
+ (declare (double-float x y))
+ (let* ((x-hi (sb!kernel:double-float-high-bits x))
+ (x-lo (sb!kernel:double-float-low-bits x))
+ (x-ihi (logand x-hi #x7fffffff))
+ (y-hi (sb!kernel:double-float-high-bits y))
+ (y-lo (sb!kernel:double-float-low-bits y))
+ (y-ihi (logand y-hi #x7fffffff)))
+ (declare (type (signed-byte 32) x-hi y-hi)
+ (type (unsigned-byte 31) x-ihi y-ihi)
+ (type (unsigned-byte 32) x-lo y-lo))
+ ;; y==zero: x**0 = 1
+ (when (zerop (logior y-ihi y-lo))
+ (return-from real-expt (coerce 1d0 rtype)))
+ ;; +-NaN return x+y
+ ;; FIXME: Hardcoded qNaN/sNaN values are not portable.
+ (when (or (> x-ihi #x7ff00000)
+ (and (= x-ihi #x7ff00000) (/= x-lo 0))
+ (> y-ihi #x7ff00000)
+ (and (= y-ihi #x7ff00000) (/= y-lo 0)))
+ (return-from real-expt (coerce (+ x y) rtype)))
+ (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0)))
+ (declare (type fixnum yisint))
+ ;; special value of y
+ (when (and (zerop y-lo) (= y-ihi #x7ff00000))
+ ;; y is +-inf
+ (return-from real-expt
+ (cond ((and (= x-ihi #x3ff00000) (zerop x-lo))
+ ;; +-1**inf is NaN
+ (coerce (- y y) rtype))
+ ((>= x-ihi #x3ff00000)
+ ;; (|x|>1)**+-inf = inf,0
+ (if (>= y-hi 0)
+ (coerce y rtype)
+ (coerce 0 rtype)))
+ (t
+ ;; (|x|<1)**-,+inf = inf,0
+ (if (< y-hi 0)
+ (coerce (- y) rtype)
+ (coerce 0 rtype))))))