- (declare (double-float x) (fixnum exp))
- (let* ((hi (double-float-high-bits x))
- (lo (double-float-low-bits x))
- (old-exp (ldb sb!vm:double-float-exponent-byte hi))
- (new-exp (+ old-exp exp)))
- (cond
- ((zerop x) x)
- ((or (< old-exp sb!vm:double-float-normal-exponent-min)
- (< new-exp sb!vm:double-float-normal-exponent-min))
- (scale-float-maybe-underflow x exp))
- ((or (> old-exp sb!vm:double-float-normal-exponent-max)
- (> new-exp sb!vm:double-float-normal-exponent-max))
- (scale-float-maybe-overflow x exp))
- (t
- (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi)
- lo)))))
+ (declare (double-float x) (integer exp))
+ (etypecase exp
+ (fixnum
+ (let* ((hi (double-float-high-bits x))
+ (lo (double-float-low-bits x))
+ (old-exp (ldb sb!vm:double-float-exponent-byte hi))
+ (new-exp (+ old-exp exp)))
+ (cond
+ ((zerop x) x)
+ ((or (< old-exp sb!vm:double-float-normal-exponent-min)
+ (< new-exp sb!vm:double-float-normal-exponent-min))
+ (scale-float-maybe-underflow x exp))
+ ((or (> old-exp sb!vm:double-float-normal-exponent-max)
+ (> new-exp sb!vm:double-float-normal-exponent-max))
+ (scale-float-maybe-overflow x exp))
+ (t
+ (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi)
+ lo)))))
+ (unsigned-byte (scale-float-maybe-overflow x exp))
+ ((integer * 0) (scale-float-maybe-underflow x exp))))