src/code/irrat.lisp

   1 ;;;; This file contains all the irrational functions. (Actually, most
   2 ;;;; of the work is done by calling out to C.)
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!KERNEL")
  14 \f
  15 ;;;; miscellaneous constants, utility functions, and macros
  16
  17 (defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
  18 ;(defconstant e 2.71828182845904523536028747135266249775724709369996L0)
  19
  20 ;;; Make these INLINE, since the call to C is at least as compact as a
  21 ;;; Lisp call, and saves number consing to boot.
  22 (eval-when (:compile-toplevel :execute)
  23
  24 (sb!xc:defmacro def-math-rtn (name num-args)
  25   (let ((function (symbolicate "%" (string-upcase name))))
  26     `(progn
  27        (proclaim '(inline ,function))
  28        (sb!alien:def-alien-routine (,name ,function) double-float
  29          ,@(let ((results nil))
  30              (dotimes (i num-args (nreverse results))
  31                (push (list (intern (format nil "ARG-~D" i))
  32                            'double-float)
  33                      results)))))))
  34
  35 (defun handle-reals (function var)
  36   `((((foreach fixnum single-float bignum ratio))
  37      (coerce (,function (coerce ,var 'double-float)) 'single-float))
  38     ((double-float)
  39      (,function ,var))))
  40
  41 ) ; EVAL-WHEN
  42 \f
  43 ;;;; stubs for the Unix math library
  44
  45 ;;; Please refer to the Unix man pages for details about these routines.
  46
  47 ;;; Trigonometric.
  48 #!-x86 (def-math-rtn "sin" 1)
  49 #!-x86 (def-math-rtn "cos" 1)
  50 #!-x86 (def-math-rtn "tan" 1)
  51 (def-math-rtn "asin" 1)
  52 (def-math-rtn "acos" 1)
  53 #!-x86 (def-math-rtn "atan" 1)
  54 #!-x86 (def-math-rtn "atan2" 2)
  55 (def-math-rtn "sinh" 1)
  56 (def-math-rtn "cosh" 1)
  57 (def-math-rtn "tanh" 1)
  58 (def-math-rtn "asinh" 1)
  59 (def-math-rtn "acosh" 1)
  60 (def-math-rtn "atanh" 1)
  61
  62 ;;; Exponential and Logarithmic.
  63 #!-x86 (def-math-rtn "exp" 1)
  64 #!-x86 (def-math-rtn "log" 1)
  65 #!-x86 (def-math-rtn "log10" 1)
  66 (def-math-rtn "pow" 2)
  67 #!-x86 (def-math-rtn "sqrt" 1)
  68 (def-math-rtn "hypot" 2)
  69 #!-(or hpux x86) (def-math-rtn "log1p" 1)
  70
  71 #!+x86 ;; These are needed for use by byte-compiled files.
  72 (progn
  73   (defun %sin (x)
  74     (declare (double-float x)
  75              (values double-float))
  76     (%sin x))
  77   (defun %sin-quick (x)
  78     (declare (double-float x)
  79              (values double-float))
  80     (%sin-quick x))
  81   (defun %cos (x)
  82     (declare (double-float x)
  83              (values double-float))
  84     (%cos x))
  85   (defun %cos-quick (x)
  86     (declare (double-float x)
  87              (values double-float))
  88     (%cos-quick x))
  89   (defun %tan (x)
  90     (declare (double-float x)
  91              (values double-float))
  92     (%tan x))
  93   (defun %tan-quick (x)
  94     (declare (double-float x)
  95              (values double-float))
  96     (%tan-quick x))
  97   (defun %atan (x)
  98     (declare (double-float x)
  99              (values double-float))
 100     (%atan x))
 101   (defun %atan2 (x y)
 102     (declare (double-float x y)
 103              (values double-float))
 104     (%atan2 x y))
 105   (defun %exp (x)
 106     (declare (double-float x)
 107              (values double-float))
 108     (%exp x))
 109   (defun %log (x)
 110     (declare (double-float x)
 111              (values double-float))
 112     (%log x))
 113   (defun %log10 (x)
 114     (declare (double-float x)
 115              (values double-float))
 116     (%log10 x))
 117   #+nil ;; notyet
 118   (defun %pow (x y)
 119     (declare (type (double-float 0d0) x)
 120              (double-float y)
 121              (values (double-float 0d0)))
 122     (%pow x y))
 123   (defun %sqrt (x)
 124     (declare (double-float x)
 125              (values double-float))
 126     (%sqrt x))
 127   (defun %scalbn (f ex)
 128     (declare (double-float f)
 129              (type (signed-byte 32) ex)
 130              (values double-float))
 131     (%scalbn f ex))
 132   (defun %scalb (f ex)
 133     (declare (double-float f ex)
 134              (values double-float))
 135     (%scalb f ex))
 136   (defun %logb (x)
 137     (declare (double-float x)
 138              (values double-float))
 139     (%logb x))
 140   (defun %log1p (x)
 141     (declare (double-float x)
 142              (values double-float))
 143     (%log1p x))
 144   ) ; progn
 145 \f
 146 ;;;; power functions
 147
 148 (defun exp (number)
 149   #!+sb-doc
 150   "Return e raised to the power NUMBER."
 151   (number-dispatch ((number number))
 152     (handle-reals %exp number)
 153     ((complex)
 154      (* (exp (realpart number))
 155         (cis (imagpart number))))))
 156
 157 ;;; INTEXP -- Handle the rational base, integer power case.
 158
 159 ;;; FIXME: As long as the
 160 ;;; system dies on stack overflow or memory exhaustion, it seems reasonable
 161 ;;; to have this, but its default should be NIL, and when it's NIL,
 162 ;;; anything should be accepted.
 163 (defparameter *intexp-maximum-exponent* 10000)
 164
 165 ;;; This function precisely calculates base raised to an integral power. It
 166 ;;; separates the cases by the sign of power, for efficiency reasons, as powers
 167 ;;; can be calculated more efficiently if power is a positive integer. Values
 168 ;;; of power are calculated as positive integers, and inverted if negative.
 169 (defun intexp (base power)
 170   (when (> (abs power) *intexp-maximum-exponent*)
 171     ;; FIXME: should be ordinary error, not CERROR. (Once we set the
 172     ;; default for the variable to NIL, the un-continuable error will
 173     ;; be less obnoxious.)
 174     (cerror "Continue with calculation."
 175             "The absolute value of ~S exceeds ~S."
 176             power '*intexp-maximum-exponent* base power))
 177   (cond ((minusp power)
 178          (/ (intexp base (- power))))
 179         ((eql base 2)
 180          (ash 1 power))
 181         (t
 182          (do ((nextn (ash power -1) (ash power -1))
 183               (total (if (oddp power) base 1)
 184                      (if (oddp power) (* base total) total)))
 185              ((zerop nextn) total)
 186            (setq base (* base base))
 187            (setq power nextn)))))
 188
 189 ;;; If an integer power of a rational, use INTEXP above. Otherwise, do
 190 ;;; floating point stuff. If both args are real, we try %POW right off,
 191 ;;; assuming it will return 0 if the result may be complex. If so, we call
 192 ;;; COMPLEX-POW which directly computes the complex result. We also separate
 193 ;;; the complex-real and real-complex cases from the general complex case.
 194 (defun expt (base power)
 195   #!+sb-doc
 196   "Returns BASE raised to the POWER."
 197   (if (zerop power)
 198       (1+ (* base power))
 199     (labels (;; determine if the double float is an integer.
 200              ;;  0 - not an integer
 201              ;;  1 - an odd int
 202              ;;  2 - an even int
 203              (isint (ihi lo)
 204                (declare (type (unsigned-byte 31) ihi)
 205                         (type (unsigned-byte 32) lo)
 206                         (optimize (speed 3) (safety 0)))
 207                (let ((isint 0))
 208                  (declare (type fixnum isint))
 209                  (cond ((>= ihi #x43400000)     ; exponent >= 53
 210                         (setq isint 2))
 211                        ((>= ihi #x3ff00000)
 212                         (let ((k (- (ash ihi -20) #x3ff)))      ; exponent
 213                           (declare (type (mod 53) k))
 214                           (cond ((> k 20)
 215                                  (let* ((shift (- 52 k))
 216                                         (j (logand (ash lo (- shift))))
 217                                         (j2 (ash j shift)))
 218                                    (declare (type (mod 32) shift)
 219                                             (type (unsigned-byte 32) j j2))
 220                                    (when (= j2 lo)
 221                                      (setq isint (- 2 (logand j 1))))))
 222                                 ((= lo 0)
 223                                  (let* ((shift (- 20 k))
 224                                         (j (ash ihi (- shift)))
 225                                         (j2 (ash j shift)))
 226                                    (declare (type (mod 32) shift)
 227                                             (type (unsigned-byte 31) j j2))
 228                                    (when (= j2 ihi)
 229                                      (setq isint (- 2 (logand j 1))))))))))
 230                  isint))
 231              (real-expt (x y rtype)
 232                (let ((x (coerce x 'double-float))
 233                      (y (coerce y 'double-float)))
 234                  (declare (double-float x y))
 235                  (let* ((x-hi (sb!kernel:double-float-high-bits x))
 236                         (x-lo (sb!kernel:double-float-low-bits x))
 237                         (x-ihi (logand x-hi #x7fffffff))
 238                         (y-hi (sb!kernel:double-float-high-bits y))
 239                         (y-lo (sb!kernel:double-float-low-bits y))
 240                         (y-ihi (logand y-hi #x7fffffff)))
 241                    (declare (type (signed-byte 32) x-hi y-hi)
 242                             (type (unsigned-byte 31) x-ihi y-ihi)
 243                             (type (unsigned-byte 32) x-lo y-lo))
 244                    ;; y==zero: x**0 = 1
 245                    (when (zerop (logior y-ihi y-lo))
 246                      (return-from real-expt (coerce 1d0 rtype)))
 247                    ;; +-NaN return x+y
 248                    (when (or (> x-ihi #x7ff00000)
 249                              (and (= x-ihi #x7ff00000) (/= x-lo 0))
 250                              (> y-ihi #x7ff00000)
 251                              (and (= y-ihi #x7ff00000) (/= y-lo 0)))
 252                      (return-from real-expt (coerce (+ x y) rtype)))
 253                    (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0)))
 254                      (declare (type fixnum yisint))
 255                      ;; special value of y
 256                      (when (and (zerop y-lo) (= y-ihi #x7ff00000))
 257                        ;; y is +-inf
 258                        (return-from real-expt
 259                          (cond ((and (= x-ihi #x3ff00000) (zerop x-lo))
 260                                 ;; +-1**inf is NaN
 261                                 (coerce (- y y) rtype))
 262                                ((>= x-ihi #x3ff00000)
 263                                 ;; (|x|>1)**+-inf = inf,0
 264                                 (if (>= y-hi 0)
 265                                     (coerce y rtype)
 266                                     (coerce 0 rtype)))
 267                                (t
 268                                 ;; (|x|<1)**-,+inf = inf,0
 269                                 (if (< y-hi 0)
 270                                     (coerce (- y) rtype)
 271                                     (coerce 0 rtype))))))
 272
 273                      (let ((abs-x (abs x)))
 274                        (declare (double-float abs-x))
 275                        ;; special value of x
 276                        (when (and (zerop x-lo)
 277                                   (or (= x-ihi #x7ff00000) (zerop x-ihi)
 278                                       (= x-ihi #x3ff00000)))
 279                          ;; x is +-0,+-inf,+-1
 280                          (let ((z (if (< y-hi 0)
 281                                       (/ 1 abs-x)       ; z = (1/|x|)
 282                                       abs-x)))
 283                            (declare (double-float z))
 284                            (when (< x-hi 0)
 285                              (cond ((and (= x-ihi #x3ff00000) (zerop yisint))
 286                                     ;; (-1)**non-int
 287                                     (let ((y*pi (* y pi)))
 288                                       (declare (double-float y*pi))
 289                                       (return-from real-expt
 290                                         (complex
 291                                          (coerce (%cos y*pi) rtype)
 292                                          (coerce (%sin y*pi) rtype)))))
 293                                    ((= yisint 1)
 294                                     ;; (x<0)**odd = -(|x|**odd)
 295                                     (setq z (- z)))))
 296                            (return-from real-expt (coerce z rtype))))
 297
 298                        (if (>= x-hi 0)
 299                            ;; x>0
 300                            (coerce (sb!kernel::%pow x y) rtype)
 301                            ;; x<0
 302                            (let ((pow (sb!kernel::%pow abs-x y)))
 303                              (declare (double-float pow))
 304                              (case yisint
 305                                (1 ; Odd
 306                                 (coerce (* -1d0 pow) rtype))
 307                                (2 ; Even
 308                                 (coerce pow rtype))
 309                                (t ; Non-integer
 310                                 (let ((y*pi (* y pi)))
 311                                   (declare (double-float y*pi))
 312                                   (complex
 313                                    (coerce (* pow (%cos y*pi)) rtype)
 314                                    (coerce (* pow (%sin y*pi)) rtype)))))))))))))
 315       (declare (inline real-expt))
 316       (number-dispatch ((base number) (power number))
 317         (((foreach fixnum (or bignum ratio) (complex rational)) integer)
 318          (intexp base power))
 319         (((foreach single-float double-float) rational)
 320          (real-expt base power '(dispatch-type base)))
 321         (((foreach fixnum (or bignum ratio) single-float)
 322           (foreach ratio single-float))
 323          (real-expt base power 'single-float))
 324         (((foreach fixnum (or bignum ratio) single-float double-float)
 325           double-float)
 326          (real-expt base power 'double-float))
 327         ((double-float single-float)
 328          (real-expt base power 'double-float))
 329         (((foreach (complex rational) (complex float)) rational)
 330          (* (expt (abs base) power)
 331             (cis (* power (phase base)))))
 332         (((foreach fixnum (or bignum ratio) single-float double-float)
 333           complex)
 334          (if (and (zerop base) (plusp (realpart power)))
 335              (* base power)
 336              (exp (* power (log base)))))
 337         (((foreach (complex float) (complex rational))
 338           (foreach complex double-float single-float))
 339          (if (and (zerop base) (plusp (realpart power)))
 340              (* base power)
 341              (exp (* power (log base)))))))))
 342
 343 (defun log (number &optional (base nil base-p))
 344   #!+sb-doc
 345   "Return the logarithm of NUMBER in the base BASE, which defaults to e."
 346   (if base-p
 347       (if (zerop base)
 348           base                          ; ANSI spec
 349           (/ (log number) (log base)))
 350       (number-dispatch ((number number))
 351         (((foreach fixnum bignum ratio))
 352          (if (minusp number)
 353              (complex (log (- number)) (coerce pi 'single-float))
 354              (coerce (%log (coerce number 'double-float)) 'single-float)))
 355         (((foreach single-float double-float))
 356          ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)?
 357          ;; Since this doesn't seem to be an implementation issue
 358          ;; I (pw) take the Kahan result.
 359          (if (< (float-sign number)
 360                 (coerce 0 '(dispatch-type number)))
 361              (complex (log (- number)) (coerce pi '(dispatch-type number)))
 362              (coerce (%log (coerce number 'double-float))
 363                      '(dispatch-type number))))
 364         ((complex)
 365          (complex-log number)))))
 366
 367 (defun sqrt (number)
 368   #!+sb-doc
 369   "Return the square root of NUMBER."
 370   (number-dispatch ((number number))
 371     (((foreach fixnum bignum ratio))
 372      (if (minusp number)
 373          (complex-sqrt number)
 374          (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
 375     (((foreach single-float double-float))
 376      (if (minusp number)
 377          (complex-sqrt number)
 378          (coerce (%sqrt (coerce number 'double-float))
 379                  '(dispatch-type number))))
 380      ((complex)
 381       (complex-sqrt number))))
 382 \f
 383 ;;;; trigonometic and related functions
 384
 385 (defun abs (number)
 386   #!+sb-doc
 387   "Returns the absolute value of the number."
 388   (number-dispatch ((number number))
 389     (((foreach single-float double-float fixnum rational))
 390      (abs number))
 391     ((complex)
 392      (let ((rx (realpart number))
 393            (ix (imagpart number)))
 394        (etypecase rx
 395          (rational
 396           (sqrt (+ (* rx rx) (* ix ix))))
 397          (single-float
 398           (coerce (%hypot (coerce rx 'double-float)
 399                           (coerce ix 'double-float))
 400                   'single-float))
 401          (double-float
 402           (%hypot rx ix)))))))
 403
 404 (defun phase (number)
 405   #!+sb-doc
 406   "Returns the angle part of the polar representation of a complex number.
 407   For complex numbers, this is (atan (imagpart number) (realpart number)).
 408   For non-complex positive numbers, this is 0. For non-complex negative
 409   numbers this is PI."
 410   (etypecase number
 411     (rational
 412      (if (minusp number)
 413          (coerce pi 'single-float)
 414          0.0f0))
 415     (single-float
 416      (if (minusp (float-sign number))
 417          (coerce pi 'single-float)
 418          0.0f0))
 419     (double-float
 420      (if (minusp (float-sign number))
 421          (coerce pi 'double-float)
 422          0.0d0))
 423     (complex
 424      (atan (imagpart number) (realpart number)))))
 425
 426 (defun sin (number)
 427   #!+sb-doc
 428   "Return the sine of NUMBER."
 429   (number-dispatch ((number number))
 430     (handle-reals %sin number)
 431     ((complex)
 432      (let ((x (realpart number))
 433            (y (imagpart number)))
 434        (complex (* (sin x) (cosh y))
 435                 (* (cos x) (sinh y)))))))
 436
 437 (defun cos (number)
 438   #!+sb-doc
 439   "Return the cosine of NUMBER."
 440   (number-dispatch ((number number))
 441     (handle-reals %cos number)
 442     ((complex)
 443      (let ((x (realpart number))
 444            (y (imagpart number)))
 445        (complex (* (cos x) (cosh y))
 446                 (- (* (sin x) (sinh y))))))))
 447
 448 (defun tan (number)
 449   #!+sb-doc
 450   "Return the tangent of NUMBER."
 451   (number-dispatch ((number number))
 452     (handle-reals %tan number)
 453     ((complex)
 454      (complex-tan number))))
 455
 456 (defun cis (theta)
 457   #!+sb-doc
 458   "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
 459   (if (complexp theta)
 460       (error "Argument to CIS is complex: ~S" theta)
 461       (complex (cos theta) (sin theta))))
 462
 463 (defun asin (number)
 464   #!+sb-doc
 465   "Return the arc sine of NUMBER."
 466   (number-dispatch ((number number))
 467     ((rational)
 468      (if (or (> number 1) (< number -1))
 469          (complex-asin number)
 470          (coerce (%asin (coerce number 'double-float)) 'single-float)))
 471     (((foreach single-float double-float))
 472      (if (or (> number (coerce 1 '(dispatch-type number)))
 473              (< number (coerce -1 '(dispatch-type number))))
 474          (complex-asin number)
 475          (coerce (%asin (coerce number 'double-float))
 476                  '(dispatch-type number))))
 477     ((complex)
 478      (complex-asin number))))
 479
 480 (defun acos (number)
 481   #!+sb-doc
 482   "Return the arc cosine of NUMBER."
 483   (number-dispatch ((number number))
 484     ((rational)
 485      (if (or (> number 1) (< number -1))
 486          (complex-acos number)
 487          (coerce (%acos (coerce number 'double-float)) 'single-float)))
 488     (((foreach single-float double-float))
 489      (if (or (> number (coerce 1 '(dispatch-type number)))
 490              (< number (coerce -1 '(dispatch-type number))))
 491          (complex-acos number)
 492          (coerce (%acos (coerce number 'double-float))
 493                  '(dispatch-type number))))
 494     ((complex)
 495      (complex-acos number))))
 496
 497 (defun atan (y &optional (x nil xp))
 498   #!+sb-doc
 499   "Return the arc tangent of Y if X is omitted or Y/X if X is supplied."
 500   (if xp
 501       (flet ((atan2 (y x)
 502                (declare (type double-float y x)
 503                         (values double-float))
 504                (if (zerop x)
 505                    (if (zerop y)
 506                        (if (plusp (float-sign x))
 507                            y
 508                            (float-sign y pi))
 509                        (float-sign y (/ pi 2)))
 510                    (%atan2 y x))))
 511         (number-dispatch ((y number) (x number))
 512           ((double-float
 513             (foreach double-float single-float fixnum bignum ratio))
 514            (atan2 y (coerce x 'double-float)))
 515           (((foreach single-float fixnum bignum ratio)
 516             double-float)
 517            (atan2 (coerce y 'double-float) x))
 518           (((foreach single-float fixnum bignum ratio)
 519             (foreach single-float fixnum bignum ratio))
 520            (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float))
 521                    'single-float))))
 522       (number-dispatch ((y number))
 523         (handle-reals %atan y)
 524         ((complex)
 525          (complex-atan y)))))
 526
 527 ;; It seems that everyone has a C version of sinh, cosh, and
 528 ;; tanh. Let's use these for reals because the original
 529 ;; implementations based on the definitions lose big in round-off
 530 ;; error. These bad definitions also mean that sin and cos for
 531 ;; complex numbers can also lose big.
 532
 533 #+nil
 534 (defun sinh (number)
 535   #!+sb-doc
 536   "Return the hyperbolic sine of NUMBER."
 537   (/ (- (exp number) (exp (- number))) 2))
 538
 539 (defun sinh (number)
 540   #!+sb-doc
 541   "Return the hyperbolic sine of NUMBER."
 542   (number-dispatch ((number number))
 543     (handle-reals %sinh number)
 544     ((complex)
 545      (let ((x (realpart number))
 546            (y (imagpart number)))
 547        (complex (* (sinh x) (cos y))
 548                 (* (cosh x) (sin y)))))))
 549
 550 #+nil
 551 (defun cosh (number)
 552   #!+sb-doc
 553   "Return the hyperbolic cosine of NUMBER."
 554   (/ (+ (exp number) (exp (- number))) 2))
 555
 556 (defun cosh (number)
 557   #!+sb-doc
 558   "Return the hyperbolic cosine of NUMBER."
 559   (number-dispatch ((number number))
 560     (handle-reals %cosh number)
 561     ((complex)
 562      (let ((x (realpart number))
 563            (y (imagpart number)))
 564        (complex (* (cosh x) (cos y))
 565                 (* (sinh x) (sin y)))))))
 566
 567 (defun tanh (number)
 568   #!+sb-doc
 569   "Return the hyperbolic tangent of NUMBER."
 570   (number-dispatch ((number number))
 571     (handle-reals %tanh number)
 572     ((complex)
 573      (complex-tanh number))))
 574
 575 (defun asinh (number)
 576   #!+sb-doc
 577   "Return the hyperbolic arc sine of NUMBER."
 578   (number-dispatch ((number number))
 579     (handle-reals %asinh number)
 580     ((complex)
 581      (complex-asinh number))))
 582
 583 (defun acosh (number)
 584   #!+sb-doc
 585   "Return the hyperbolic arc cosine of NUMBER."
 586   (number-dispatch ((number number))
 587     ((rational)
 588      ;; acosh is complex if number < 1
 589      (if (< number 1)
 590          (complex-acosh number)
 591          (coerce (%acosh (coerce number 'double-float)) 'single-float)))
 592     (((foreach single-float double-float))
 593      (if (< number (coerce 1 '(dispatch-type number)))
 594          (complex-acosh number)
 595          (coerce (%acosh (coerce number 'double-float))
 596                  '(dispatch-type number))))
 597     ((complex)
 598      (complex-acosh number))))
 599
 600 (defun atanh (number)
 601   #!+sb-doc
 602   "Return the hyperbolic arc tangent of NUMBER."
 603   (number-dispatch ((number number))
 604     ((rational)
 605      ;; atanh is complex if |number| > 1
 606      (if (or (> number 1) (< number -1))
 607          (complex-atanh number)
 608          (coerce (%atanh (coerce number 'double-float)) 'single-float)))
 609     (((foreach single-float double-float))
 610      (if (or (> number (coerce 1 '(dispatch-type number)))
 611              (< number (coerce -1 '(dispatch-type number))))
 612          (complex-atanh number)
 613          (coerce (%atanh (coerce number 'double-float))
 614                  '(dispatch-type number))))
 615     ((complex)
 616      (complex-atanh number))))
 617
 618 ;;; HP-UX does not supply a C version of log1p, so
 619 ;;; use the definition.
 620
 621 #!+hpux
 622 #!-sb-fluid (declaim (inline %log1p))
 623 #!+hpux
 624 (defun %log1p (number)
 625   (declare (double-float number)
 626            (optimize (speed 3) (safety 0)))
 627   (the double-float (log (the (double-float 0d0) (+ number 1d0)))))
 628