diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 573dbf6..6a5ce4d 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -382,6 +382,7 @@ exact->inexact inexact floor ceiling round log fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? sin cos tan asin acos atan sqrt exp + sinh cosh tanh asinh acosh atanh flmax random error@add1 error@sub1) (import @@ -408,6 +409,7 @@ fl=? fl? fl>=? fl+ fl- fl* fl/ flsqrt flmin flzero? flnegative? sra sll exp sin cos tan asin acos atan sqrt truncate fltruncate + sinh cosh tanh asinh acosh atanh flmax random)) (define (bignum->flonum x) @@ -2522,7 +2524,11 @@ [(flonum? x) (foreign-call "ikrt_fl_sinh" x)] [(or (fixnum? x) (bignum? x) (ratnum? x)) (sinh (inexact x))] - [(number? x) (error who "not implemented" x)] + [(or (compnum? x) (cflonum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (make-rectangular + (* (sinh r) (cos i)) + (* (cosh r) (sin i))))] [else (die who "not a number" x)]))) (define cosh @@ -2532,7 +2538,11 @@ [(flonum? x) (foreign-call "ikrt_fl_cosh" x)] [(or (fixnum? x) (bignum? x) (ratnum? x)) (cosh (inexact x))] - [(number? x) (error who "not implemented" x)] + [(or (compnum? x) (cflonum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (make-rectangular + (* (cosh r) (cos i)) + (* (sinh r) (sin i))))] [else (die who "not a number" x)]))) (define tanh @@ -2542,7 +2552,13 @@ [(flonum? x) (foreign-call "ikrt_fl_tanh" x)] [(or (fixnum? x) (bignum? x) (ratnum? x)) (tanh (inexact x))] - [(number? x) (error who "not implemented" x)] + [(or (compnum? x) (cflonum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (let ([rr (* 2 r)] [ii (* 2 i)]) + (let ([cos2i (cos ii)] [cosh2r (cosh rr)]) + (make-rectangular + (/ (tanh rr) (+ 1 (/ cos2i cosh2r))) + (/ (sin ii) (+ cosh2r cos2i))))))] [else (die who "not a number" x)]))) (define asinh @@ -2552,7 +2568,22 @@ [(flonum? x) (foreign-call "ikrt_fl_asinh" x)] [(or (fixnum? x) (bignum? x) (ratnum? x)) (asinh (inexact x))] - [(number? x) (error who "not implemented" x)] + [(or (cflonum? x) (compnum? x)) + (let ([x (real-part x)] [y (imag-part x)]) + (cond + [(= x 0) + (let ([v (asin y)]) + (make-rectangular (imag-part v) (real-part v)))] + [else + (let* ([z^2 (+ (* x x) (* y y))] + [z^2-1 (- z^2 1)] + [z^2-1^2 (* z^2-1 z^2-1)] + [y^2 (* y y)] + [q (sqrt (+ z^2-1^2 (* 4 y^2)))]) + (define (sgn x) (if (< x 0) -1 1)) + (make-rectangular + (* 0.5 (sgn x) (acosh (+ q z^2))) + (* 0.5 (sgn y) (acos (- q z^2)))))]))] [else (die who "not a number" x)]))) (define acosh @@ -2569,24 +2600,38 @@ [else +nan.0])] [(or (fixnum? x) (bignum? x) (ratnum? x)) (acosh (inexact x))] - [(number? x) (error who "not implemented" x)] + [(or (cflonum? x) (compnum? x)) + (let ([x (real-part x)] [y (imag-part x)]) + (cond + [(= x 0) (+ (asinh y) (make-rectangular 0 PI/2))] + [else + (let* ([z^2 (+ (* x x) (* y y))] + [z^2-1 (- z^2 1)] + [z^2-1^2 (* z^2-1 z^2-1)] + [y^2 (* y y)] + [q (sqrt (+ z^2-1^2 (* 4 y^2)))]) + (define (sgn x) (if (< x 0) -1 1)) + (+ (* 0.5 (sgn x) (acosh (+ q z^2))) + (* 0.5i (sgn y) + (- PI (* (sgn x) (acos (- q z^2)))))))]))] [else (die who "not a number" x)]))) (define atanh (lambda (x) (define who 'atanh) (cond - [(flonum? x) (foreign-call "ikrt_fl_atanh" x)] + [(flonum? x) + (cond + [(and (fl<=? x 1.0) (fl>=? x -1.0)) + (foreign-call "ikrt_fl_atanh" x)] + [else + (- (atanh (fl/ 1.0 x)) + (if (fl x 1.0) (make-rectangular PI/2 (acosh x))] [($fl< x -1.0) - (make-rectangular (- PI/2) (- (acosh x)))] + (make-rectangular (- PI/2) (- (acosh (- x))))] [else (foreign-call "ikrt_fl_asin" x)])] [(or (cflonum? x) (compnum? x)) - (error 'asin "not implemented for complex arguments")] + (let ([x (real-part x)] [y (imag-part x)]) + (cond + [(= x 0) (make-rectangular 0 (asinh y))] + [else + (let* ([z^2 (+ (* x x) (* y y))] + [z^2-1 (- z^2 1)] + [z^2-1^2 (* z^2-1 z^2-1)] + [y^2 (* y y)] + [q (sqrt (+ z^2-1^2 (* 4 y^2)))]) + (define (sgn x) (if (< x 0) -1 1)) + (make-rectangular + (* 0.5 (sgn x) (acos (- q z^2))) + (* 0.5 (sgn y) (acosh (+ q z^2)))))]))] [(number? x) (asin (inexact x))] [else (die 'asin "not a number" x)]))) @@ -2670,7 +2727,7 @@ [else (foreign-call "ikrt_fl_acos" x)])] [(or (cflonum? x) (compnum? x)) - (error 'acos "not implemented for complex arguments")] + (- PI/2 (asin x))] [(number? x) (acos (inexact x))] [else (die 'acos "not a number" x)]))) diff --git a/scheme/last-revision b/scheme/last-revision index 5882485..abae663 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1585 +1586 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index 40b4b8d..2b52cdf 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -628,15 +628,21 @@ [* i r ba se] [/ i r ba se] [abs i r ba se] + [asin i r ba se] [acos i r ba se] + [atan i r ba se] + [sinh i] + [cosh i] + [tanh i] + [asinh i] + [acosh i] + [atanh i] [angle i r ba se] [append i r ba se] [apply i r ba se] - [asin i r ba se] [assert i r ba] [assertion-error ] [assertion-violation i r ba] - [atan i r ba se] [boolean=? i r ba] [boolean? i r ba se] [car i r ba se] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 58f6967..ae3adc7 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -391,7 +391,7 @@ ;;; shifts cancel properly. (define mkstx ;;; QUEUE (lambda (e m* s* ae*) - (if (stx? e) + (if (and (stx? e) (not (top-marked? m*))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (make-stx (stx-expr e) m* s* ae*)) (make-stx e m* s* ae*))))