Changeset 15685 for release/1.9/source/lib/numbers.lisp
 Timestamp:
 Feb 4, 2013, 6:52:19 PM (6 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/1.9/source/lib/numbers.lisp
r14665 r15685 641 641 (defun signum (x) 642 642 "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." 643 (cond ((complexp x) (if (zerop x) x (/ x (abs x)))) 643 (cond ((complexp x) (if (zerop x) 644 x 645 (let ((m (max (abs (realpart x)) 646 (abs (imagpart x))))) 647 (cond ((rationalp m) 648 ;; rescale to avoid intermediate under/overflow 649 (setq x (/ x m))) 650 ((> m #.(ash 1 23)) 651 ;; ensure no overflow for abs 652 (setq x (/ x 2)))) 653 (/ x (abs x))))) 644 654 ((rationalp x) (if (plusp x) 1 (if (zerop x) 0 1))) 645 655 ((zerop x) (float 0.0 x)) … … 678 688 "Return the hyperbolic sine of NUMBER." 679 689 (if (complexp x) 680 (/ ( (exp x) (exp ( x))) 2) 690 (let ((r (realpart x)) 691 (i (imagpart x))) 692 (complex (* (sinh r) (cos i)) 693 (* (cosh r) (sin i)))) 681 694 (if (typep x 'doublefloat) 682 695 (%doublefloatsinh! x (%makedfloat)) … … 691 704 "Return the hyperbolic cosine of NUMBER." 692 705 (if (complexp x) 693 (/ (+ (exp x) (exp ( x))) 2) 706 (let ((r (realpart x)) 707 (i (imagpart x))) 708 (complex (* (cosh r) (cos i)) 709 (* (sinh r) (sin i)))) 694 710 (if (typep x 'doublefloat) 695 711 (%doublefloatcosh! x (%makedfloat)) … … 702 718 (defun tanh (x) 703 719 "Return the hyperbolic tangent of NUMBER." 704 (if (complexp x) 705 (/ (sinh x) (cosh x)) 706 (if (typep x 'doublefloat) 707 (%doublefloattanh! x (%makedfloat)) 708 #+32bittarget 709 (target::withstackshortfloats ((sx x)) 710 (%singlefloattanh! sx (%makesfloat))) 711 #+64bittarget 712 (%singlefloattanh (%shortfloat x))))) 720 (cond ((complexp x) 721 (let ((r (realpart x)) 722 (i (imagpart x))) 723 (if (zerop r) 724 (complex r (tan i)) 725 (let* ((tx (tanh r)) 726 (ty (tan i)) 727 (ty2 (* ty ty)) 728 (d (1+ (* (* tx tx) ty2))) 729 (n (if (> (abs r) 20) 730 (* 4 (exp ( (* 2 (abs r))))) 731 (let ((c (cosh r))) 732 (/ (* c c)))))) 733 (complex (/ (* tx (1+ ty2)) d) 734 (/ (* n ty) d)))))) 735 ((typep x 'doublefloat) 736 (%doublefloattanh! x (%makedfloat))) 737 ((and (typep x 'rational) 738 (> (abs x) 12)) 739 (if (plusp x) 1.0s0 1.0s0)) 740 (t 741 #+32bittarget 742 (target::withstackshortfloats ((sx x)) 743 (%singlefloattanh! sx (%makesfloat))) 744 #+64bittarget 745 (%singlefloattanh (%shortfloat x))))) 713 746 714 747 (defun asinh (x) 715 748 "Return the hyperbolic arc sine of NUMBER." 716 (if (complexp x) 717 (log (+ x (sqrt (+ 1 (* x x))))) 718 (if (typep x 'doublefloat) 719 (%doublefloatasinh! x (%makedfloat)) 720 #+32bittarget 721 (target::withstackshortfloats ((sx x)) 722 (%singlefloatasinh! sx (%makesfloat))) 723 #+64bittarget 724 (%singlefloatasinh (%shortfloat x))))) 725 749 (cond ((typep x 'doublefloat) 750 (%doublefloatasinh! x (%makedfloat))) 751 ((typep x 'shortfloat) 752 #+32bittarget 753 (%singlefloatasinh! x (%makesfloat)) 754 #+64bittarget 755 (%singlefloatasinh (%shortfloat x))) 756 ((typep x 'rational) 757 (if (< (abs x) mostpositiveshortfloat) 758 #+32bittarget 759 (target::withstackshortfloats ((sx x)) 760 (%singlefloatasinh! sx (%makesfloat))) 761 #+64bittarget 762 (%singlefloatasinh (%shortfloat x)) 763 (* (signum x) (loge (* 2 (abs x)))))) 764 (t 765 (i* (%complexasin/acos (i* x) nil) 1)))) 766 767 ;;; for complex case, use acos and postfix the branch cut 726 768 (defun acosh (x) 727 769 "Return the hyperbolic arc cosine of NUMBER." 728 (if (and (realp x) (<= 1.0 x)) 729 (if (typep x 'doublefloat) 730 (%doublefloatacosh! x (%makedfloat)) 731 #+32bittarget 732 (target::withstackshortfloats ((sx x)) 733 (%singlefloatacosh! sx (%makesfloat))) 734 #+64bittarget 735 (%singlefloatacosh (%shortfloat x))) 736 (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1 x) 2))))))) 770 (cond ((and (typep x 'doublefloat) 771 (locally (declare (type doublefloat x)) 772 (<= 1.0d0 x))) 773 (%doublefloatacosh! x (%makedfloat))) 774 ((and (typep x 'shortfloat) 775 (locally (declare (type shortfloat x)) 776 (<= 1.0s0 x))) 777 #+32bittarget 778 (%singlefloatacosh! x (%makesfloat)) 779 #+64bittarget 780 (%singlefloatacosh (%shortfloat x))) 781 ((and (typep x 'rational) 782 (<= 1 x)) 783 (cond ((< x 2) 784 (log1+ (+ ( x 1) (sqrt ( (* x x) 1))))) 785 ((<= x mostpositiveshortfloat) 786 #+32bittarget 787 (target::withstackshortfloats ((x1 x)) 788 (%singlefloatacosh! x1 (%makesfloat))) 789 #+64bittarget 790 (%singlefloatacosh (%shortfloat x))) 791 (t 792 (loge (* 2 x))))) 793 (t 794 (let ((sign (and (typep x 'complex) 795 (let ((ix (imagpart x))) 796 (typecase ix 797 (doublefloat (%doublefloatsign ix)) 798 (singlefloat (%shortfloatsign ix)) 799 (t (minusp ix))))))) 800 (i* (%complexasin/acos x t) (if sign 1 1)))))) 737 801 738 802 (defun atanh (x) 739 803 "Return the hyperbolic arc tangent of NUMBER." 740 (if (and (realp x) (<= 1.0 (setq x (float x)) 1.0)) 741 (if (typep x 'doublefloat) 742 (%doublefloatatanh! x (%makedfloat)) 743 #+32bittarget 744 (%singlefloatatanh! x (%makesfloat)) 745 #+64bittarget 746 (%singlefloatatanh x)) 747 (/ ( (log (+ 1 x)) (log ( 1 x))) 2))) 804 (cond ((and (typep x 'doublefloat) 805 (locally (declare (type doublefloat x)) 806 (and (<= 1.0d0 x) 807 (<= x 1.0d0)))) 808 (%doublefloatatanh! x (%makedfloat))) 809 ((and (typep x 'shortfloat) 810 (locally (declare (type shortfloat x)) 811 (and (<= 1.0s0 x) 812 (<= x 1.0s0)))) 813 #+32bittarget 814 (%singlefloatatanh! x (%makesfloat)) 815 #+64bittarget 816 (%singlefloatatanh x)) 817 ((and (typep x 'rational) 818 (<= (abs x) 1)) 819 (let ((n (numerator x)) 820 (d (denominator x))) 821 (/ (loge (/ (+ d n) ( d n))) 2))) 822 (t 823 (let ((r (realpart x))) 824 (if (zerop r) 825 (complex r (atan (imagpart x))) 826 (%complexatanh x)))))) 748 827 749 828 (defun ffloor (number &optional divisor)
Note: See TracChangeset
for help on using the changeset viewer.