From c64fda7619802752210f5cf38ae498f7aa8ff4e3 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Mon, 11 Aug 2008 10:37:05 -0700 Subject: [PATCH] fixed a few problems in geometric functions when they are passed complex numbers or when they're passed real numbers but the results are complex. --- c64 | 4 +- scheme/ikarus.compiler.source-optimizer.ss | 6 + scheme/ikarus.numerics.ss | 141 +++++++++++++++++++-- scheme/last-revision | 2 +- src/ikarus-flonums.c | 61 +++++++-- 5 files changed, 186 insertions(+), 28 deletions(-) diff --git a/c64 b/c64 index 890955a..fc61b19 100755 --- a/c64 +++ b/c64 @@ -1,8 +1,8 @@ #!/usr/bin/env sh ./configure --prefix=/Users/ikarus/.opt \ - CFLAGS="-m64 -g -I/Users/ikarus/.opt64/include" \ - LDFLAGS="-m64 -g -L/Users/ikarus/.opt64/lib" \ + CFLAGS="-m64 -I/Users/ikarus/.opt64/include" \ + LDFLAGS="-m64 -L/Users/ikarus/.opt64/lib" \ && make clean \ && make diff --git a/scheme/ikarus.compiler.source-optimizer.ss b/scheme/ikarus.compiler.source-optimizer.ss index 450771f..28ade5f 100644 --- a/scheme/ikarus.compiler.source-optimizer.ss +++ b/scheme/ikarus.compiler.source-optimizer.ss @@ -238,6 +238,12 @@ [(sub1 _) foldable result-true] [(bitwise-and _ _) foldable result-true] [(make-rectangular _ _) foldable result-true] + [(sin _) foldable result-true] + [(cos _) foldable result-true] + [(tan _) foldable result-true] + [(asin _) foldable result-true] + [(acos _) foldable result-true] + [(atan _) foldable result-true] [(make-eq-hashtable) effect-free result-true] [(string->number _) foldable ] [(string->number _ _) foldable ] diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss index 22953bc..f7ceb49 100644 --- a/scheme/ikarus.numerics.ss +++ b/scheme/ikarus.numerics.ss @@ -1401,9 +1401,9 @@ [else (f (max a b) (car ls) (cdr ls))]))] [(x) - (if (number? x) - x - (die 'max "not a number" x))])) + (cond + [(or (fixnum? x) (bignum? x) (ratnum? x) (flonum? x)) x] + [else (die 'max "not a number" x)])])) (define min (case-lambda @@ -1464,9 +1464,9 @@ [else (f (min a b) (car ls) (cdr ls))]))] [(x) - (if (number? x) - x - (die 'min "not a number" x))])) + (cond + [(or (fixnum? x) (bignum? x) (ratnum? x) (flonum? x)) x] + [else (die 'min "not a number" x)])])) (define (abs x) (cond @@ -2388,6 +2388,9 @@ [(ratnum? x) #f] [(flonum? x) (or ($fl= x 0.0) ($fl= x -0.0))] + [(cflonum? x) + (and ($fl= ($cflonum-real x) 0.0) ($fl= ($cflonum-imag x) 0.0))] + [(compnum? x) #f] [else (die 'zero? "not a number" x)]))) @@ -2512,6 +2515,78 @@ [(ratnum? x) (negative? ($ratnum-n x))] [else (die 'negative? "not a number" x)]))) + (define sinh + (lambda (x) + (define who 'sinh) + (cond + [(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)] + [else (die who "not a number" x)]))) + + (define cosh + (lambda (x) + (define who 'cosh) + (cond + [(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)] + [else (die who "not a number" x)]))) + + (define tanh + (lambda (x) + (define who 'tanh) + (cond + [(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)] + [else (die who "not a number" x)]))) + + (define asinh + (lambda (x) + (define who 'asinh) + (cond + [(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)] + [else (die who "not a number" x)]))) + + (define acosh + (lambda (x) + (define who 'acosh) + (cond + [(flonum? x) + (cond + [($fl>= x 1.0) (foreign-call "ikrt_fl_acosh" x)] + [($fl>= x -1.0) + (make-rectangular 0 (atan (sqrt (- 1 (* x x))) x))] + [($fl< x -1.0) + (make-rectangular (acosh (- x)) PI)] + [else +nan.0])] + [(or (fixnum? x) (bignum? x) (ratnum? x)) + (acosh (inexact x))] + [(number? x) (error who "not implemented" x)] + [else (die who "not a number" x)]))) + + (define atanh + (lambda (x) + (define who 'atanh) + (cond + [(flonum? x) (foreign-call "ikrt_fl_atanh" x)] + [(or (fixnum? x) (bignum? x) (ratnum? x)) + (atanh (inexact x))] + [(number? x) (error who "not implemented" x)] + [else (die who "not a number" x)]))) + + + + + + (define sin (lambda (x) (cond @@ -2520,6 +2595,11 @@ (if (fx=? x 0) 0 (foreign-call "ikrt_fx_sin" x))] + [(or (cflonum? x) (compnum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (make-rectangular + (* (sin r) (cosh i)) + (* (cos r) (sinh i))))] [(number? x) (sin (inexact x))] [else (die 'sin "not a number" x)]))) @@ -2531,6 +2611,11 @@ (if (fx=? x 0) 1 (foreign-call "ikrt_fx_cos" x))] + [(or (cflonum? x) (compnum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (make-rectangular + (* (cos r) (cosh i)) + (* (sin r) (sinh i))))] [(number? x) (cos (inexact x))] [else (die 'cos "not a number" x)]))) @@ -2542,22 +2627,50 @@ (if (fx=? x 0) 0 (foreign-call "ikrt_fx_tan" x))] + [(or (cflonum? x) (compnum? x)) + (let ([r (real-part x)] [i (imag-part x)]) + (make-rectangular + (/ (sin (* 2 r)) + (+ (cos (* 2 r)) (cosh (* 2 i)))) + (/ (tanh (* 2 i)) + (+ 1 (/ (cos (* 2 r)) (cosh (* 2 i)))))))] [(number? x) (tan (inexact x))] [else (die 'tan "not a number" x)]))) + (module (PI PI/2) + (import (ikarus)) + (define PI (acos -1)) + (define PI/2 (/ PI 2))) + (define asin (lambda (x) (cond - [(flonum? x) (foreign-call "ikrt_fl_asin" x)] - [(fixnum? x) (foreign-call "ikrt_fx_asin" x)] + [(flonum? x) + (cond + [($fl> x 1.0) + (make-rectangular PI/2 (acosh x))] + [($fl< x -1.0) + (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")] [(number? x) (asin (inexact x))] [else (die 'asin "not a number" x)]))) (define acos (lambda (x) (cond - [(flonum? x) (foreign-call "ikrt_fl_acos" x)] - [(fixnum? x) (foreign-call "ikrt_fx_acos" x)] + [(flonum? x) + (cond + [($fl> x 1.0) + (make-rectangular 0 (acosh x))] + [($fl< x -1.0) + (make-rectangular PI (- (acosh (- x))))] + [else + (foreign-call "ikrt_fl_acos" x)])] + [(or (cflonum? x) (compnum? x)) + (error 'acos "not implemented for complex arguments")] [(number? x) (acos (inexact x))] [else (die 'acos "not a number" x)]))) @@ -3784,10 +3897,10 @@ (define (make-polar mag angle) (define who 'make-polar) - (unless (number? mag) - (die who "not a number" mag)) - (unless (number? angle) - (die who "not a number" angle)) + (unless (real? mag) + (die who "not a real number" mag)) + (unless (real? angle) + (die who "not a real number" angle)) (make-rectangular (* mag (cos angle)) (* mag (sin angle)))) diff --git a/scheme/last-revision b/scheme/last-revision index 2907ff5..b1e142d 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1583 +1584 diff --git a/src/ikarus-flonums.c b/src/ikarus-flonums.c index 1f4ba48..4851f89 100644 --- a/src/ikarus-flonums.c +++ b/src/ikarus-flonums.c @@ -41,10 +41,6 @@ ikrt_flfl_expt(ikptr a, ikptr b, ikptr z){ return z; } - - - - ikptr ikrt_bytevector_to_flonum(ikptr x, ikpcb* pcb){ double v = strtod((char*)(long)x+off_bytevector_data, NULL); @@ -54,7 +50,6 @@ ikrt_bytevector_to_flonum(ikptr x, ikpcb* pcb){ return r; } - ikptr ikrt_fl_plus(ikptr x, ikptr y,ikpcb* pcb){ ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; @@ -151,9 +146,6 @@ ikrt_atan2(ikptr y, ikptr x, ikpcb* pcb){ return r; } - - - ikptr ikrt_fl_sqrt(ikptr x, ikpcb* pcb){ ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; @@ -170,7 +162,6 @@ ikrt_fl_log(ikptr x, ikpcb* pcb){ return r; } - ikptr ikrt_fx_sin(ikptr x, ikpcb* pcb){ ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; @@ -219,6 +210,56 @@ ikrt_fx_atan(ikptr x, ikpcb* pcb){ return r; } +ikptr +ikrt_fl_sinh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = sinh(flonum_data(x)); + return r; +} + +ikptr +ikrt_fl_cosh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = cosh(flonum_data(x)); + return r; +} + +ikptr +ikrt_fl_tanh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = tanh(flonum_data(x)); + return r; +} + +ikptr +ikrt_fl_asinh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = asinh(flonum_data(x)); + return r; +} + +ikptr +ikrt_fl_acosh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = acosh(flonum_data(x)); + return r; +} + +ikptr +ikrt_fl_atanh(ikptr x, ikpcb* pcb){ + ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; + ref(r, -vector_tag) = (ikptr)flonum_tag; + flonum_data(r) = atanh(flonum_data(x)); + return r; +} + + + ikptr ikrt_fx_sqrt(ikptr x, ikpcb* pcb){ ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; @@ -227,7 +268,6 @@ ikrt_fx_sqrt(ikptr x, ikpcb* pcb){ return r; } - ikptr ikrt_fx_log(ikptr x, ikpcb* pcb){ ikptr r = ik_unsafe_alloc(pcb, flonum_size) + vector_tag; @@ -236,7 +276,6 @@ ikrt_fx_log(ikptr x, ikpcb* pcb){ return r; } - ikptr ikrt_fixnum_to_flonum(ikptr x, ikptr r, ikpcb* pcb){ flonum_data(r) = unfix(x);