0.9.2.43:
[sbcl.git] / src / code / irrat.lisp
index 25a5f8b..9b901e8 100644 (file)
@@ -43,7 +43,7 @@
 \f
 #!+x86 ;; for constant folding
 (macrolet ((def (name ll)
-            `(defun ,name ,ll (,name ,@ll))))
+             `(defun ,name ,ll (,name ,@ll))))
   (def %atan2 (x y))
   (def %atan (x))
   (def %tan-quick (x))
@@ -91,7 +91,7 @@
     (handle-reals %exp number)
     ((complex)
      (* (exp (realpart number))
-       (cis (imagpart number))))))
+        (cis (imagpart number))))))
 
 ;;; INTEXP -- Handle the rational base, integer power case.
 
 ;;; integers, and inverted if negative.
 (defun intexp (base power)
   (when (and *intexp-maximum-exponent*
-            (> (abs power) *intexp-maximum-exponent*))
+             (> (abs power) *intexp-maximum-exponent*))
     (error "The absolute value of ~S exceeds ~S."
-           power '*intexp-maximum-exponent*))
+            power '*intexp-maximum-exponent*))
   (cond ((minusp power)
-        (/ (intexp base (- power))))
-       ((eql base 2)
-        (ash 1 power))
-       (t
-        (do ((nextn (ash power -1) (ash power -1))
-             (total (if (oddp power) base 1)
-                    (if (oddp power) (* base total) total)))
-            ((zerop nextn) total)
-          (setq base (* base base))
-          (setq power nextn)))))
+         (/ (intexp base (- power))))
+        ((eql base 2)
+         (ash 1 power))
+        (t
+         (do ((nextn (ash power -1) (ash power -1))
+              (total (if (oddp power) base 1)
+                     (if (oddp power) (* base total) total)))
+             ((zerop nextn) total)
+           (setq base (* base base))
+           (setq power nextn)))))
 
 ;;; If an integer power of a rational, use INTEXP above. Otherwise, do
 ;;; floating point stuff. If both args are real, we try %POW right
   "Return BASE raised to the POWER."
   (if (zerop power)
       (let ((result (1+ (* base power))))
-       (if (and (floatp result) (float-nan-p result))
-           (float 1 result)
-           result))
+        (if (and (floatp result) (float-nan-p result))
+            (float 1 result)
+            result))
     (labels (;; determine if the double float is an integer.
-            ;;  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
+                   (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))))))
 
