Fix PR fortran/93871 and re-implement degree-valued trigonometric intrinsics.

2020-04-01  Fritz Reese  <foreese@gcc.gnu.org>
	    Steven G. Kargl  <kargl@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/93871
	* gfortran.h (GFC_ISYM_ACOSD, GFC_ISYM_ASIND, GFC_ISYM_ATAN2D,
	GFC_ISYM_ATAND, GFC_ISYM_COSD, GFC_ISYM_COTAND, GFC_ISYM_SIND,
	GFC_ISYM_TAND): New.
	* intrinsic.c (add_functions): Remove check for flag_dec_math.
	Give degree trig functions simplification and name resolution
	functions (e.g, gfc_simplify_atrigd () and gfc_resolve_atrigd ()).
	(do_simplify): Remove special casing of degree trig functions.
	* intrinsic.h (gfc_simplify_acosd, gfc_simplify_asind,
	gfc_simplify_atand, gfc_simplify_cosd, gfc_simplify_cotand,
	gfc_simplify_sind, gfc_simplify_tand, gfc_resolve_trigd2): Add new
	prototypes.
	(gfc_simplify_atrigd, gfc_simplify_trigd, gfc_resolve_cotan,
	resolve_atrigd): Remove prototypes of deleted functions.
	* iresolve.c (is_trig_resolved, copy_replace_function_shallow,
	gfc_resolve_cotan, get_radians, get_degrees, resolve_trig_call,
	gfc_resolve_atrigd, gfc_resolve_atan2d): Delete functions.
	(gfc_resolve_trigd, gfc_resolve_trigd2): Resolve to library functions.
	* simplify.c (rad2deg, deg2rad, gfc_simplify_acosd, gfc_simplify_asind,
	gfc_simplify_atand, gfc_simplify_atan2d, gfc_simplify_cosd,
	gfc_simplify_sind, gfc_simplify_tand, gfc_simplify_cotand): New
	functions.
	(gfc_simplify_atan2): Fix error message.
	(simplify_trig_call, gfc_simplify_trigd, gfc_simplify_atrigd,
	radians_f): Delete functions.
	* trans-intrinsic.c: Add LIB_FUNCTION decls for sind, cosd, tand.
	(rad2deg, gfc_conv_intrinsic_atrigd, gfc_conv_intrinsic_cotan,
	gfc_conv_intrinsic_cotand, gfc_conv_intrinsic_atan2d): New functions.
	(gfc_conv_intrinsic_function): Handle ACOSD, ASIND, ATAND, COTAN,
	COTAND, ATAN2D.
	* trigd_fe.inc: New file. Included by simplify.c to implement
	simplify_sind, simplify_cosd, simplify_tand with code common to the
	libgfortran implementation.

gcc/testsuite/ChangeLog

	PR fortran/93871
	* gfortran.dg/dec_math.f90: Extend coverage to real(10) and real(16).
	* gfortran.dg/dec_math_2.f90: New test.
	* gfortran.dg/dec_math_3.f90: Likewise.
	* gfortran.dg/dec_math_4.f90: Likewise.
	* gfortran.dg/dec_math_5.f90: Likewise.

libgfortran/ChangeLog

	PR fortran/93871
	* Makefile.am, Makefile.in: New make rule for intrinsics/trigd.c.
	* gfortran.map: New routines for {sind, cosd, tand}X{r4, r8, r10, r16}.
	* intrinsics/trigd.c, intrinsics/trigd_lib.inc, intrinsics/trigd.inc:
	New files. Defines native degree-valued trig functions.

1 files changed, 464 insertions, 0 deletions

