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, 24 insertions, 232 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index a991c3a..7ecb659 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -689,86 +689,6 @@ gfc_resolve_cosh (gfc_expr *f, gfc_expr *x)
 }
 
 
-/* Our replacement of elements of a trig call with an EXPR_OP (e.g.
-   multiplying the result or operands by a factor to convert to/from degrees)
-   will cause the resolve_* function to be invoked again when resolving the
-   freshly created EXPR_OP.  See gfc_resolve_trigd, gfc_resolve_atrigd,
-   gfc_resolve_cotan.  We must observe this and avoid recursively creating
-   layers of nested EXPR_OP expressions.  */
-
-static bool
-is_trig_resolved (gfc_expr *f)
-{
-  /* We know we've already resolved the function if we see the lib call
-     starting with '__'.  */
-  return (f->value.function.name != NULL
-	  && gfc_str_startswith (f->value.function.name, "__"));
-}
-
-/* Return a shallow copy of the function expression f.  The original expression
-   has its pointers cleared so that it may be freed without affecting the
-   shallow copy.  This is similar to gfc_copy_expr, but doesn't perform a deep
-   copy of the argument list, allowing it to be reused somewhere else,
-   setting the expression up nicely for gfc_replace_expr.  */
-
-static gfc_expr *
-copy_replace_function_shallow (gfc_expr *f)
-{
-  gfc_expr *fcopy;
-  gfc_actual_arglist *args;
-
-  /* The only thing deep-copied in gfc_copy_expr is args.  */
-  args = f->value.function.actual;
-  f->value.function.actual = NULL;
-  fcopy = gfc_copy_expr (f);
-  fcopy->value.function.actual = args;
-
-  /* Clear the old function so the shallow copy is not affected if the old
-     expression is freed.  */
-  f->value.function.name = NULL;
-  f->value.function.isym = NULL;
-  f->value.function.actual = NULL;
-  f->value.function.esym = NULL;
-  f->shape = NULL;
-  f->ref = NULL;
-
-  return fcopy;
-}
-
-
-/* Resolve cotan = cos / sin.  */
-
-void
-gfc_resolve_cotan (gfc_expr *f, gfc_expr *x)
-{
-  gfc_expr *result, *fcopy, *sin;
-  gfc_actual_arglist *sin_args;
-
-  if (is_trig_resolved (f))
-    return;
-
-  /* Compute cotan (x) = cos (x) / sin (x).  */
-  f->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_COS);
-  gfc_resolve_cos (f, x);
-
-  sin_args = gfc_get_actual_arglist ();
-  sin_args->expr = gfc_copy_expr (x);
-
-  sin = gfc_get_expr ();
-  sin->ts = f->ts;
-  sin->where = f->where;
-  sin->expr_type = EXPR_FUNCTION;
-  sin->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SIN);
-  sin->value.function.actual = sin_args;
-  gfc_resolve_sin (sin, sin_args->expr);
-
-  /* Replace f with cos/sin - we do this in place in f for the caller.  */
-  fcopy = copy_replace_function_shallow (f);
-  result = gfc_divide (fcopy, sin);
-  gfc_replace_expr (f, result);
-}
-
-
 void
 gfc_resolve_count (gfc_expr *f, gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
 {
@@ -2912,158 +2832,6 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
 }
 
 
-/* Build an expression for converting degrees to radians.  */
-
-static gfc_expr *
-get_radians (gfc_expr *deg)
-{
-  gfc_expr *result, *factor;
-  gfc_actual_arglist *mod_args;
-
-  gcc_assert (deg->ts.type == BT_REAL);
-
-  /* Set deg = deg % 360 to avoid offsets from large angles.  */
-  factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
-  mpfr_set_d (factor->value.real, 360.0, GFC_RND_MODE);
-
-  mod_args = gfc_get_actual_arglist ();
-  mod_args->expr = deg;
-  mod_args->next = gfc_get_actual_arglist ();
-  mod_args->next->expr = factor;
-
-  result = gfc_get_expr ();
-  result->ts = deg->ts;
-  result->where = deg->where;
-  result->expr_type = EXPR_FUNCTION;
-  result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
-  result->value.function.actual = mod_args;
-
-  /* Set factor = pi / 180.  */
-  factor = gfc_get_constant_expr (deg->ts.type, deg->ts.kind, &deg->where);
-  mpfr_const_pi (factor->value.real, GFC_RND_MODE);
-  mpfr_div_ui (factor->value.real, factor->value.real, 180, GFC_RND_MODE);
-
-  /* Result is rad = (deg % 360) * (pi / 180).  */
-  result = gfc_multiply (result, factor);
-  return result;
-}
-
-
-/* Build an expression for converting radians to degrees.  */
-
-static gfc_expr *
-get_degrees (gfc_expr *rad)
-{
-  gfc_expr *result, *factor;
-  gfc_actual_arglist *mod_args;
-  mpfr_t tmp;
-
-  gcc_assert (rad->ts.type == BT_REAL);
-
-  /* Set rad = rad % 2pi to avoid offsets from large angles.  */
-  factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
-  mpfr_const_pi (factor->value.real, GFC_RND_MODE);
-  mpfr_mul_ui (factor->value.real, factor->value.real, 2, GFC_RND_MODE);
-
-  mod_args = gfc_get_actual_arglist ();
-  mod_args->expr = rad;
-  mod_args->next = gfc_get_actual_arglist ();
-  mod_args->next->expr = factor;
-
-  result = gfc_get_expr ();
-  result->ts = rad->ts;
-  result->where = rad->where;
-  result->expr_type = EXPR_FUNCTION;
-  result->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
-  result->value.function.actual = mod_args;
-
-  /* Set factor = 180 / pi.  */
-  factor = gfc_get_constant_expr (rad->ts.type, rad->ts.kind, &rad->where);
-  mpfr_set_ui (factor->value.real, 180, GFC_RND_MODE);
-  mpfr_init (tmp);
-  mpfr_const_pi (tmp, GFC_RND_MODE);
-  mpfr_div (factor->value.real, factor->value.real, tmp, GFC_RND_MODE);
-  mpfr_clear (tmp);
-
-  /* Result is deg = (rad % 2pi) * (180 / pi).  */
-  result = gfc_multiply (result, factor);
-  return result;
-}
-
-
-/* Resolve a call to a trig function.  */
-
-static void
-resolve_trig_call (gfc_expr *f, gfc_expr *x)
-{
-  switch (f->value.function.isym->id)
-    {
-    case GFC_ISYM_ACOS:
-      return gfc_resolve_acos (f, x);
-    case GFC_ISYM_ASIN:
-      return gfc_resolve_asin (f, x);
-    case GFC_ISYM_ATAN:
-      return gfc_resolve_atan (f, x);
-    case GFC_ISYM_ATAN2:
-      /* NB. arg3 is unused for atan2 */
-      return gfc_resolve_atan2 (f, x, NULL);
-    case GFC_ISYM_COS:
-      return gfc_resolve_cos (f, x);
-    case GFC_ISYM_COTAN:
-      return gfc_resolve_cotan (f, x);
-    case GFC_ISYM_SIN:
-      return gfc_resolve_sin (f, x);
-    case GFC_ISYM_TAN:
-      return gfc_resolve_tan (f, x);
-    default:
-      gcc_unreachable ();
-    }
-}
-
-/* Resolve degree trig function as trigd (x) = trig (radians (x)).  */
-
-void
-gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
-{
-  if (is_trig_resolved (f))
-    return;
-
-  x = get_radians (x);
-  f->value.function.actual->expr = x;
-
-  resolve_trig_call (f, x);
-}
-
-
-/* Resolve degree inverse trig function as atrigd (x) = degrees (atrig (x)).  */
-
-void
-gfc_resolve_atrigd (gfc_expr *f, gfc_expr *x)
-{
-  gfc_expr *result, *fcopy;
-
-  if (is_trig_resolved (f))
-    return;
-
-  resolve_trig_call (f, x);
-
-  fcopy = copy_replace_function_shallow (f);
-  result = get_degrees (fcopy);
-  gfc_replace_expr (f, result);
-}
-
-
-/* Resolve atan2d(x) = degrees(atan2(x)).  */
-
-void
-gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
-{
-  /* Note that we lose the second arg here - that's okay because it is
-     unused in gfc_resolve_atan2 anyway.  */
-  gfc_resolve_atrigd (f, x);
-}
-
-
 /* Resolve failed_images (team, kind).  */
 
 void
@@ -3298,6 +3066,30 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 }
 
 
+/* Resolve the degree trignometric functions.  This amounts to setting
+   the function return type-spec from its argument and building a
+   library function names of the form _gfortran_sind_r4.  */
+
+void
+gfc_resolve_trigd (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s_%c%d"), f->value.function.isym->name,
+		      gfc_type_letter (x->ts.type), x->ts.kind);
+}
+
+
+void
+gfc_resolve_trigd2 (gfc_expr *f, gfc_expr *y, gfc_expr *x)
+{
+  f->ts = y->ts;
+  f->value.function.name
+    = gfc_get_string (PREFIX ("%s_%d"), f->value.function.isym->name,
+		      x->ts.kind);
+}
+
+
 void
 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {