X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Firrat.lisp;h=86940c3f41e02c06996774893e8208010772862c;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=6544f582a4194348b70f034386573194537de674;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git

diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index 6544f58..86940c3 100644
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -14,23 +14,27 @@
 
 ;;;; miscellaneous constants, utility functions, and macros
 
-(defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
-;(defconstant e 2.71828182845904523536028747135266249775724709369996L0)
+(defconstant pi
+  #!+long-float 3.14159265358979323846264338327950288419716939937511l0
+  #!-long-float 3.14159265358979323846264338327950288419716939937511d0)
 
 ;;; Make these INLINE, since the call to C is at least as compact as a
 ;;; Lisp call, and saves number consing to boot.
 (eval-when (:compile-toplevel :execute)
 
 (sb!xc:defmacro def-math-rtn (name num-args)
-  (let ((function (symbolicate "%" (string-upcase name))))
+  (let ((function (symbolicate "%" (string-upcase name)))
+        (args (loop for i below num-args
+                    collect (intern (format nil "ARG~D" i)))))
     `(progn
-       (proclaim '(inline ,function))
-       (sb!alien:def-alien-routine (,name ,function) double-float
-         ,@(let ((results nil))
-             (dotimes (i num-args (nreverse results))
-               (push (list (intern (format nil "ARG-~D" i))
-                           'double-float)
-                     results)))))))
+       (declaim (inline ,function))
+       (defun ,function ,args
+         (alien-funcall
+          (extern-alien ,name
+                        (function double-float
+                                  ,@(loop repeat num-args
+                                          collect 'double-float)))
+          ,@args)))))
 
 (defun handle-reals (function var)
   `((((foreach fixnum single-float bignum ratio))
@@ -40,108 +44,113 @@
 
 ) ; EVAL-WHEN
 
-;;;; stubs for the Unix math library
+#!+x86 ;; for constant folding
+(macrolet ((def (name ll)
+             `(defun ,name ,ll (,name ,@ll))))
+  (def %atan2 (x y))
+  (def %atan (x))
+  (def %tan (x))
+  (def %tan-quick (x))
+  (def %cos (x))
+  (def %cos-quick (x))
+  (def %sin (x))
+  (def %sin-quick (x))
+  (def %sqrt (x))
+  (def %log (x))
+  (def %exp (x)))
+
+#!+x86-64 ;; for constant folding
+(macrolet ((def (name ll)
+             `(defun ,name ,ll (,name ,@ll))))
+  (def %sqrt (x)))
 
-;;; Please refer to the Unix man pages for details about these routines.
+;;;; stubs for the Unix math library
+;;;;
+;;;; Many of these are unnecessary on the X86 because they're built
+;;;; into the FPU.
 
-;;; Trigonometric.
+;;; trigonometric
 #!-x86 (def-math-rtn "sin" 1)
 #!-x86 (def-math-rtn "cos" 1)
 #!-x86 (def-math-rtn "tan" 1)
-(def-math-rtn "asin" 1)
-(def-math-rtn "acos" 1)
 #!-x86 (def-math-rtn "atan" 1)
 #!-x86 (def-math-rtn "atan2" 2)
-(def-math-rtn "sinh" 1)
-(def-math-rtn "cosh" 1)
-(def-math-rtn "tanh" 1)
-(def-math-rtn "asinh" 1)
-(def-math-rtn "acosh" 1)
-(def-math-rtn "atanh" 1)
-
-;;; Exponential and Logarithmic.
+#!-(and win32 x86)
+(progn
+  (def-math-rtn "acos" 1)
+  (def-math-rtn "asin" 1)
+  (def-math-rtn "cosh" 1)
+  (def-math-rtn "sinh" 1)
+  (def-math-rtn "tanh" 1)
+  #!-win32
+  (progn
+    (def-math-rtn "asinh" 1)
+    (def-math-rtn "acosh" 1)
+    (def-math-rtn "atanh" 1)))
+#!+win32
+(progn
+  #!-x86-64
+  (progn
+    (declaim (inline %asin))
+    (defun %asin (number)
+      (%atan (/ number (sqrt (- 1 (* number number))))))
+    (declaim (inline %acos))
+    (defun %acos (number)
+      (- (/ pi 2) (%asin number)))
+    (declaim (inline %cosh))
+    (defun %cosh (number)
+      (/ (+ (exp number) (exp (- number))) 2))
+    (declaim (inline %sinh))
+    (defun %sinh (number)
+      (/ (- (exp number) (exp (- number))) 2))
+    (declaim (inline %tanh))
+    (defun %tanh (number)
+      (/ (%sinh number) (%cosh number))))
+  (declaim (inline %asinh))
+  (defun %asinh (number)
+    (log (+ number (sqrt (+ (* number number) 1.0d0))) #.(exp 1.0d0)))
+  (declaim (inline %acosh))
+  (defun %acosh (number)
+    (log (+ number (sqrt (- (* number number) 1.0d0))) #.(exp 1.0d0)))
+  (declaim (inline %atanh))
+  (defun %atanh (number)
+    (let ((ratio (/ (+ 1 number) (- 1 number))))
+      ;; Were we effectively zero?
+      (if (= ratio -1.0d0)
+          0.0d0
+          (/ (log ratio #.(exp 1.0d0)) 2.0d0)))))
+
+;;; exponential and logarithmic
 #!-x86 (def-math-rtn "exp" 1)
 #!-x86 (def-math-rtn "log" 1)
 #!-x86 (def-math-rtn "log10" 1)
-(def-math-rtn "pow" 2)
-#!-x86 (def-math-rtn "sqrt" 1)
-(def-math-rtn "hypot" 2)
-#!-(or hpux x86) (def-math-rtn "log1p" 1)
+#!-(and win32 x86) (def-math-rtn "pow" 2)
+#!-(or x86 x86-64) (def-math-rtn "sqrt" 1)
+#!-win32 (def-math-rtn "hypot" 2)
+#!-x86 (def-math-rtn "log1p" 1)
 
-#!+x86 ;; These are needed for use by byte-compiled files.
+#!+win32
 (progn
-  (defun %sin (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%sin x))
-  (defun %sin-quick (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%sin-quick x))
-  (defun %cos (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%cos x))
-  (defun %cos-quick (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%cos-quick x))
-  (defun %tan (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%tan x))
-  (defun %tan-quick (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%tan-quick x))
-  (defun %atan (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%atan x))
-  (defun %atan2 (x y)
-    (declare (double-float x y)
-	     (values double-float))
-    (%atan2 x y))
-  (defun %exp (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%exp x))
-  (defun %log (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%log x))
-  (defun %log10 (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%log10 x))
-  #+nil ;; notyet
-  (defun %pow (x y)
-    (declare (type (double-float 0d0) x)
-	     (double-float y)
-	     (values (double-float 0d0)))
-    (%pow x y))
-  (defun %sqrt (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%sqrt x))
-  (defun %scalbn (f ex)
-    (declare (double-float f)
-	     (type (signed-byte 32) ex)
-	     (values double-float))
-    (%scalbn f ex))
-  (defun %scalb (f ex)
-    (declare (double-float f ex)
-	     (values double-float))
-    (%scalb f ex))
-  (defun %logb (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%logb x))
-  (defun %log1p (x)
-    (declare (double-float x)
-	     (values double-float))
-    (%log1p x))
-  ) ; progn
+  ;; This is written in a peculiar way to avoid overflow. Note that in
+  ;; sqrt(x^2 + y^2), either square or the sum can overflow.
+  ;;
+  ;; Factoring x^2 out of sqrt(x^2 + y^2) gives us the expression
+  ;; |x|sqrt(1 + (y/x)^2), which, assuming |x| >= |y|, can only overflow
+  ;; if |x| is sufficiently large.
+  ;;
+  ;; The ZEROP test suffices (y is non-negative) to guard against
+  ;; divisions by zero: x >= y > 0.
+  (declaim (inline %hypot))
+  (defun %hypot (x y)
+    (declare (type double-float x y))
+    (let ((x (abs x))
+          (y (abs y)))
+      (when (> y x)
+        (rotatef x y))
+      (if (zerop y)
+          x
+          (let ((y/x (/ y x)))
+            (* x (sqrt (1+ (* y/x y/x)))))))))
 
 ;;;; power functions
 
@@ -152,217 +161,287 @@
     (handle-reals %exp number)
     ((complex)
      (* (exp (realpart number))
-	(cis (imagpart number))))))
+        (cis (imagpart number))))))
 
 ;;; INTEXP -- Handle the rational base, integer power case.
 
-;;; FIXME: As long as the
-;;; system dies on stack overflow or memory exhaustion, it seems reasonable
-;;; to have this, but its default should be NIL, and when it's NIL,
-;;; anything should be accepted.
-(defparameter *intexp-maximum-exponent* 10000)
+(declaim (type (or integer null) *intexp-maximum-exponent*))
+(defparameter *intexp-maximum-exponent* nil)
 
-;;; This function precisely calculates base raised to an integral power. It
-;;; separates the cases by the sign of power, for efficiency reasons, as powers
-;;; can be calculated more efficiently if power is a positive integer. Values
-;;; of power are calculated as positive integers, and inverted if negative.
+;;; This function precisely calculates base raised to an integral
+;;; power. It separates the cases by the sign of power, for efficiency
+;;; reasons, as powers can be calculated more efficiently if power is
+;;; a positive integer. Values of power are calculated as positive
+;;; integers, and inverted if negative.
 (defun intexp (base power)
-  (when (> (abs power) *intexp-maximum-exponent*)
-    ;; FIXME: should be ordinary error, not CERROR. (Once we set the
-    ;; default for the variable to NIL, the un-continuable error will
-    ;; be less obnoxious.)
-    (cerror "Continue with calculation."
-	    "The absolute value of ~S exceeds ~S."
-	    power '*intexp-maximum-exponent* base power))
+  (when (and *intexp-maximum-exponent*
+             (> (abs power) *intexp-maximum-exponent*))
+    (error "The absolute value of ~S exceeds ~S."
+            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 off,
-;;; assuming it will return 0 if the result may be complex. If so, we call
-;;; COMPLEX-POW which directly computes the complex result. We also separate
-;;; the complex-real and real-complex cases from the general complex case.
+;;; floating point stuff. If both args are real, we try %POW right
+;;; off, assuming it will return 0 if the result may be complex. If
+;;; so, we call COMPLEX-POW which directly computes the complex
+;;; result. We also separate the complex-real and real-complex cases
+;;; from the general complex case.
 (defun expt (base power)
   #!+sb-doc
-  "Returns BASE raised to the POWER."
+  "Return BASE raised to the POWER."
   (if (zerop power)
-      (1+ (* base power))
+    (if (and (zerop base) (floatp power))
+        (error 'arguments-out-of-domain-error
+               :operands (list base power)
+               :operation 'expt
+               :references (list '(:ansi-cl :function expt)))
+        (let ((result (1+ (* base power))))
+          (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))))))
-
-		     (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)))))))))))))
-      (declare (inline real-expt))
+             ;;  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))))))
+
+                     (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))))))))))))
+             (complex-expt (base power)
+               (if (and (zerop base) (plusp (realpart power)))
+                   (* base power)
+                   (exp (* power (log base))))))
+      (declare (inline real-expt complex-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))
+        ;; Handle (expt <complex> <rational>), except the case dealt with
+        ;; in the first clause above, (expt <(complex rational)> <integer>).
+        (((foreach (complex rational) (complex single-float)
+                   (complex double-float))
+          rational)
+         (* (expt (abs base) power)
+            (cis (* power (phase base)))))
+        ;; The next three clauses handle (expt <real> <complex>).
+        (((foreach fixnum (or bignum ratio) single-float)
+          (foreach (complex single-float) (complex rational)))
+         (complex-expt base power))
+        (((foreach fixnum (or bignum ratio) single-float)
+          (complex double-float))
+         (complex-expt (coerce base 'double-float) power))
+        ((double-float complex)
+         (complex-expt base power))
+        ;; The next three clauses handle (expt <complex> <float>) and
+        ;; (expt <complex> <complex>).
+        (((foreach (complex single-float) (complex rational))
+          (foreach (complex single-float) (complex rational) single-float))
+         (complex-expt base power))
+        (((foreach (complex single-float) (complex rational))
+          (foreach (complex double-float) double-float))
+         (complex-expt (coerce base '(complex double-float)) power))
+        (((complex double-float)
+          (foreach complex double-float single-float))
+         (complex-expt base power))))))
+
+;;; FIXME: Maybe rename this so that it's clearer that it only works
+;;; on integers?
+(defun log2 (x)
+  (declare (type integer x))
+  ;; CMUCL comment:
+  ;;
+  ;;   Write x = 2^n*f where 1/2 < f <= 1.  Then log2(x) = n +
+  ;;   log2(f).  So we grab the top few bits of x and scale that
+  ;;   appropriately, take the log of it and add it to n.
+  ;;
+  ;; 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))))))
 
 (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
-      (if (zerop base)
-	  base				; ANSI spec
-	  (/ (log number) (log base)))
+      (cond
+        ((zerop base)
+         (if (or (typep number 'double-float) (typep base 'double-float))
+             0.0d0
+             0.0f0))
+        ((and (typep number '(integer (0) *))
+              (typep base '(integer (0) *)))
+         (coerce (/ (log2 number) (log2 base)) 'single-float))
+        ((and (typep number 'integer) (typep base 'double-float))
+         ;; No single float intermediate result
+         (/ (log2 number) (log base 2.0d0)))
+        ((and (typep number 'double-float) (typep base 'integer))
+         (/ (log number 2.0d0) (log2 base)))
+        (t
+         (/ (log number) (log base))))
       (number-dispatch ((number number))
-	(((foreach fixnum bignum ratio))
-	 (if (minusp number)
-	     (complex (log (- number)) (coerce pi 'single-float))
-	     (coerce (%log (coerce number 'double-float)) '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
@@ -370,13 +449,13 @@
   (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 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))))
 
@@ -384,42 +463,42 @@
 
 (defun abs (number)
   #!+sb-doc
-  "Returns the absolute value of the number."
+  "Return the absolute value of the number."
   (number-dispatch ((number number))
     (((foreach single-float double-float fixnum rational))
      (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
-  "Returns the angle part of the polar representation of a complex number.
+  "Return the angle part of the polar representation of a complex number.
   For complex numbers, this is (atan (imagpart number) (realpart number)).
   For non-complex positive numbers, this is 0. For non-complex negative
   numbers this is PI."
   (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)))))
 
@@ -430,9 +509,9 @@
     (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
@@ -441,9 +520,9 @@
     (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
@@ -455,7 +534,7 @@
 
 (defun cis (theta)
   #!+sb-doc
-  "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
+  "Return cos(Theta) + i sin(Theta), i.e. exp(i Theta)."
   (declare (type real theta))
   (complex (cos theta) (sin theta)))
 
@@ -465,14 +544,14 @@
   (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 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))))
 
@@ -482,14 +561,14 @@
   (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 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))))
 
@@ -498,42 +577,36 @@
   "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 number) (x number))
-	  ((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)))))
-
-;; It seems that everyone has a C version of sinh, cosh, and
-;; tanh. Let's use these for reals because the original
-;; implementations based on the definitions lose big in round-off
-;; error. These bad definitions also mean that sin and cos for
-;; complex numbers can also lose big.
+        (handle-reals %atan y)
+        ((complex)
+         (complex-atan y)))))
 
-#+nil
-(defun sinh (number)
-  #!+sb-doc
-  "Return the hyperbolic sine of NUMBER."
-  (/ (- (exp number) (exp (- number))) 2))
+;;; It seems that every target system has a C version of sinh, cosh,
+;;; and tanh. Let's use these for reals because the original
+;;; implementations based on the definitions lose big in round-off
+;;; error. These bad definitions also mean that sin and cos for
+;;; complex numbers can also lose big.
 
 (defun sinh (number)
   #!+sb-doc
@@ -542,15 +615,9 @@
     (handle-reals %sinh number)
     ((complex)
      (let ((x (realpart number))
-	   (y (imagpart number)))
+           (y (imagpart number)))
        (complex (* (sinh x) (cos y))
-		(* (cosh x) (sin y)))))))
-
-#+nil
-(defun cosh (number)
-  #!+sb-doc
-  "Return the hyperbolic cosine of NUMBER."
-  (/ (+ (exp number) (exp (- number))) 2))
+                (* (cosh x) (sin y)))))))
 
 (defun cosh (number)
   #!+sb-doc
@@ -559,9 +626,9 @@
     (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
@@ -586,13 +653,13 @@
     ((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 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))))
 
@@ -603,25 +670,496 @@
     ((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 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.
+
+;;;; not-OLD-SPECFUN stuff
+;;;;
+;;;; (This was conditional on #-OLD-SPECFUN in the CMU CL sources,
+;;;; but OLD-SPECFUN was mentioned nowhere else, so it seems to be
+;;;; the standard special function system.)
+;;;;
+;;;; This is a set of routines that implement many elementary
+;;;; transcendental functions as specified by ANSI Common Lisp.  The
+;;;; implementation is based on Kahan's paper.
+;;;;
+;;;; I believe I have accurately implemented the routines and are
+;;;; correct, but you may want to check for your self.
+;;;;
+;;;; These functions are written for CMU Lisp and take advantage of
+;;;; some of the features available there.  It may be possible,
+;;;; however, to port this to other Lisps.
+;;;;
+;;;; Some functions are significantly more accurate than the original
+;;;; definitions in CMU Lisp.  In fact, some functions in CMU Lisp
+;;;; give the wrong answer like (acos #c(-2.0 0.0)), where the true
+;;;; answer is pi + i*log(2-sqrt(3)).
+;;;;
+;;;; All of the implemented functions will take any number for an
+;;;; input, but the result will always be a either a complex
+;;;; single-float or a complex double-float.
+;;;;
+;;;; general functions:
+;;;;   complex-sqrt
+;;;;   complex-log
+;;;;   complex-atanh
+;;;;   complex-tanh
+;;;;   complex-acos
+;;;;   complex-acosh
+;;;;   complex-asin
+;;;;   complex-asinh
+;;;;   complex-atan
+;;;;   complex-tan
+;;;;
+;;;; utility functions:
+;;;;   scalb logb
+;;;;
+;;;; internal functions:
+;;;;    square coerce-to-complex-type cssqs complex-log-scaled
+;;;;
+;;;; references:
+;;;;   Kahan, W. "Branch Cuts for Complex Elementary Functions, or Much
+;;;;   Ado About Nothing's Sign Bit" in Iserles and Powell (eds.) "The
+;;;;   State of the Art in Numerical Analysis", pp. 165-211, Clarendon
+;;;;   Press, 1987
+;;;;
+;;;; The original CMU CL code requested:
+;;;;   Please send any bug reports, comments, or improvements to
+;;;;   Raymond Toy at <email address deleted during 2002 spam avalanche>.
+
+;;; FIXME: In SBCL, the floating point infinity constants like
+;;; SB!EXT:DOUBLE-FLOAT-POSITIVE-INFINITY aren't available as
+;;; constants at cross-compile time, because the cross-compilation
+;;; host might not have support for floating point infinities. Thus,
+;;; they're effectively implemented as special variable references,
+;;; and the code below which uses them might be unnecessarily
+;;; inefficient. Perhaps some sort of MAKE-LOAD-TIME-VALUE hackery
+;;; should be used instead?  (KLUDGED 2004-03-08 CSR, by replacing the
+;;; special variable references with (probably equally slow)
+;;; constructors)
+;;;
+;;; FIXME: As of 2004-05, when PFD noted that IMAGPART and COMPLEX
+;;; differ in their interpretations of the real line, IMAGPART was
+;;; patch, which without a certain amount of effort would have altered
+;;; all the branch cut treatment.  Clients of these COMPLEX- routines
+;;; were patched to use explicit COMPLEX, rather than implicitly
+;;; passing in real numbers for treatment with IMAGPART, and these
+;;; COMPLEX- functions altered to require arguments of type COMPLEX;
+;;; however, someone needs to go back to Kahan for the definitive
+;;; answer for treatment of negative real floating point numbers and
+;;; branch cuts.  If adjustment is needed, it is probably the removal
+;;; of explicit calls to COMPLEX in the clients of irrational
+;;; functions.  -- a slightly bitter CSR, 2004-05-16
+
+(declaim (inline square))
+(defun square (x)
+  (declare (double-float x))
+  (* x x))
+
+;;; original CMU CL comment, apparently re. SCALB and LOGB and
+;;; perhaps CSSQS:
+;;;   If you have these functions in libm, perhaps they should be used
+;;;   instead of these Lisp versions. These versions are probably good
+;;;   enough, especially since they are portable.
+
+;;; Compute 2^N * X without computing 2^N first. (Use properties of
+;;; the underlying floating-point format.)
+(declaim (inline scalb))
+(defun scalb (x n)
+  (declare (type double-float x)
+           (type double-float-exponent n))
+  (scale-float x n))
+
+;;; This is like LOGB, but X is not infinity and non-zero and not a
+;;; NaN, so we can always return an integer.
+(declaim (inline logb-finite))
+(defun logb-finite (x)
+  (declare (type double-float x))
+  (multiple-value-bind (signif exponent sign)
+      (decode-float x)
+    (declare (ignore signif sign))
+    ;; DECODE-FLOAT is almost right, except that the exponent is off
+    ;; by one.
+    (1- exponent)))
+
+;;; Compute an integer N such that 1 <= |2^N * x| < 2.
+;;; For the special cases, the following values are used:
+;;;    x             logb
+;;;   NaN            NaN
+;;;   +/- infinity   +infinity
+;;;   0              -infinity
+(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
+          ;; signal divide-by-zero, so do the actual division
+         (/ -1.0d0 x)
+         )
+        (t
+          (logb-finite x))))
+
+;;; This function is used to create a complex number of the
+;;; appropriate type:
+;;;   Create complex number with real part X and imaginary part Y
+;;;   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"))
+(declaim (inline coerce-to-complex-type))
+(defun coerce-to-complex-type (x y z)
+  (declare (double-float x y)
+           (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))))
+
+;;; 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"))
+(defun cssqs (z)
+  (let ((x (float (realpart 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
+    ;; signal would have been raised.
+    (with-float-traps-masked (:underflow :overflow)
+      (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)
+                    (load-time-value
+                     #!-long-float
+                     (sb!kernel:make-double-float #x1fffff #xfffffffe)
+                     #!+long-float
+                     (error "(/ least-positive-long-float long-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))))
+              ;; If we're here, neither x nor y are infinity and at
+              ;; least one is non-zero.. Thus logb returns a nice
+              ;; integer.
+              (let ((k (- (logb-finite (max (abs x) (abs y))))))
+                (values (+ (square (scalb x k))
+                           (square (scalb y k)))
+                        (- k))))
+             (t
+              (values rho 0)))))))
+
+;;; principal square root of Z
+;;;
+;;; Z may be RATIONAL or COMPLEX; the result is always a COMPLEX.
+(defun complex-sqrt (z)
+  ;; KLUDGE: Here and below, we can't just declare Z to be of type
+  ;; COMPLEX, because one-arg COMPLEX on rationals returns a rational.
+  ;; Since there isn't a rational negative zero, this is OK from the
+  ;; point of view of getting the right answer in the face of branch
+  ;; cuts, but declarations of the form (OR RATIONAL COMPLEX) are
+  ;; still ugly.  -- CSR, 2004-05-16
+  (declare (type (or complex rational) z))
+  (multiple-value-bind (rho k)
+      (cssqs z)
+    (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))
+      (declare (double-float x y eta nu))
+
+      (locally
+         ;; space 0 to get maybe-inline functions inlined.
+         (declare (optimize (speed 3) (space 0)))
+
+      (if (not (float-nan-p x))
+          (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 rho (scalb (sqrt rho) k))
+
+      (setf eta rho)
+      (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))))
+       (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))
+  ;; 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 (load-time-value
+             #!-long-float
+             (sb!kernel:make-double-float #x3fe6a09e #x667f3bcd)
+             #!+long-float
+             (error "(/ (sqrt 2l0))")))
+        ;; KLUDGE: if repeatable fasls start failing under some weird
+        ;; xc host, this 1.2d0 might be a good place to examine: while
+        ;; it _should_ be the same in all vaguely-IEEE754 hosts, 1.2
+        ;; is not exactly representable, so something could go wrong.
+        (t1 1.2d0)
+        (t2 3d0)
+        (ln2 (load-time-value
+              #!-long-float
+              (sb!kernel:make-double-float #x3fe62e42 #xfefa39ef)
+              #!+long-float
+              (error "(log 2l0)")))
+        (x (float (realpart z) 1.0d0))
+        (y (float (imagpart z) 1.0d0)))
+    (multiple-value-bind (rho k)
+        (cssqs z)
+      (declare (optimize (speed 3)))
+      (let ((beta (max (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)))
+                                  (/ (%log1p (+ (* (- beta 1.0d0)
+                                       (+ beta 1.0d0))
+                                    (* theta theta)))
+                                     2d0)
+                                  (+ (/ (log rho) 2d0)
+                                     (* (+ k j) ln2)))
+                                (atan y x)
+                                z)))))
+
+;;; log of Z = log |Z| + i * arg Z
+;;;
+;;; Z may be any number, but the result is always a complex.
+(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
+;;; i*y is never 0 since we have positive and negative zeroes. -- rtoy
+;;; Compute atanh z = (log(1+z) - log(1-z))/2.
+(defun complex-atanh (z)
+  (declare (type (or rational complex) z))
+  (let* (;; constants
+         (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))
+    ;; 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)))
+              ;; 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))))))))
+    (coerce-to-complex-type (* beta eta)
+                            (- (* 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)))
+    (locally
+      ;; space 0 to get maybe-inline functions inlined
+      (declare (optimize (speed 3) (space 0)))
+    (cond ((> (abs x)
+              (load-time-value
+               #!-long-float
+               (sb!kernel:make-double-float #x406633ce #x8fb9f87e)
+               #!+long-float
+               (error "(/ (+ (log 2l0) (log most-positive-long-float)) 4l0)")))
+           (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.
+;;;
+;;; Z may be any NUMBER, but the result is always a COMPLEX.
+(defun complex-acos (z)
+  ;; Kahan says we should only compute the parts needed.  Thus, the
+  ;; REALPART's below should only compute the real part, not the whole
+  ;; complex expression.  Doing this can be important because we may get
+  ;; spurious signals that occur in the part that we are not using.
+  ;;
+  ;; However, we take a pragmatic approach and just use the whole
+  ;; expression.
+  ;;
+  ;; NOTE: The formula given by Kahan is somewhat ambiguous in whether
+  ;; it's the conjugate of the square root or the square root of the
+  ;; conjugate.  This needs to be checked.
+  ;;
+  ;; I checked.  It doesn't matter because (conjugate (sqrt z)) is the
+  ;; same as (sqrt (conjugate z)) for all z.  This follows because
+  ;;
+  ;; (conjugate (sqrt z)) = exp(0.5*log |z|)*exp(-0.5*j*arg z).
+  ;;
+  ;; (sqrt (conjugate z)) = exp(0.5*log|z|)*exp(0.5*j*arg conj z)
+  ;;
+  ;; and these two expressions are equal if and only if arg conj 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))))
+    (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)))))))
+
+;;; Compute acosh z = 2 * log(sqrt((z+1)/2) + sqrt((z-1)/2))
+;;;
+;;; Z may be any NUMBER, but the result is always a COMPLEX.
+(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))))
+    (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))))))))
+
+;;; Compute asin z = asinh(i*z)/i.
+;;;
+;;; Z may be any NUMBER, but the result is always a COMPLEX.
+(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))))
+    (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)))))))
+
+;;; Compute asinh z = log(z + sqrt(1 + z*z)).
+;;;
+;;; Z may be any number, but the result is always a complex.
+(defun complex-asinh (z)
+  (declare (type (or rational complex) z))
+  ;; asinh z = -i * asin (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+         (result (complex-asin iz)))
+    (complex (imagpart result)
+             (- (realpart result)))))
 
-#!+hpux
-#!-sb-fluid (declaim (inline %log1p))
-#!+hpux
-(defun %log1p (number)
-  (declare (double-float number)
-	   (optimize (speed 3) (safety 0)))
-  (the double-float (log (the (double-float 0d0) (+ number 1d0)))))
+;;; Compute atan z = atanh (i*z) / i.
+;;;
+;;; Z may be any number, but the result is always a complex.
+(defun complex-atan (z)
+  (declare (type (or rational complex) z))
+  ;; atan z = -i * atanh (i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+         (result (complex-atanh iz)))
+    (complex (imagpart result)
+             (- (realpart result)))))
 
+;;; Compute tan z = -i * tanh(i * z)
+;;;
+;;; Z may be any number, but the result is always a complex.
+(defun complex-tan (z)
+  (declare (type (or rational complex) z))
+  ;; tan z = -i * tanh(i*z)
+  (let* ((iz (complex (- (imagpart z)) (realpart z)))
+         (result (complex-tanh iz)))
+    (complex (imagpart result)
+             (- (realpart result)))))