X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Firrat.lisp;h=86940c3f41e02c06996774893e8208010772862c;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=ac8b805d9cf32289599fa64a0a21325fe9a5cb19;hpb=9728093863d1ed201719d1f7ef61b9df29bb1d44;p=sbcl.git

diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index ac8b805..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:define-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,6 +44,26 @@
 
 ) ; EVAL-WHEN
 
+#!+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)))
+
 ;;;; stubs for the Unix math library
 ;;;;
 ;;;; Many of these are unnecessary on the X86 because they're built
@@ -49,25 +73,84 @@
 #!-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)
+#!-(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)
+
+#!+win32
+(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
 
@@ -78,14 +161,12 @@
     (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
@@ -93,24 +174,21 @@
 ;;; 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
@@ -122,176 +200,248 @@
   #!+sb-doc
   "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
@@ -299,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))))
 
@@ -319,16 +469,16 @@
      (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
@@ -339,16 +489,16 @@
   (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)))))
 
@@ -359,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
@@ -370,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
@@ -394,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))))
 
@@ -411,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))))
 
@@ -427,36 +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)))))
+        (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.
+;;; 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
@@ -465,9 +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)))))))
+                (* (cosh x) (sin y)))))))
 
 (defun cosh (number)
   #!+sb-doc
@@ -476,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
@@ -503,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))))
 
@@ -520,29 +670,17 @@
     ((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.
-;;; 
-;;; 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
-#!-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)))))
 
 ;;;; not-OLD-SPECFUN stuff
 ;;;;
@@ -605,7 +743,22 @@
 ;;; 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?
+;;; 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)
@@ -623,7 +776,7 @@
 (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
@@ -647,15 +800,16 @@
 (defun logb (x)
   (declare (type double-float x))
   (cond ((float-nan-p x)
-	 x)
-	((float-infinity-p x)
-	 sb!ext:double-float-positive-infinity)
-	((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
@@ -664,24 +818,26 @@
 ;;;   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))
-  (if (subtypep (type-of (realpart z)) 'double-float)
+           (number z))
+  (if (typep (realpart z) 'double-float)
       (complex x y)
-      ;; Convert anything that's not a DOUBLE-FLOAT to a SINGLE-FLOAT.
+      ;; 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
@@ -690,20 +846,28 @@
       (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))))
-              (values sb!ext:double-float-positive-infinity 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)
+                    (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))))
+               (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.
@@ -716,17 +880,23 @@
 
 ;;; principal square root of Z
 ;;;
-;;; Z may be any NUMBER, but the result is always a COMPLEX.
+;;; Z may be RATIONAL or COMPLEX; the result is always a COMPLEX.
 (defun complex-sqrt (z)
-  (declare (number 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))
+          (y (float (imagpart z) 1.0d0))
+          (eta 0d0)
+          (nu 0d0))
       (declare (double-float x y eta nu))
 
       (locally
@@ -734,13 +904,13 @@
          (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))
 
@@ -748,42 +918,54 @@
       (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 (number z)
-	   (fixnum 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 #.(/ 1 (sqrt 2.0d0)))
-	(t1 1.2d0)
-	(t2 3d0)
-	(ln2 #.(log 2d0))
-	(x (float (realpart z) 1.0d0))
-	(y (float (imagpart z) 1.0d0)))
+  (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)
+        (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)))
@@ -794,99 +976,99 @@
 ;;;
 ;;; Z may be any number, but the result is always a complex.
 (defun complex-log (z)
-  (declare (number 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 (number 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))
+         (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 eta (float-sign y half-pi))
-	   ;; nu 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 nu (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 (number 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)
-	      #-(or linux hpux) #.(/ (asinh most-positive-double-float) 4d0)
-	      ;; This is more accurate under linux.
-	      #+(or linux hpux) #.(/ (+ (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)
+              (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.
@@ -914,70 +1096,70 @@
   ;;
   ;; and these two expressions are equal if and only if arg conj z =
   ;; -arg z, which is clearly true for all z.
-  (declare (number 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))
 ;;;
 ;;; Z may be any NUMBER, but the result is always a COMPLEX.
 (defun complex-acosh (z)
-  (declare (number 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.
 ;;;
 ;;; Z may be any NUMBER, but the result is always a COMPLEX.
 (defun complex-asin (z)
-  (declare (number 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)).
 ;;;
 ;;; Z may be any number, but the result is always a complex.
 (defun complex-asinh (z)
-  (declare (number 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.
 (defun complex-atan (z)
-  (declare (number z))
+  (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)
 ;;;
 ;;; Z may be any number, but the result is always a complex.
 (defun complex-tan (z)
-  (declare (number 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)))))