>From 702c1210e420a0fcd68b9c62f85633c5401a3a28 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 1 Feb 2011 06:56:02 -0500 Subject: [PATCH] Trigonometric functions return exact numbers in some cases * libguile/numbers.c (scm_sin, scm_cos, scm_tan, scm_asin, scm_acos, scm_atan, scm_sinh, scm_cosh, scm_tanh, scm_sys_asinh, scm_sys_acosh, scm_sys_atanh): Return an exact result in some cases. * test-suite/tests/numbers.test: Add test cases. * NEWS: Add NEWS entry --- NEWS | 7 +++ libguile/numbers.c | 48 ++++++++++++++----- test-suite/tests/numbers.test | 102 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 142 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 63df7db..64d2864 100644 --- a/NEWS +++ b/NEWS @@ -187,6 +187,13 @@ was at least 1 or inexact, e.g. (rationalize 4 1) should return 3 per R5RS and R6RS, but previously it returned 4. It also now handles cases involving infinities and NaNs properly, per R6RS. +*** Trigonometric functions now return exact numbers in some cases + +scm_sin `sin', scm_cos `cos', scm_tan `tan', scm_asin `asin', scm_acos +`acos', scm_atan `atan', scm_sinh `sinh', scm_cosh `cosh', scm_tanh +`tanh', scm_sys_asinh `asinh', scm_sys_acosh `acosh', and +scm_sys_atanh `atanh' now return exact results in some cases. + *** New procedure: `finite?' Add scm_finite_p `finite?' from R6RS to guile core, which returns #t diff --git a/libguile/numbers.c b/libguile/numbers.c index f9e00e6..df95c32 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -6744,7 +6744,9 @@ SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0, "Compute the sine of @var{z}.") #define FUNC_NAME s_scm_sin { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* sin(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (sin (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -6763,7 +6765,9 @@ SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0, "Compute the cosine of @var{z}.") #define FUNC_NAME s_scm_cos { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return SCM_INUM1; /* cos(exact0) = exact1 */ + else if (scm_is_real (z)) return scm_from_double (cos (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -6782,7 +6786,9 @@ SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0, "Compute the tangent of @var{z}.") #define FUNC_NAME s_scm_tan { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* tan(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (tan (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y, w; @@ -6805,7 +6811,9 @@ SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0, "Compute the hyperbolic sine of @var{z}.") #define FUNC_NAME s_scm_sinh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* sinh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (sinh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -6824,7 +6832,9 @@ SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0, "Compute the hyperbolic cosine of @var{z}.") #define FUNC_NAME s_scm_cosh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return SCM_INUM1; /* cosh(exact0) = exact1 */ + else if (scm_is_real (z)) return scm_from_double (cosh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y; @@ -6843,7 +6853,9 @@ SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0, "Compute the hyperbolic tangent of @var{z}.") #define FUNC_NAME s_scm_tanh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* tanh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (tanh (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { double x, y, w; @@ -6866,7 +6878,9 @@ SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0, "Compute the arc sine of @var{z}.") #define FUNC_NAME s_scm_asin { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* asin(exact0) = exact0 */ + else if (scm_is_real (z)) { double w = scm_to_double (z); if (w >= -1.0 && w <= 1.0) @@ -6892,7 +6906,9 @@ SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0, "Compute the arc cosine of @var{z}.") #define FUNC_NAME s_scm_acos { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1))) + return SCM_INUM0; /* acos(exact1) = exact0 */ + else if (scm_is_real (z)) { double w = scm_to_double (z); if (w >= -1.0 && w <= 1.0) @@ -6924,7 +6940,9 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0, { if (SCM_UNBNDP (y)) { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* atan(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (atan (scm_to_double (z))); else if (SCM_COMPLEXP (z)) { @@ -6955,7 +6973,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0, "Compute the inverse hyperbolic sine of @var{z}.") #define FUNC_NAME s_scm_sys_asinh { - if (scm_is_real (z)) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* asinh(exact0) = exact0 */ + else if (scm_is_real (z)) return scm_from_double (asinh (scm_to_double (z))); else if (scm_is_number (z)) return scm_log (scm_sum (z, @@ -6971,7 +6991,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0, "Compute the inverse hyperbolic cosine of @var{z}.") #define FUNC_NAME s_scm_sys_acosh { - if (scm_is_real (z) && scm_to_double (z) >= 1.0) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1))) + return SCM_INUM0; /* acosh(exact1) = exact0 */ + else if (scm_is_real (z) && scm_to_double (z) >= 1.0) return scm_from_double (acosh (scm_to_double (z))); else if (scm_is_number (z)) return scm_log (scm_sum (z, @@ -6987,7 +7009,9 @@ SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0, "Compute the inverse hyperbolic tangent of @var{z}.") #define FUNC_NAME s_scm_sys_atanh { - if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0) + if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0))) + return z; /* atanh(exact0) = exact0 */ + else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0) return scm_from_double (atanh (scm_to_double (z))); else if (scm_is_number (z)) return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z), diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 96fb6d9..9c01fa1 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3316,25 +3316,121 @@ ;;; +;;; sin +;;; + +(with-test-prefix "sin" + (pass-if (eqv? 0 (sin 0))) + (pass-if (eqv? 0.0 (sin 0.0))) + (pass-if (eqv-loosely? 1.0 (sin 1.57))) + (pass-if (eqv-loosely? +1.175i (sin +i))) + (pass-if (real-nan? (sin +nan.0))) + (pass-if (real-nan? (sin +inf.0))) + (pass-if (real-nan? (sin -inf.0)))) + +;;; +;;; cos +;;; + +(with-test-prefix "cos" + (pass-if (eqv? 1 (cos 0))) + (pass-if (eqv? 1.0 (cos 0.0))) + (pass-if (eqv-loosely? 0.0 (cos 1.57))) + (pass-if (eqv-loosely? 1.543 (cos +i))) + (pass-if (real-nan? (cos +nan.0))) + (pass-if (real-nan? (cos +inf.0))) + (pass-if (real-nan? (cos -inf.0)))) + +;;; +;;; tan +;;; + +(with-test-prefix "tan" + (pass-if (eqv? 0 (tan 0))) + (pass-if (eqv? 0.0 (tan 0.0))) + (pass-if (eqv-loosely? 1.0 (tan 0.785))) + (pass-if (eqv-loosely? +0.76i (tan +i))) + (pass-if (real-nan? (tan +nan.0))) + (pass-if (real-nan? (tan +inf.0))) + (pass-if (real-nan? (tan -inf.0)))) + +;;; +;;; asin +;;; + +(with-test-prefix "asin" + (pass-if (complex-nan? (asin +nan.0))) + (pass-if (eqv? 0 (asin 0))) + (pass-if (eqv? 0.0 (asin 0.0)))) + +;;; +;;; acos +;;; + +(with-test-prefix "acos" + (pass-if (complex-nan? (acos +nan.0))) + (pass-if (eqv? 0 (acos 1))) + (pass-if (eqv? 0.0 (acos 1.0)))) + +;;; +;;; atan +;;; +;;; FIXME: add tests for two-argument atan +;;; +(with-test-prefix "atan" + (pass-if (real-nan? (atan +nan.0))) + (pass-if (eqv? 0 (atan 0))) + (pass-if (eqv? 0.0 (atan 0.0))) + (pass-if (eqv-loosely? 1.57 (atan +inf.0))) + (pass-if (eqv-loosely? -1.57 (atan -inf.0)))) + +;;; +;;; sinh +;;; + +(with-test-prefix "sinh" + (pass-if (= 0 (sinh 0))) + (pass-if (= 0.0 (sinh 0.0)))) + +;;; +;;; cosh +;;; + +(with-test-prefix "cosh" + (pass-if (= 1 (cosh 0))) + (pass-if (= 1.0 (cosh 0.0)))) + +;;; +;;; tanh +;;; + +(with-test-prefix "tanh" + (pass-if (= 0 (tanh 0))) + (pass-if (= 0.0 (tanh 0.0)))) + +;;; ;;; asinh ;;; (with-test-prefix "asinh" - (pass-if (= 0 (asinh 0)))) + (pass-if (= 0 (asinh 0))) + (pass-if (= 0.0 (asinh 0.0)))) ;;; ;;; acosh ;;; (with-test-prefix "acosh" - (pass-if (= 0 (acosh 1)))) + (pass-if (= 0 (acosh 1))) + (pass-if (= 0.0 (acosh 1.0)))) ;;; ;;; atanh ;;; (with-test-prefix "atanh" - (pass-if (= 0 (atanh 0)))) + (pass-if (= 0 (atanh 0))) + (pass-if (= 0.0 (atanh 0.0)))) ;;; ;;; make-rectangular -- 1.5.6.5