From 36d2e4ced3d15947524a8766c8ca0008ced6fd5b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 26 Jan 2011 15:18:40 -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 | 102 +++++++++++++++++++++++++++++++++++++++- 3 files changed, 143 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index 9c1f32f..0375faf 100644 --- a/NEWS +++ b/NEWS @@ -80,6 +80,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 480d326..a0186a2 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5543,7 +5543,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; @@ -5562,7 +5564,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; @@ -5581,7 +5585,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; @@ -5604,7 +5610,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; @@ -5623,7 +5631,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; @@ -5642,7 +5652,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; @@ -5665,7 +5677,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) @@ -5691,7 +5705,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) @@ -5723,7 +5739,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)) { @@ -5754,7 +5772,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, @@ -5770,7 +5790,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, @@ -5786,7 +5808,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 e812658..8854a25 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -3310,25 +3310,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