>From 45e061f24ad470d5a2517cec958db590b79e5c4c Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 26 Jan 2011 09:17:43 -0500 Subject: [PATCH] Trigonometric functions return exact numbers in some cases * libguile/numbers.c (scm_sin, scm_cos, scm_tan, scm_sinh, scm_cosh, scm_tanh, scm_asin, scm_acos, scm_sys_asinh, scm_sys_acosh, scm_sys_acosh, scm_sys_atanh, scm_atan): Return an exact result in some cases. * test-suite/tests/numbers.test: Add test cases. * NEWS: Add NEWS entry --- NEWS | 8 +++++ libguile/numbers.c | 48 +++++++++++++++++++++------- test-suite/tests/numbers.test | 69 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 12 deletions(-) diff --git a/NEWS b/NEWS index 5864755..b1196db 100644 --- a/NEWS +++ b/NEWS @@ -67,6 +67,14 @@ 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_sinh `sinh', scm_cosh +`cosh', scm_tanh `tanh', scm_asin `asin', scm_acos `acos', +scm_sys_asinh `asinh', scm_sys_acosh `acosh', scm_sys_acosh `acosh', +scm_sys_atanh `atanh' and the one-argument case of scm_atan `atan' 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 80af674..e71e9f4 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5540,7 +5540,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; @@ -5559,7 +5561,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; @@ -5578,7 +5582,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; @@ -5601,7 +5607,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; @@ -5620,7 +5628,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; @@ -5639,7 +5649,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; @@ -5662,7 +5674,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) @@ -5688,7 +5702,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) @@ -5720,7 +5736,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)) { @@ -5751,7 +5769,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, @@ -5767,7 +5787,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, @@ -5783,7 +5805,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 cfcabe3..8a984f6 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3298,6 +3298,75 @@ ;;; +;;; 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)))) + +;;; ;;; asinh ;;; -- 1.5.6.5