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

@@ -193,6 +193,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

libguile/numbers.c

@@ -6801,7 +6801,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;
@@ -6820,7 +6822,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;
@@ -6839,7 +6843,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;
@@ -6862,7 +6868,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;
@@ -6881,7 +6889,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;
@@ -6900,7 +6910,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;
@@ -6923,7 +6935,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)
@@ -6949,7 +6963,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)
@@ -6981,7 +6997,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))
         {
@@ -7012,7 +7030,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,
@@ -7028,7 +7048,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,
@@ -7044,7 +7066,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),

test-suite/tests/numbers.test

@@ -3421,26 +3421,122 @@
   (pass-if (eqv? 0.0 (expt 2.0 -inf.0))))
 
 
+;;;
+;;; 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