diff --git a/libgfortran/intrinsics/trigd.inc b/libgfortran/intrinsics/trigd.inc
new file mode 100644
index 00000000000..98bfae7e839
--- /dev/null
+++ b/libgfortran/intrinsics/trigd.inc
@@ -0,0 +1,464 @@
+/* Implementation of the degree trignometric functions COSD, SIND, TAND.
+   Copyright (C) 2020 Free Software Foundation, Inc.
+   Contributed by Steven G. Kargl <kargl@gcc.gnu.org>
+   and Fritz Reese <foreese@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+Under Section 7 of GPL version 3, you are granted additional
+permissions described in the GCC Runtime Library Exception, version
+3.1, as published by the Free Software Foundation.
+
+You should have received a copy of the GNU General Public License and
+a copy of the GCC Runtime Library Exception along with this program;
+see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
+<http://www.gnu.org/licenses/>.  */
+
+
+/*
+
+This file is included from both the FE and the runtime library code.
+Operations are generalized using GMP/MPFR functions. When included from
+libgfortran, these should be overridden using macros which will use native
+operations conforming to the same API. From the FE, the GMP/MPFR functions can
+be used as-is.
+
+The following macros and GMP/FMPR functions are used and must be defined.
+
+
+Types and names:
+
+FTYPE
+    Type name for the real-valued parameter.
+    Variables of this type are constructed/destroyed using mpfr_init()
+    and mpfr_clear.
+
+RETTYPE
+    Return type of the functions.
+
+RETURN(x)
+    Insert code to return a value.
+    The parameter x is the result variable, which was also the input parameter.
+
+ITYPE
+    Type name for integer types.
+
+SIND, COSD, TRIGD
+    Names for the degree-valued trig functions defined by this module.
+
+
+Literal values:
+
+TINY [optional]
+    Value subtracted from 1 to cause rase INEXACT for COSD(x)
+    for x << 1. If not set, COSD(x) for x <= COSD_SMALL simply returns 1.
+
+COSD_SMALL [optional]
+    Value such that x <= COSD_SMALL implies COSD(x) = 1 to within the
+    precision of FTYPE. If not set, this condition is not checked.
+
+SIND_SMALL [optional]
+    Value such that x <= SIND_SMALL implies SIND(x) = D2R(x) to within
+    the precision of FTYPE. If not set, this condition is not checked.
+
+COSD30
+    Value of SIND(60) and COSD(30).
+
+*/
+
+
+/* Compute sind(x) = sin(x * pi / 180). */
+
+RETTYPE
+SIND (FTYPE x)
+{
+  if (ISFINITE (x))
+    {
+      FTYPE s, one;
+
+      /* sin(-x) = - sin(x).  */
+      mpfr_init (s);
+      mpfr_init_set_ui (one, 1, GFC_RND_MODE);
+      mpfr_copysign (s, one, x, GFC_RND_MODE);
+      mpfr_clear (one);
+
+#ifdef SIND_SMALL
+      /* sin(x) = x as x -> 0; but only for some precisions. */
+      FTYPE ax;
+      mpfr_init (ax);
+      mpfr_abs (ax, x, GFC_RND_MODE);
+      if (mpfr_cmp_ld (ax, SIND_SMALL) < 0)
+	{
+	  D2R (x);
+	  mpfr_clear (ax);
+	  return x;
+	}
+
+      mpfr_swap (x, ax);
+      mpfr_clear (ax);
+
+#else
+      mpfr_abs (x, x, GFC_RND_MODE);
+#endif /* SIND_SMALL */
+
+      /* Reduce angle to x in [0,360].  */
+      FTYPE period;
+      mpfr_init_set_ui (period, 360, GFC_RND_MODE);
+      mpfr_fmod (x, x, period, GFC_RND_MODE);
+      mpfr_clear (period);
+
+      /* Special cases with exact results.  */
+      ITYPE n;
+      mpz_init (n);
+      if (mpfr_get_z (n, x, GFC_RND_MODE) == 0 && mpz_divisible_ui_p (n, 30))
+	{
+	  /* Flip sign for odd n*pi (x is % 360 so this is only for 180).
+	     This respects sgn(sin(x)) = sgn(d/dx sin(x)) = sgn(cos(x)). */
+	  if (mpz_divisible_ui_p (n, 180))
+	    {
+	      mpfr_set_ui (x, 0, GFC_RND_MODE);
+	      if (mpz_cmp_ui (n, 180) == 0)
+		mpfr_neg (s, s, GFC_RND_MODE);
+	    }
+	  else if (mpz_divisible_ui_p (n, 90))
+	    mpfr_set_si (x, (mpz_cmp_ui (n, 90) == 0 ? 1 : -1), GFC_RND_MODE);
+	  else if (mpz_divisible_ui_p (n, 60))
+	    {
+	      SET_COSD30 (x);
+	      if (mpz_cmp_ui (n, 180) >= 0)
+		mpfr_neg (x, x, GFC_RND_MODE);
+	    }
+	  else
+	    mpfr_set_ld (x, (mpz_cmp_ui (n, 180) < 0 ? 0.5L : -0.5L),
+			 GFC_RND_MODE);
+	}
+
+      /* Fold [0,360] into the range [0,45], and compute either SIN() or
+         COS() depending on symmetry of shifting into the [0,45] range.  */
+      else
+	{
+	  bool fold_cos = false;
+	  if (mpfr_cmp_ui (x, 180) <= 0)
+	    {
+	      if (mpfr_cmp_ui (x, 90) <= 0)
+		{
+		  if (mpfr_cmp_ui (x, 45) > 0)
+		    {
+		      /* x = COS(D2R(90 - x)) */
+		      mpfr_ui_sub (x, 90, x, GFC_RND_MODE);
+		      fold_cos = true;
+		    }
+		}
+	      else
+		{
+		  if (mpfr_cmp_ui (x, 135) <= 0)
+		    {
+		      mpfr_sub_ui (x, x, 90, GFC_RND_MODE);
+		      fold_cos = true;
+		    }
+		  else
+		    mpfr_ui_sub (x, 180, x, GFC_RND_MODE);
+		}
+	    }
+
+	  else if (mpfr_cmp_ui (x, 270) <= 0)
+	    {
+	      if (mpfr_cmp_ui (x, 225) <= 0)
+		mpfr_sub_ui (x, x, 180, GFC_RND_MODE);
+	      else
+		{
+		  mpfr_ui_sub (x, 270, x, GFC_RND_MODE);
+		  fold_cos = true;
+		}
+	      mpfr_neg (s, s, GFC_RND_MODE);
+	    }
+
+	  else
+	    {
+	      if (mpfr_cmp_ui (x, 315) <= 0)
+		{
+		  mpfr_sub_ui (x, x, 270, GFC_RND_MODE);
+		  fold_cos = true;
+		}
+	      else
+		mpfr_ui_sub (x, 360, x, GFC_RND_MODE);
+	      mpfr_neg (s, s, GFC_RND_MODE);
+	    }
+
+	  D2R (x);
+
+	  if (fold_cos)
+	    mpfr_cos (x, x, GFC_RND_MODE);
+	  else
+	    mpfr_sin (x, x, GFC_RND_MODE);
+	}
+
+      mpfr_mul (x, x, s, GFC_RND_MODE);
+      mpz_clear (n);
+      mpfr_clear (s);
+    }
+
+  /* Return NaN for +-Inf and NaN and raise exception.  */
+  else
+    mpfr_sub (x, x, x, GFC_RND_MODE);
+
+  RETURN (x);
+}
+
+
+/* Compute cosd(x) = cos(x * pi / 180).  */
+
+RETTYPE
+COSD (FTYPE x)
+{
+#if defined(TINY) && defined(COSD_SMALL)
+  static const volatile FTYPE tiny = TINY;
+#endif
+
+  if (ISFINITE (x))
+    {
+#ifdef COSD_SMALL
+      FTYPE ax;
+      mpfr_init (ax);
+
+      mpfr_abs (ax, x, GFC_RND_MODE);
+      /* No spurious underflows!.  In radians, cos(x) = 1-x*x/2 as x -> 0.  */
+      if (mpfr_cmp_ld (ax, COSD_SMALL) <= 0)
+	{
+	  mpfr_set_ui (x, 1, GFC_RND_MODE);
+#ifdef TINY
+	  /* Cause INEXACT.  */
+	  if (!mpfr_zero_p (ax))
+	    mpfr_sub_d (x, x, tiny, GFC_RND_MODE);
+#endif
+
+	  mpfr_clear (ax);
+	  return x;
+	}
+
+      mpfr_swap (x, ax);
+      mpfr_clear (ax);
+#else
+      mpfr_abs (x, x, GFC_RND_MODE);
+#endif /* COSD_SMALL */
+
+      /* Reduce angle to ax in [0,360].  */
+      FTYPE period;
+      mpfr_init_set_ui (period, 360, GFC_RND_MODE);
+      mpfr_fmod (x, x, period, GFC_RND_MODE);
+      mpfr_clear (period);
+
+      /* Special cases with exact results.
+         Return negative zero for cosd(270) for consistency with libm cos().  */
+      ITYPE n;
+      mpz_init (n);
+      if (mpfr_get_z (n, x, GFC_RND_MODE) == 0 && mpz_divisible_ui_p (n, 30))
+	{
+	  if (mpz_divisible_ui_p (n, 180))
+	    mpfr_set_si (x, (mpz_cmp_ui (n, 180) == 0 ? -1 : 1),
+			 GFC_RND_MODE);
+	  else if (mpz_divisible_ui_p (n, 90))
+	    mpfr_set_zero (x, 0);
+	  else if (mpz_divisible_ui_p (n, 60))
+	    {
+	      mpfr_set_ld (x, 0.5, GFC_RND_MODE);
+	      if (mpz_cmp_ui (n, 60) != 0 && mpz_cmp_ui (n, 300) != 0)
+		mpfr_neg (x, x, GFC_RND_MODE);
+	    }
+	  else
+	    {
+	      SET_COSD30 (x);
+	      if (mpz_cmp_ui (n, 30) != 0 && mpz_cmp_ui (n, 330) != 0)
+		mpfr_neg (x, x, GFC_RND_MODE);
+	    }
+	}
+
+      /* Fold [0,360] into the range [0,45], and compute either SIN() or
+         COS() depending on symmetry of shifting into the [0,45] range.  */
+      else
+	{
+	  bool neg = false;
+	  bool fold_sin = false;
+	  if (mpfr_cmp_ui (x, 180) <= 0)
+	    {
+	      if (mpfr_cmp_ui (x, 90) <= 0)
+		{
+		  if (mpfr_cmp_ui (x, 45) > 0)
+		    {
+		      mpfr_ui_sub (x, 90, x, GFC_RND_MODE);
+		      fold_sin = true;
+		    }
+		}
+	      else
+		{
+		  if (mpfr_cmp_ui (x, 135) <= 0)
+		    {
+		      mpfr_sub_ui (x, x, 90, GFC_RND_MODE);
+		      fold_sin = true;
+		    }
+		  else
+		    mpfr_ui_sub (x, 180, x, GFC_RND_MODE);
+		  neg = true;
+		}
+	    }
+
+	  else if (mpfr_cmp_ui (x, 270) <= 0)
+	    {
+	      if (mpfr_cmp_ui (x, 225) <= 0)
+		mpfr_sub_ui (x, x, 180, GFC_RND_MODE);
+	      else
+		{
+		  mpfr_ui_sub (x, 270, x, GFC_RND_MODE);
+		  fold_sin = true;
+		}
+	      neg = true;
+	    }
+
+	  else
+	    {
+	      if (mpfr_cmp_ui (x, 315) <= 0)
+		{
+		  mpfr_sub_ui (x, x, 270, GFC_RND_MODE);
+		  fold_sin = true;
+		}
+	      else
+		mpfr_ui_sub (x, 360, x, GFC_RND_MODE);
+	    }
+
+	  D2R (x);
+
+	  if (fold_sin)
+	    mpfr_sin (x, x, GFC_RND_MODE);
+	  else
+	    mpfr_cos (x, x, GFC_RND_MODE);
+
+	  if (neg)
+	    mpfr_neg (x, x, GFC_RND_MODE);
+	}
+
+      mpz_clear (n);
+    }
+
+  /* Return NaN for +-Inf and NaN and raise exception.  */
+  else
+    mpfr_sub (x, x, x, GFC_RND_MODE);
+
+  RETURN (x);
+}
+
+
+/* Compute tand(x) = tan(x * pi / 180).  */
+
+RETTYPE
+TAND (FTYPE x)
+{
+  if (ISFINITE (x))
+    {
+      FTYPE s, one;
+
+      /* tan(-x) = - tan(x).  */
+      mpfr_init (s);
+      mpfr_init_set_ui (one, 1, GFC_RND_MODE);
+      mpfr_copysign (s, one, x, GFC_RND_MODE);
+      mpfr_clear (one);
+
+#ifdef SIND_SMALL
+      /* tan(x) = x as x -> 0; but only for some precisions. */
+      FTYPE ax;
+      mpfr_init (ax);
+      mpfr_abs (ax, x, GFC_RND_MODE);
+      if (mpfr_cmp_ld (ax, SIND_SMALL) < 0)
+	{
+	  D2R (x);
+	  mpfr_clear (ax);
+	  return x;
+	}
+
+      mpfr_swap (x, ax);
+      mpfr_clear (ax);
+
+#else
+      mpfr_abs (x, x, GFC_RND_MODE);
+#endif /* SIND_SMALL */
+
+      /* Reduce angle to x in [0,360].  */
+      FTYPE period;
+      mpfr_init_set_ui (period, 360, GFC_RND_MODE);
+      mpfr_fmod (x, x, period, GFC_RND_MODE);
+      mpfr_clear (period);
+
+      /* Special cases with exact results. */
+      ITYPE n;
+      mpz_init (n);
+      if (mpfr_get_z (n, x, GFC_RND_MODE) == 0 && mpz_divisible_ui_p (n, 45))
+	{
+	  if (mpz_divisible_ui_p (n, 180))
+	    mpfr_set_zero (x, 0);
+
+	  /* Though mathematically NaN is more appropriate for tan(n*90),
+	     returning +/-Inf offers the advantage that 1/tan(n*90) returns 0,
+	     which is mathematically sound. In fact we rely on this behavior
+	     to implement COTAND(x) = 1 / TAND(x).
+	   */
+	  else if (mpz_divisible_ui_p (n, 90))
+	    mpfr_set_inf (x, mpz_cmp_ui (n, 90) == 0 ? 0 : 1);
+
+	  else
+	    {
+	      mpfr_set_ui (x, 1, GFC_RND_MODE);
+	      if (mpz_cmp_ui (n, 45) != 0 && mpz_cmp_ui (n, 225) != 0)
+		mpfr_neg (x, x, GFC_RND_MODE);
+	    }
+	}
+
+      else
+	{
+	  /* Fold [0,360] into the range [0,90], and compute TAN().  */
+	  if (mpfr_cmp_ui (x, 180) <= 0)
+	    {
+	      if (mpfr_cmp_ui (x, 90) > 0)
+		{
+		  mpfr_ui_sub (x, 180, x, GFC_RND_MODE);
+		  mpfr_neg (s, s, GFC_RND_MODE);
+		}
+	    }
+	  else
+	    {
+	      if (mpfr_cmp_ui (x, 270) <= 0)
+		{
+		  mpfr_sub_ui (x, x, 180, GFC_RND_MODE);
+		}
+	      else
+		{
+		  mpfr_ui_sub (x, 360, x, GFC_RND_MODE);
+		  mpfr_neg (s, s, GFC_RND_MODE);
+		}
+	    }
+
+	  D2R (x);
+	  mpfr_tan (x, x, GFC_RND_MODE);
+	}
+
+      mpfr_mul (x, x, s, GFC_RND_MODE);
+      mpz_clear (n);
+      mpfr_clear (s);
+    }
+
+  /* Return NaN for +-Inf and NaN and raise exception.  */
+  else
+    mpfr_sub (x, x, x, GFC_RND_MODE);
+
+  RETURN (x);
+}
+
+/* vim: set ft=c: */