New flag -fdec-math for COTAN and degree trig intrinsics.

2016-10-11  Fritz Reese  <fritzoreese@gmail.com>

New flag -fdec-math for COTAN and degree trig intrinsics.

	gcc/fortran/
	* lang.opt: New flag -fdec-math.
	* options.c (set_dec_flags): Enable with -fdec.
	* invoke.texi, gfortran.texi, intrinsic.texi: Update documentation.
	* intrinsics.c (add_functions, do_simplify): New intrinsics
	with -fdec-math.
	* gfortran.h (gfc_isym_id): New isym GFC_ISYM_COTAN.
	* gfortran.h (gfc_resolve_atan2d, gfc_resolve_cotan,
	gfc_resolve_trigd, gfc_resolve_atrigd): New prototypes.
	* iresolve.c (resolve_trig_call, get_degrees, get_radians,
	is_trig_resolved, gfc_resolve_cotan, gfc_resolve_trigd,
	gfc_resolve_atrigd, gfc_resolve_atan2d): New functions.
	* intrinsics.h (gfc_simplify_atan2d, gfc_simplify_atrigd,
	gfc_simplify_cotan, gfc_simplify_trigd): New prototypes.
	* simplify.c (simplify_trig_call, degrees_f, radians_f,
	gfc_simplify_cotan, gfc_simplify_trigd, gfc_simplify_atrigd,
	gfc_simplify_atan2d): New functions.

	gcc/testsuite/gfortran.dg/
	* dec_math.f90: New testsuite.

From-SVN: r240989

1 files changed, 181 insertions, 0 deletions

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index ad547a1..bf60f74 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1706,6 +1706,152 @@ gfc_simplify_conjg (gfc_expr *e)
   return range_check (result, "CONJG");
 }
 
+/* Return the simplification of the constant expression in icall, or NULL
+   if the expression is not constant.  */
+
+static gfc_expr *
+simplify_trig_call (gfc_expr *icall)
+{
+  gfc_isym_id func = icall->value.function.isym->id;
+  gfc_expr *x = icall->value.function.actual->expr;
+
+  /* The actual simplifiers will return NULL for non-constant x.  */
+  switch (func)
+  {
+    case GFC_ISYM_ACOS:
+	return gfc_simplify_acos (x);
+    case GFC_ISYM_ASIN:
+	return gfc_simplify_asin (x);
+    case GFC_ISYM_ATAN:
+	return gfc_simplify_atan (x);
+    case GFC_ISYM_COS:
+	return gfc_simplify_cos (x);
+    case GFC_ISYM_COTAN:
+	return gfc_simplify_cotan (x);
+    case GFC_ISYM_SIN:
+	return gfc_simplify_sin (x);
+    case GFC_ISYM_TAN:
+	return gfc_simplify_tan (x);
+    default:
+	 break;
+  }
+
+  gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
+  return NULL;
+}
+
+/* Convert a floating-point number from radians to degrees.  */
+
+static void
+degrees_f (mpfr_t x, mp_rnd_t rnd_mode)
+{
+    mpfr_t tmp;
+    mpfr_init (tmp);
+
+    /* Set x = x % 2pi to avoid offsets with large angles.  */
+    mpfr_const_pi (tmp, rnd_mode);
+    mpfr_mul_ui (tmp, tmp, 2, rnd_mode);
+    mpfr_fmod (tmp, x, tmp, rnd_mode);
+
+    /* Set x = x * 180.  */
+    mpfr_mul_d (x, x, 180.0, rnd_mode);
+
+    /* Set x = x / pi.  */
+    mpfr_const_pi (tmp, rnd_mode);
+    mpfr_div (x, x, tmp, rnd_mode);
+
+    mpfr_clear (tmp);
+}
+
+/* Convert a floating-point number from degrees to radians.  */
+
+static void
+radians_f (mpfr_t x, mp_rnd_t rnd_mode)
+{
+    mpfr_t tmp;
+    mpfr_init (tmp);
+
+    /* Set x = x % 360 to avoid offsets with large angles.  */
+    mpfr_fmod_d (tmp, x, 360.0, rnd_mode);
+
+    /* Set x = x * pi.  */
+    mpfr_const_pi (tmp, rnd_mode);
+    mpfr_mul (x, x, tmp, rnd_mode);
+
+    /* Set x = x / 180.  */
+    mpfr_div_d (x, x, 180.0, rnd_mode);
+
+    mpfr_clear (tmp);
+}
+
+
+/* Convert argument to radians before calling a trig function.  */
+
+gfc_expr *
+gfc_simplify_trigd (gfc_expr *icall)
+{
+  gfc_expr *arg;
+
+  arg = icall->value.function.actual->expr;
+
+  if (arg->ts.type != BT_REAL)
+    gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
+
+  if (arg->expr_type == EXPR_CONSTANT)
+    /* Convert constant to radians before passing off to simplifier.  */
+    radians_f (arg->value.real, GFC_RND_MODE);
+
+  /* Let the usual simplifier take over - we just simplified the arg.  */
+  return simplify_trig_call (icall);
+}
+
+/* Convert result of an inverse trig function to degrees.  */
+
+gfc_expr *
+gfc_simplify_atrigd (gfc_expr *icall)
+{
+  gfc_expr *result;
+
+  if (icall->value.function.actual->expr->ts.type != BT_REAL)
+    gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
+
+  /* See if another simplifier has work to do first.  */
+  result = simplify_trig_call (icall);
+
+  if (result && result->expr_type == EXPR_CONSTANT)
+  {
+      /* Convert constant to degrees after passing off to actual simplifier.  */
+      degrees_f (result->value.real, GFC_RND_MODE);
+      return result;
+  }
+
+  /* Let gfc_resolve_atrigd take care of the non-constant case.  */
+  return NULL;
+}
+
+/* Convert the result of atan2 to degrees.  */
+
+gfc_expr *
+gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
+{
+  gfc_expr *result;
+
+  if (x->ts.type != BT_REAL || y->ts.type != BT_REAL)
+    gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
+
+  if (x->expr_type == EXPR_CONSTANT && y->expr_type == EXPR_CONSTANT)
+    {
+      result = gfc_simplify_atan2 (y, x);
+      if (result != NULL)
+	{
+	  degrees_f (result->value.real, GFC_RND_MODE);
+	  return result;
+	}
+    }
+
+  /* Let gfc_resolve_atan2d take care of the non-constant case.  */
+  return NULL;
+}
 
 gfc_expr *
 gfc_simplify_cos (gfc_expr *x)
@@ -6244,6 +6390,41 @@ gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
 
 
 gfc_expr *
+gfc_simplify_cotan (gfc_expr *x)
+{
+  gfc_expr *result;
+  mpc_t swp, *val;
+
+  if (x->expr_type != EXPR_CONSTANT)
+    return NULL;
+
+  result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+  switch (x->ts.type)
+    {
+      case BT_REAL:
+	mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
+	break;
+
+      case BT_COMPLEX:
+	/* There is no builtin mpc_cot, so compute cot = cos / sin.  */
+	val = &result->value.complex;
+	mpc_init2 (swp, mpfr_get_default_prec ());
+	mpc_cos (swp, x->value.complex, GFC_MPC_RND_MODE);
+	mpc_sin (*val, x->value.complex, GFC_MPC_RND_MODE);
+	mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
+	mpc_clear (swp);
+	break;
+
+      default:
+	gcc_unreachable ();
+    }
+
+  return range_check (result, "COTAN");
+}
+
+
+gfc_expr *
 gfc_simplify_tan (gfc_expr *x)
 {
   gfc_expr *result;