-                    (let ((abs-x (abs x)))
-                      (declare (double-float abs-x))
-                      ;; special value of x
-                      (when (and (zerop x-lo)
-                                 (or (= x-ihi #x7ff00000) (zerop x-ihi)
-                                     (= x-ihi #x3ff00000)))
-                        ;; x is +-0,+-inf,+-1
-                        (let ((z (if (< y-hi 0)
-                                     (/ 1 abs-x)       ; z = (1/|x|)
-                                     abs-x)))
-                          (declare (double-float z))
-                          (when (< x-hi 0)
-                            (cond ((and (= x-ihi #x3ff00000) (zerop yisint))
-                                   ;; (-1)**non-int
-                                   (let ((y*pi (* y pi)))
-                                     (declare (double-float y*pi))
-                                     (return-from real-expt
-                                       (complex
-                                        (coerce (%cos y*pi) rtype)
-                                        (coerce (%sin y*pi) rtype)))))
-                                  ((= yisint 1)
-                                   ;; (x<0)**odd = -(|x|**odd)
-                                   (setq z (- z)))))
-                          (return-from real-expt (coerce z rtype))))
+                     (let ((abs-x (abs x)))
+                       (declare (double-float abs-x))
+                       ;; special value of x
+                       (when (and (zerop x-lo)
+                                  (or (= x-ihi #x7ff00000) (zerop x-ihi)
+                                      (= x-ihi #x3ff00000)))
+                         ;; x is +-0,+-inf,+-1
+                         (let ((z (if (< y-hi 0)
+                                      (/ 1 abs-x)       ; z = (1/|x|)
+                                      abs-x)))
+                           (declare (double-float z))
+                           (when (< x-hi 0)
+                             (cond ((and (= x-ihi #x3ff00000) (zerop yisint))
+                                    ;; (-1)**non-int
+                                    (let ((y*pi (* y pi)))
+                                      (declare (double-float y*pi))
+                                      (return-from real-expt
+                                        (complex
+                                         (coerce (%cos y*pi) rtype)
+                                         (coerce (%sin y*pi) rtype)))))
+                                   ((= yisint 1)
+                                    ;; (x<0)**odd = -(|x|**odd)
+                                    (setq z (- z)))))
+                           (return-from real-expt (coerce z rtype))))
 
-                      (if (>= x-hi 0)
-                          ;; x>0
-                          (coerce (sb!kernel::%pow x y) rtype)
-                          ;; x<0
-                          (let ((pow (sb!kernel::%pow abs-x y)))
-                            (declare (double-float pow))
-                            (case yisint
-                              (1 ; odd
-                               (coerce (* -1d0 pow) rtype))
-                              (2 ; even
-                               (coerce pow rtype))
-                              (t ; non-integer
-                               (let ((y*pi (* y pi)))
-                                 (declare (double-float y*pi))
-                                 (complex
-                                  (coerce (* pow (%cos y*pi))
-                                          rtype)
-                                  (coerce (* pow (%sin y*pi))
-                                          rtype)))))))))))))
+                       (if (>= x-hi 0)
+                           ;; x>0
+                           (coerce (sb!kernel::%pow x y) rtype)
+                           ;; x<0
+                           (let ((pow (sb!kernel::%pow abs-x y)))
+                             (declare (double-float pow))
+                             (case yisint
+                               (1 ; odd
+                                (coerce (* -1d0 pow) rtype))
+                               (2 ; even
+                                (coerce pow rtype))
+                               (t ; non-integer
+                                (let ((y*pi (* y pi)))
+                                  (declare (double-float y*pi))
+                                  (complex
+                                   (coerce (* pow (%cos y*pi))
+                                           rtype)
+                                   (coerce (* pow (%sin y*pi))
+                                           rtype)))))))))))))
       (declare (inline real-expt))
       (number-dispatch ((base number) (power number))
-       (((foreach fixnum (or bignum ratio) (complex rational)) integer)
-        (intexp base power))
-       (((foreach single-float double-float) rational)
-        (real-expt base power '(dispatch-type base)))
-       (((foreach fixnum (or bignum ratio) single-float)
-         (foreach ratio single-float))
-        (real-expt base power 'single-float))
-       (((foreach fixnum (or bignum ratio) single-float double-float)
-         double-float)
-        (real-expt base power 'double-float))
-       ((double-float single-float)
-        (real-expt base power 'double-float))
-       (((foreach (complex rational) (complex float)) rational)
-        (* (expt (abs base) power)
-           (cis (* power (phase base)))))
-       (((foreach fixnum (or bignum ratio) single-float double-float)
-         complex)
-        (if (and (zerop base) (plusp (realpart power)))
-            (* base power)
-            (exp (* power (log base)))))
-       (((foreach (complex float) (complex rational))
-         (foreach complex double-float single-float))
-        (if (and (zerop base) (plusp (realpart power)))
-            (* base power)
-            (exp (* power (log base)))))))))
+        (((foreach fixnum (or bignum ratio) (complex rational)) integer)
+         (intexp base power))
+        (((foreach single-float double-float) rational)
+         (real-expt base power '(dispatch-type base)))
+        (((foreach fixnum (or bignum ratio) single-float)
+          (foreach ratio single-float))
+         (real-expt base power 'single-float))
+        (((foreach fixnum (or bignum ratio) single-float double-float)
+          double-float)
+         (real-expt base power 'double-float))
+        ((double-float single-float)
+         (real-expt base power 'double-float))
+        (((foreach (complex rational) (complex float)) rational)
+         (* (expt (abs base) power)
+            (cis (* power (phase base)))))
+        (((foreach fixnum (or bignum ratio) single-float double-float)
+          complex)
+         (if (and (zerop base) (plusp (realpart power)))
+             (* base power)
+             (exp (* power (log base)))))
+        (((foreach (complex float) (complex rational))
+          (foreach complex double-float single-float))
+         (if (and (zerop base) (plusp (realpart power)))
+             (* base power)
+             (exp (* power (log base)))))))))
 
 ;;; FIXME: Maybe rename this so that it's clearer that it only works
 ;;; on integers?
   ;; Motivated by an attempt to get LOG to work better on bignums.
   (let ((n (integer-length x)))
     (if (< n sb!vm:double-float-digits)
-       (log (coerce x 'double-float) 2.0d0)
-       (let ((f (ldb (byte sb!vm:double-float-digits
-                           (- n sb!vm:double-float-digits))
-                     x)))
-         (+ n (log (scale-float (coerce f 'double-float)
-                                (- sb!vm:double-float-digits))
-                   2.0d0))))))
+        (log (coerce x 'double-float) 2.0d0)
+        (let ((f (ldb (byte sb!vm:double-float-digits
+                            (- n sb!vm:double-float-digits))
+                      x)))
+          (+ n (log (scale-float (coerce f 'double-float)
+                                 (- sb!vm:double-float-digits))
+                    2.0d0))))))
 
 (defun log (number &optional (base nil base-p))
   #!+sb-doc
   "Return the logarithm of NUMBER in the base BASE, which defaults to e."
   (if base-p
       (cond
-       ((zerop base) 0f0) ; FIXME: type
-       ((and (typep number '(integer (0) *))
-             (typep base '(integer (0) *)))
-        (coerce (/ (log2 number) (log2 base)) 'single-float))
-       (t (/ (log number) (log base))))
+        ((zerop base) 0f0) ; FIXME: type
+        ((and (typep number '(integer (0) *))
+              (typep base '(integer (0) *)))
+         (coerce (/ (log2 number) (log2 base)) 'single-float))
+        (t (/ (log number) (log base))))
       (number-dispatch ((number number))
-       (((foreach fixnum bignum))
-        (if (minusp number)
-            (complex (log (- number)) (coerce pi 'single-float))
-            (coerce (/ (log2 number) (log (exp 1.0d0) 2.0d0)) 'single-float)))
-       ((ratio)
-        (if (minusp number)
-            (complex (log (- number)) (coerce pi 'single-float))
-            (let ((numerator (numerator number))
-                  (denominator (denominator number)))
-              (if (= (integer-length numerator)
-                     (integer-length denominator))
-                  (coerce (%log1p (coerce (- number 1) 'double-float))
-                          'single-float)
-                  (coerce (/ (- (log2 numerator) (log2 denominator))
-                             (log (exp 1.0d0) 2.0d0))
-                          'single-float)))))
-       (((foreach single-float double-float))
-        ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)?
-        ;; Since this doesn't seem to be an implementation issue
-        ;; I (pw) take the Kahan result.
-        (if (< (float-sign number)
-               (coerce 0 '(dispatch-type number)))
-            (complex (log (- number)) (coerce pi '(dispatch-type number)))
-            (coerce (%log (coerce number 'double-float))
-                    '(dispatch-type number))))
-       ((complex)
-        (complex-log number)))))
+        (((foreach fixnum bignum))
+         (if (minusp number)
+             (complex (log (- number)) (coerce pi 'single-float))
+             (coerce (/ (log2 number) (log (exp 1.0d0) 2.0d0)) 'single-float)))
+        ((ratio)
+         (if (minusp number)
+             (complex (log (- number)) (coerce pi 'single-float))
+             (let ((numerator (numerator number))
+                   (denominator (denominator number)))
+               (if (= (integer-length numerator)
+                      (integer-length denominator))
+                   (coerce (%log1p (coerce (- number 1) 'double-float))
+                           'single-float)
+                   (coerce (/ (- (log2 numerator) (log2 denominator))
+                              (log (exp 1.0d0) 2.0d0))
+                           'single-float)))))
+        (((foreach single-float double-float))
+         ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)?
+         ;; Since this doesn't seem to be an implementation issue
+         ;; I (pw) take the Kahan result.
+         (if (< (float-sign number)
+                (coerce 0 '(dispatch-type number)))
+             (complex (log (- number)) (coerce pi '(dispatch-type number)))
+             (coerce (%log (coerce number 'double-float))
+                     '(dispatch-type number))))
+        ((complex)
+         (complex-log number)))))
 
 (defun sqrt (number)
   #!+sb-doc
   (number-dispatch ((number number))
     (((foreach fixnum bignum ratio))
      (if (minusp number)
-        (complex-sqrt number)
-        (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
+         (complex-sqrt number)
+         (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
     (((foreach single-float double-float))
      (if (minusp number)
-        (complex-sqrt (complex number))
-        (coerce (%sqrt (coerce number 'double-float))
-                '(dispatch-type number))))
+         (complex-sqrt (complex number))
+         (coerce (%sqrt (coerce number 'double-float))
+                 '(dispatch-type number))))
      ((complex)
       (complex-sqrt number))))
 \f
      (abs number))
     ((complex)
      (let ((rx (realpart number))
-          (ix (imagpart number)))
+           (ix (imagpart number)))
        (etypecase rx
-        (rational
-         (sqrt (+ (* rx rx) (* ix ix))))
-        (single-float
-         (coerce (%hypot (coerce rx 'double-float)
-                         (coerce ix 'double-float))
-                 'single-float))
-        (double-float
-         (%hypot rx ix)))))))
+         (rational
+          (sqrt (+ (* rx rx) (* ix ix))))
+         (single-float
+          (coerce (%hypot (coerce rx 'double-float)
+                          (coerce ix 'double-float))
+                  'single-float))
+         (double-float
+          (%hypot rx ix)))))))
 
 (defun phase (number)
   #!+sb-doc
   (etypecase number
     (rational
      (if (minusp number)
-        (coerce pi 'single-float)
-        0.0f0))
+         (coerce pi 'single-float)
+         0.0f0))
     (single-float
      (if (minusp (float-sign number))
-        (coerce pi 'single-float)
-        0.0f0))
+         (coerce pi 'single-float)
+         0.0f0))
     (double-float
      (if (minusp (float-sign number))
-        (coerce pi 'double-float)
-        0.0d0))
+         (coerce pi 'double-float)
+         0.0d0))
     (complex
      (atan (imagpart number) (realpart number)))))
 
     (handle-reals %sin number)
     ((complex)
      (let ((x (realpart number))
-          (y (imagpart number)))
+           (y (imagpart number)))
        (complex (* (sin x) (cosh y))
-               (* (cos x) (sinh y)))))))
+                (* (cos x) (sinh y)))))))
 
 (defun cos (number)
   #!+sb-doc
     (handle-reals %cos number)
     ((complex)
      (let ((x (realpart number))
-          (y (imagpart number)))
+           (y (imagpart number)))
        (complex (* (cos x) (cosh y))
-               (- (* (sin x) (sinh y))))))))
+                (- (* (sin x) (sinh y))))))))
 
 (defun tan (number)
   #!+sb-doc
   (number-dispatch ((number number))
     ((rational)
      (if (or (> number 1) (< number -1))
-        (complex-asin number)
-        (coerce (%asin (coerce number 'double-float)) 'single-float)))
+         (complex-asin number)
+         (coerce (%asin (coerce number 'double-float)) 'single-float)))
     (((foreach single-float double-float))
      (if (or (> number (coerce 1 '(dispatch-type number)))
-            (< number (coerce -1 '(dispatch-type number))))
-        (complex-asin (complex number))
-        (coerce (%asin (coerce number 'double-float))
-                '(dispatch-type number))))
+             (< number (coerce -1 '(dispatch-type number))))
+         (complex-asin (complex number))
+         (coerce (%asin (coerce number 'double-float))
+                 '(dispatch-type number))))
     ((complex)
      (complex-asin number))))
 
   (number-dispatch ((number number))
     ((rational)
      (if (or (> number 1) (< number -1))
-        (complex-acos number)
-        (coerce (%acos (coerce number 'double-float)) 'single-float)))
+         (complex-acos number)
+         (coerce (%acos (coerce number 'double-float)) 'single-float)))
     (((foreach single-float double-float))
      (if (or (> number (coerce 1 '(dispatch-type number)))
-            (< number (coerce -1 '(dispatch-type number))))
-        (complex-acos (complex number))
-        (coerce (%acos (coerce number 'double-float))
-                '(dispatch-type number))))
+             (< number (coerce -1 '(dispatch-type number))))
+         (complex-acos (complex number))
+         (coerce (%acos (coerce number 'double-float))
+                 '(dispatch-type number))))
     ((complex)
      (complex-acos number))))
 
   "Return the arc tangent of Y if X is omitted or Y/X if X is supplied."
   (if xp
       (flet ((atan2 (y x)
-              (declare (type double-float y x)
-                       (values double-float))
-              (if (zerop x)
-                  (if (zerop y)
-                      (if (plusp (float-sign x))
-                          y
-                          (float-sign y pi))
-                      (float-sign y (/ pi 2)))
-                  (%atan2 y x))))
-       (number-dispatch ((y real) (x real))
-         ((double-float
-           (foreach double-float single-float fixnum bignum ratio))
-          (atan2 y (coerce x 'double-float)))
-         (((foreach single-float fixnum bignum ratio)
-           double-float)
-          (atan2 (coerce y 'double-float) x))
-         (((foreach single-float fixnum bignum ratio)
-           (foreach single-float fixnum bignum ratio))
-          (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float))
-                  'single-float))))
+               (declare (type double-float y x)
+                        (values double-float))
+               (if (zerop x)
+                   (if (zerop y)
+                       (if (plusp (float-sign x))
+                           y
+                           (float-sign y pi))
+                       (float-sign y (/ pi 2)))
+                   (%atan2 y x))))
+        (number-dispatch ((y real) (x real))
+          ((double-float
+            (foreach double-float single-float fixnum bignum ratio))
+           (atan2 y (coerce x 'double-float)))
+          (((foreach single-float fixnum bignum ratio)
+            double-float)
+           (atan2 (coerce y 'double-float) x))
+          (((foreach single-float fixnum bignum ratio)
+            (foreach single-float fixnum bignum ratio))
+           (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float))
+                   'single-float))))
       (number-dispatch ((y number))
-       (handle-reals %atan y)
-       ((complex)
-        (complex-atan y)))))
+        (handle-reals %atan y)
+        ((complex)
+         (complex-atan y)))))
 
 ;;; It seems that every target system has a C version of sinh, cosh,
 ;;; and tanh. Let's use these for reals because the original
     (handle-reals %sinh number)
     ((complex)
      (let ((x (realpart number))
-          (y (imagpart number)))
+           (y (imagpart number)))
        (complex (* (sinh x) (cos y))
-               (* (cosh x) (sin y)))))))
+                (* (cosh x) (sin y)))))))
 
 (defun cosh (number)
   #!+sb-doc
     (handle-reals %cosh number)
     ((complex)
      (let ((x (realpart number))
-          (y (imagpart number)))
+           (y (imagpart number)))
        (complex (* (cosh x) (cos y))
-               (* (sinh x) (sin y)))))))
+                (* (sinh x) (sin y)))))))
 
 (defun tanh (number)
   #!+sb-doc
     ((rational)
      ;; acosh is complex if number < 1
      (if (< number 1)
-        (complex-acosh number)
-        (coerce (%acosh (coerce number 'double-float)) 'single-float)))
+         (complex-acosh number)
+         (coerce (%acosh (coerce number 'double-float)) 'single-float)))
     (((foreach single-float double-float))
      (if (< number (coerce 1 '(dispatch-type number)))
-        (complex-acosh (complex number))
-        (coerce (%acosh (coerce number 'double-float))
-                '(dispatch-type number))))
+         (complex-acosh (complex number))
+         (coerce (%acosh (coerce number 'double-float))
+                 '(dispatch-type number))))
     ((complex)
      (complex-acosh number))))
 
     ((rational)
      ;; atanh is complex if |number| > 1
      (if (or (> number 1) (< number -1))
-        (complex-atanh number)
-        (coerce (%atanh (coerce number 'double-float)) 'single-float)))
+         (complex-atanh number)
+         (coerce (%atanh (coerce number 'double-float)) 'single-float)))
     (((foreach single-float double-float))
      (if (or (> number (coerce 1 '(dispatch-type number)))
-            (< number (coerce -1 '(dispatch-type number))))
-        (complex-atanh (complex number))
-        (coerce (%atanh (coerce number 'double-float))
-                '(dispatch-type number))))
+             (< number (coerce -1 '(dispatch-type number))))
+         (complex-atanh (complex number))
+         (coerce (%atanh (coerce number 'double-float))
+                 '(dispatch-type number))))
     ((complex)
      (complex-atanh number))))
 
 ;;; HP-UX does not supply a C version of log1p, so use the definition.
-;;; 
+;;;
 ;;; FIXME: This is really not a good definition. As per Raymond Toy
 ;;; working on CMU CL, "The definition really loses big-time in
 ;;; roundoff as x gets small."
 #!+hpux
 (defun %log1p (number)
   (declare (double-float number)
-          (optimize (speed 3) (safety 0)))
+           (optimize (speed 3) (safety 0)))
   (the double-float (log (the (double-float 0d0) (+ number 1d0)))))
 \f
 ;;;; not-OLD-SPECFUN stuff
 (declaim (inline scalb))
 (defun scalb (x n)
   (declare (type double-float x)
-          (type double-float-exponent n))
+           (type double-float-exponent n))
   (scale-float x n))
 
 ;;; This is like LOGB, but X is not infinity and non-zero and not a
 (defun logb (x)
   (declare (type double-float x))
   (cond ((float-nan-p x)
-        x)
-       ((float-infinity-p x)
-        ;; DOUBLE-FLOAT-POSITIVE-INFINITY
-        (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
-       ((zerop x)
-        ;; The answer is negative infinity, but we are supposed to
+         x)
+        ((float-infinity-p x)
+         ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+         (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
+        ((zerop x)
+         ;; The answer is negative infinity, but we are supposed to
           ;; signal divide-by-zero, so do the actual division
-        (/ -1.0d0 x)
-        )
-       (t
+         (/ -1.0d0 x)
+         )
+        (t
           (logb-finite x))))
 
 ;;; This function is used to create a complex number of the
 ;;;   such that has the same type as Z.  If Z has type (complex
 ;;;   rational), the X and Y are coerced to single-float.
 #!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
-               (error "needs work for long float support"))
+                (error "needs work for long float support"))
 (declaim (inline coerce-to-complex-type))
 (defun coerce-to-complex-type (x y z)
   (declare (double-float x y)
-          (number z))
+           (number z))
   (if (typep (realpart z) 'double-float)
       (complex x y)
       ;; Convert anything that's not already a DOUBLE-FLOAT (because
       ;; the initial argument was a (COMPLEX DOUBLE-FLOAT) and we
       ;; haven't done anything to lose precision) to a SINGLE-FLOAT.
       (complex (float x 1f0)
-              (float y 1f0))))
+               (float y 1f0))))
 
 ;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
 ;;; result is r + i*k, where k is an integer.
 #!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
-               (error "needs work for long float support"))
+                (error "needs work for long float support"))
 (defun cssqs (z)
   (let ((x (float (realpart z) 1d0))
-       (y (float (imagpart z) 1d0)))
+        (y (float (imagpart z) 1d0)))
     ;; Would this be better handled using an exception handler to
     ;; catch the overflow or underflow signal?  For now, we turn all
     ;; traps off and look at the accrued exceptions to see if any
       (let ((rho (+ (square x) (square y))))
        (declare (optimize (speed 3) (space 0)))
       (cond ((and (or (float-nan-p rho)
-                     (float-infinity-p rho))
-                 (or (float-infinity-p (abs x))
-                     (float-infinity-p (abs y))))
-            ;; DOUBLE-FLOAT-POSITIVE-INFINITY
-            (values
-             (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)
-             0))
-           ((let ((threshold #.(/ least-positive-double-float
-                                  double-float-epsilon))
-                  (traps (ldb sb!vm::float-sticky-bits
-                              (sb!vm:floating-point-modes))))
+                      (float-infinity-p rho))
+                  (or (float-infinity-p (abs x))
+                      (float-infinity-p (abs y))))
+             ;; DOUBLE-FLOAT-POSITIVE-INFINITY
+             (values
+              (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0)
+              0))
+            ((let ((threshold #.(/ least-positive-double-float
+                                   double-float-epsilon))
+                   (traps (ldb sb!vm::float-sticky-bits
+                               (sb!vm:floating-point-modes))))
                 ;; Overflow raised or (underflow raised and rho <
                 ;; lambda/eps)
-              (or (not (zerop (logand sb!vm:float-overflow-trap-bit traps)))
-                  (and (not (zerop (logand sb!vm:float-underflow-trap-bit
-                                           traps)))
-                       (< rho threshold))))
+               (or (not (zerop (logand sb!vm:float-overflow-trap-bit traps)))
+                   (and (not (zerop (logand sb!vm:float-underflow-trap-bit
+                                            traps)))
+                        (< rho threshold))))
               ;; If we're here, neither x nor y are infinity and at
               ;; least one is non-zero.. Thus logb returns a nice
               ;; integer.
     (declare (type (or (member 0d0) (double-float 0d0)) rho)
              (type fixnum k))
     (let ((x (float (realpart z) 1.0d0))
-         (y (float (imagpart z) 1.0d0))
-         (eta 0d0)
-         (nu 0d0))
+          (y (float (imagpart z) 1.0d0))
+          (eta 0d0)
+          (nu 0d0))
       (declare (double-float x y eta nu))
 
       (locally
          (declare (optimize (speed 3) (space 0)))
 
       (if (not (float-nan-p x))
-         (setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
+          (setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
 
       (cond ((oddp k)
-            (setf k (ash k -1)))
-           (t
-            (setf k (1- (ash k -1)))
-            (setf rho (+ rho rho))))
+             (setf k (ash k -1)))
+            (t
+             (setf k (1- (ash k -1)))
+             (setf rho (+ rho rho))))
 
       (setf rho (scalb (sqrt rho) k))
 
       (setf nu y)
 
       (when (/= rho 0d0)
-           (when (not (float-infinity-p (abs nu)))
-                 (setf nu (/ (/ nu rho) 2d0)))
-           (when (< x 0d0)
-                 (setf eta (abs nu))
-                 (setf nu (float-sign y rho))))
+            (when (not (float-infinity-p (abs nu)))
+                  (setf nu (/ (/ nu rho) 2d0)))
+            (when (< x 0d0)
+                  (setf eta (abs nu))
+                  (setf nu (float-sign y rho))))
        (coerce-to-complex-type eta nu z)))))
-    
+
 ;;; Compute log(2^j*z).
 ;;;
 ;;; This is for use with J /= 0 only when |z| is huge.
 (defun complex-log-scaled (z j)
   (declare (type (or rational complex) z)
-          (fixnum j))
+           (fixnum j))
   ;; The constants t0, t1, t2 should be evaluated to machine
   ;; precision.  In addition, Kahan says the accuracy of log1p
   ;; influences the choices of these constants but doesn't say how to
   ;; choose them.  We'll just assume his choices matches our
   ;; implementation of log1p.
   (let ((t0 #.(/ 1 (sqrt 2.0d0)))
-       (t1 1.2d0)
-       (t2 3d0)
-       (ln2 #.(log 2d0))
-       (x (float (realpart z) 1.0d0))
-       (y (float (imagpart z) 1.0d0)))
+        (t1 1.2d0)
+        (t2 3d0)
+        (ln2 #.(log 2d0))
+        (x (float (realpart z) 1.0d0))
+        (y (float (imagpart z) 1.0d0)))
     (multiple-value-bind (rho k)
-       (cssqs z)
+        (cssqs z)
       (declare (optimize (speed 3)))
       (let ((beta (max (abs x) (abs y)))
-           (theta (min (abs x) (abs y))))
+            (theta (min (abs x) (abs y))))
         (coerce-to-complex-type (if (and (zerop k)
-                (< t0 beta)
-                (or (<= beta t1)
-                    (< rho t2)))
+                 (< t0 beta)
+                 (or (<= beta t1)
+                     (< rho t2)))
                                   (/ (%log1p (+ (* (- beta 1.0d0)
-                                      (+ beta 1.0d0))
-                                   (* theta theta)))
+                                       (+ beta 1.0d0))
+                                    (* theta theta)))
                                      2d0)
                                   (+ (/ (log rho) 2d0)
                                      (* (+ k j) ln2)))
 (defun complex-log (z)
   (declare (type (or rational complex) z))
   (complex-log-scaled z 0))
-              
+
 ;;; KLUDGE: Let us note the following "strange" behavior. atanh 1.0d0
 ;;; is +infinity, but the following code returns approx 176 + i*pi/4.
 ;;; The reason for the imaginary part is caused by the fact that arg
          (theta (/ (sqrt most-positive-double-float) 4.0d0))
          (rho (/ 4.0d0 (sqrt most-positive-double-float)))
          (half-pi (/ pi 2.0d0))
-        (rp (float (realpart z) 1.0d0))
-        (beta (float-sign rp 1.0d0))
-        (x (* beta rp))
-        (y (* beta (- (float (imagpart z) 1.0d0))))
-        (eta 0.0d0)
-        (nu 0.0d0))
+         (rp (float (realpart z) 1.0d0))
+         (beta (float-sign rp 1.0d0))
+         (x (* beta rp))
+         (y (* beta (- (float (imagpart z) 1.0d0))))
+         (eta 0.0d0)
+         (nu 0.0d0))
     ;; Shouldn't need this declare.
     (declare (double-float x y))
     (locally
        (declare (optimize (speed 3)))
     (cond ((or (> x theta)
-              (> (abs y) theta))
-          ;; To avoid overflow...
-          (setf nu (float-sign y half-pi))
-          ;; ETA is real part of 1/(x + iy).  This is x/(x^2+y^2),
-          ;; which can cause overflow.  Arrange this computation so
-          ;; that it won't overflow.
-          (setf eta (let* ((x-bigger (> x (abs y)))
-                           (r (if x-bigger (/ y x) (/ x y)))
-                           (d (+ 1.0d0 (* r r))))
-                      (if x-bigger
-                          (/ (/ x) d)
-                          (/ (/ r y) d)))))
-         ((= x 1.0d0)
-          ;; Should this be changed so that if y is zero, eta is set
-          ;; to +infinity instead of approx 176?  In any case
-          ;; tanh(176) is 1.0d0 within working precision.
-          (let ((t1 (+ 4d0 (square y)))
-                (t2 (+ (abs y) rho)))
-            (setf eta (log (/ (sqrt (sqrt t1))
-                              (sqrt t2))))
-            (setf nu (* 0.5d0
-                        (float-sign y
-                                    (+ half-pi (atan (* 0.5d0 t2))))))))
-         (t
-          (let ((t1 (+ (abs y) rho)))
+               (> (abs y) theta))
+           ;; To avoid overflow...
+           (setf nu (float-sign y half-pi))
+           ;; ETA is real part of 1/(x + iy).  This is x/(x^2+y^2),
+           ;; which can cause overflow.  Arrange this computation so
+           ;; that it won't overflow.
+           (setf eta (let* ((x-bigger (> x (abs y)))
+                            (r (if x-bigger (/ y x) (/ x y)))
+                            (d (+ 1.0d0 (* r r))))
+                       (if x-bigger
+                           (/ (/ x) d)
+                           (/ (/ r y) d)))))
+          ((= x 1.0d0)
+           ;; Should this be changed so that if y is zero, eta is set
+           ;; to +infinity instead of approx 176?  In any case
+           ;; tanh(176) is 1.0d0 within working precision.
+           (let ((t1 (+ 4d0 (square y)))
+                 (t2 (+ (abs y) rho)))
+             (setf eta (log (/ (sqrt (sqrt t1))
+                               (sqrt t2))))
+             (setf nu (* 0.5d0
+                         (float-sign y
+                                     (+ half-pi (atan (* 0.5d0 t2))))))))
+          (t
+           (let ((t1 (+ (abs y) rho)))
               ;; Normal case using log1p(x) = log(1 + x)
-            (setf eta (* 0.25d0
-                         (%log1p (/ (* 4.0d0 x)
-                                    (+ (square (- 1.0d0 x))
-                                       (square t1))))))
-            (setf nu (* 0.5d0
-                        (atan (* 2.0d0 y)
-                              (- (* (- 1.0d0 x)
-                                    (+ 1.0d0 x))
-                                 (square t1))))))))
+             (setf eta (* 0.25d0
+                          (%log1p (/ (* 4.0d0 x)
+                                     (+ (square (- 1.0d0 x))
+                                        (square t1))))))
+             (setf nu (* 0.5d0
+                         (atan (* 2.0d0 y)
+                               (- (* (- 1.0d0 x)
+                                     (+ 1.0d0 x))
+                                  (square t1))))))))
     (coerce-to-complex-type (* beta eta)
-                           (- (* beta nu))
+                            (- (* beta nu))
                              z))))
 
 ;;; Compute tanh z = sinh z / cosh z.
 (defun complex-tanh (z)
   (declare (type (or rational complex) z))
   (let ((x (float (realpart z) 1.0d0))
-       (y (float (imagpart z) 1.0d0)))
+        (y (float (imagpart z) 1.0d0)))
     (locally
       ;; space 0 to get maybe-inline functions inlined
       (declare (optimize (speed 3) (space 0)))
     (cond ((> (abs x)
-             ;; FIXME: this form is hideously broken wrt
-             ;; cross-compilation portability.  Much else in this
-             ;; file is too, of course, sometimes hidden by
-             ;; constant-folding, but this one in particular clearly
-             ;; depends on host and target
-             ;; MOST-POSITIVE-DOUBLE-FLOATs being equal.  -- CSR,
-             ;; 2003-04-20
-             #.(/ (+ (log 2.0d0)
-                     (log most-positive-double-float))
-                  4d0))
-          (coerce-to-complex-type (float-sign x)
-                                  (float-sign y) z))
-         (t
-          (let* ((tv (%tan y))
-                 (beta (+ 1.0d0 (* tv tv)))
-                 (s (sinh x))
-                 (rho (sqrt (+ 1.0d0 (* s s)))))
-            (if (float-infinity-p (abs tv))
-                (coerce-to-complex-type (/ rho s)
-                                        (/ tv)
-                                        z)
-                (let ((den (+ 1.0d0 (* beta s s))))
-                  (coerce-to-complex-type (/ (* beta rho s)
-                                             den)
-                                          (/ tv den)
+              ;; FIXME: this form is hideously broken wrt
+              ;; cross-compilation portability.  Much else in this
+              ;; file is too, of course, sometimes hidden by
+              ;; constant-folding, but this one in particular clearly
+              ;; depends on host and target
+              ;; MOST-POSITIVE-DOUBLE-FLOATs being equal.  -- CSR,
+              ;; 2003-04-20
+              #.(/ (+ (log 2.0d0)
+                      (log most-positive-double-float))
+                   4d0))
+           (coerce-to-complex-type (float-sign x)
+                                   (float-sign y) z))
+          (t
+           (let* ((tv (%tan y))
+                  (beta (+ 1.0d0 (* tv tv)))
+                  (s (sinh x))
+                  (rho (sqrt (+ 1.0d0 (* s s)))))
+             (if (float-infinity-p (abs tv))
+                 (coerce-to-complex-type (/ rho s)
+                                         (/ tv)
+                                         z)
+                 (let ((den (+ 1.0d0 (* beta s s))))
+                   (coerce-to-complex-type (/ (* beta rho s)
+                                              den)
+                                           (/ tv den)
                                             z)))))))))
 
 ;;; Compute acos z = pi/2 - asin z.
   ;; -arg z, which is clearly true for all z.
   (declare (type (or rational complex) z))
   (let ((sqrt-1+z (complex-sqrt (+ 1 z)))
-       (sqrt-1-z (complex-sqrt (- 1 z))))
+        (sqrt-1-z (complex-sqrt (- 1 z))))
     (with-float-traps-masked (:divide-by-zero)
       (complex (* 2 (atan (/ (realpart sqrt-1-z)
-                            (realpart sqrt-1+z))))
-              (asinh (imagpart (* (conjugate sqrt-1+z)
-                                  sqrt-1-z)))))))
+                             (realpart sqrt-1+z))))
+               (asinh (imagpart (* (conjugate sqrt-1+z)
+                                   sqrt-1-z)))))))
 
 ;;; Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2))
 ;;;
 (defun complex-acosh (z)
   (declare (type (or rational complex) z))
   (let ((sqrt-z-1 (complex-sqrt (- z 1)))
-       (sqrt-z+1 (complex-sqrt (+ z 1))))
+        (sqrt-z+1 (complex-sqrt (+ z 1))))
     (with-float-traps-masked (:divide-by-zero)
       (complex (asinh (realpart (* (conjugate sqrt-z-1)
-                                  sqrt-z+1)))
-              (* 2 (atan (/ (imagpart sqrt-z-1)
-                            (realpart sqrt-z+1))))))))
+                                   sqrt-z+1)))
+               (* 2 (atan (/ (imagpart sqrt-z-1)
+                             (realpart sqrt-z+1))))))))
 
 ;;; Compute asin z = asinh(i*z)/i.
 ;;;
 (defun complex-asin (z)
   (declare (type (or rational complex) z))
   (let ((sqrt-1-z (complex-sqrt (- 1 z)))
-       (sqrt-1+z (complex-sqrt (+ 1 z))))
+        (sqrt-1+z (complex-sqrt (+ 1 z))))
     (with-float-traps-masked (:divide-by-zero)
       (complex (atan (/ (realpart z)
-                       (realpart (* sqrt-1-z sqrt-1+z))))
-              (asinh (imagpart (* (conjugate sqrt-1-z)
-                                  sqrt-1+z)))))))
+                        (realpart (* sqrt-1-z sqrt-1+z))))
+               (asinh (imagpart (* (conjugate sqrt-1-z)
+                                   sqrt-1+z)))))))
 
 ;;; Compute asinh z = log(z + sqrt(1 + z*z)).
 ;;;
   (declare (type (or rational complex) z))
   ;; asinh z = -i * asin (i*z)
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
-        (result (complex-asin iz)))
+         (result (complex-asin iz)))
     (complex (imagpart result)
-            (- (realpart result)))))
-        
+             (- (realpart result)))))
+
 ;;; Compute atan z = atanh (i*z) / i.
 ;;;
 ;;; Z may be any number, but the result is always a complex.
   (declare (type (or rational complex) z))
   ;; atan z = -i * atanh (i*z)
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
-        (result (complex-atanh iz)))
+         (result (complex-atanh iz)))
     (complex (imagpart result)
-            (- (realpart result)))))
+             (- (realpart result)))))
 
 ;;; Compute tan z = -i * tanh(i * z)
 ;;;
   (declare (type (or rational complex) z))
   ;; tan z = -i * tanh(i*z)
   (let* ((iz (complex (- (imagpart z)) (realpart z)))
-        (result (complex-tanh iz)))
+         (result (complex-tanh iz)))
     (complex (imagpart result)
-            (- (realpart result)))))
+             (- (realpart result)))))