aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/simplify.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/simplify.cc')
-rw-r--r--gcc/fortran/simplify.cc264
1 files changed, 256 insertions, 8 deletions
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 1927097..b25cd2c 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -885,7 +885,8 @@ gfc_simplify_acos (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ACOS at %L must be between -1 and 1",
+ gfc_error ("Argument of ACOS at %L must be within the closed "
+ "interval [-1, 1]",
&x->where);
return &gfc_bad_expr;
}
@@ -1162,7 +1163,8 @@ gfc_simplify_asin (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ASIN at %L must be between -1 and 1",
+ gfc_error ("Argument of ASIN at %L must be within the closed "
+ "interval [-1, 1]",
&x->where);
return &gfc_bad_expr;
}
@@ -1213,8 +1215,9 @@ gfc_simplify_acosd (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ACOSD at %L must be between -1 and 1",
- &x->where);
+ gfc_error (
+ "Argument of ACOSD at %L must be within the closed interval [-1, 1]",
+ &x->where);
return &gfc_bad_expr;
}
@@ -1243,8 +1246,9 @@ gfc_simplify_asind (gfc_expr *x)
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
- gfc_error ("Argument of ASIND at %L must be between -1 and 1",
- &x->where);
+ gfc_error (
+ "Argument of ASIND at %L must be within the closed interval [-1, 1]",
+ &x->where);
return &gfc_bad_expr;
}
@@ -1383,7 +1387,7 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
- gfc_error ("If first argument of ATAN2 at %L is zero, then the "
+ gfc_error ("If the first argument of ATAN2 at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
@@ -1962,7 +1966,7 @@ gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
- gfc_error ("If first argument of ATAN2D at %L is zero, then the "
+ gfc_error ("If the first argument of ATAN2D at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
@@ -2151,6 +2155,250 @@ gfc_simplify_cosh (gfc_expr *x)
return range_check (result, "COSH");
}
+gfc_expr *
+gfc_simplify_acospi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error (
+ "Argument of ACOSPI at %L must be within the closed interval [-1, 1]",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_acospi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_acos (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return result;
+}
+
+gfc_expr *
+gfc_simplify_asinpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) > 0 || mpfr_cmp_si (x->value.real, -1) < 0)
+ {
+ gfc_error (
+ "Argument of ASINPI at %L must be within the closed interval [-1, 1]",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_asinpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_asin (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return result;
+}
+
+gfc_expr *
+gfc_simplify_atanpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_atanpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_atan (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return range_check (result, "ATANPI");
+}
+
+gfc_expr *
+gfc_simplify_atan2pi (gfc_expr *y, gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
+ {
+ gfc_error ("If the first argument of ATAN2PI at %L is zero, then the "
+ "second argument must not be zero",
+ &y->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_atan2pi (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t pi, tmp;
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), pi, tmp, NULL);
+ mpfr_const_pi (pi, GFC_RND_MODE);
+ mpfr_atan2 (tmp, y->value.real, x->value.real, GFC_RND_MODE);
+ mpfr_div (result->value.real, tmp, pi, GFC_RND_MODE);
+ mpfr_clears (pi, tmp, NULL);
+#endif
+
+ return range_check (result, "ATAN2PI");
+}
+
+gfc_expr *
+gfc_simplify_cospi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_cospi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t cs, n, r, two;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), cs, n, r, two, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.5) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ mpfr_set_ui (two, 2, GFC_RND_MODE);
+ mpfr_fmod (cs, n, two, GFC_RND_MODE);
+ s = mpfr_cmp_ui (cs, 0) == 0 ? 1 : -1;
+
+ mpfr_const_pi (cs, GFC_RND_MODE);
+ mpfr_mul (cs, cs, r, GFC_RND_MODE);
+ mpfr_cos (cs, cs, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, cs, s, GFC_RND_MODE);
+
+ mpfr_clears (cs, n, r, two, NULL);
+#endif
+
+ return range_check (result, "COSPI");
+}
+
+gfc_expr *
+gfc_simplify_sinpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_sinpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t sn, n, r, two;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), sn, n, r, two, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.0) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ mpfr_set_ui (two, 2, GFC_RND_MODE);
+ mpfr_fmod (sn, n, two, GFC_RND_MODE);
+ s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1;
+ s *= mpfr_cmp_ui (sn, 0) == 0 ? 1 : -1;
+
+ mpfr_const_pi (sn, GFC_RND_MODE);
+ mpfr_mul (sn, sn, r, GFC_RND_MODE);
+ mpfr_sin (sn, sn, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, sn, s, GFC_RND_MODE);
+
+ mpfr_clears (sn, n, r, two, NULL);
+#endif
+
+ return range_check (result, "SINPI");
+}
+
+gfc_expr *
+gfc_simplify_tanpi (gfc_expr *x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+#if MPFR_VERSION >= MPFR_VERSION_NUM(4, 2, 0)
+ mpfr_tanpi (result->value.real, x->value.real, GFC_RND_MODE);
+#else
+ mpfr_t tn, n, r;
+ int s;
+
+ mpfr_inits2 (2 * mpfr_get_prec (x->value.real), tn, n, r, NULL);
+
+ mpfr_abs (r, x->value.real, GFC_RND_MODE);
+ mpfr_modf (n, r, r, GFC_RND_MODE);
+
+ if (mpfr_cmp_d (r, 0.0) == 0)
+ {
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ return result;
+ }
+
+ s = mpfr_cmp_si (x->value.real, 0) < 0 ? -1 : 1;
+
+ mpfr_const_pi (tn, GFC_RND_MODE);
+ mpfr_mul (tn, tn, r, GFC_RND_MODE);
+ mpfr_tan (tn, tn, GFC_RND_MODE);
+ mpfr_mul_si (result->value.real, tn, s, GFC_RND_MODE);
+
+ mpfr_clears (tn, n, r, NULL);
+#endif
+
+ return range_check (result, "TANPI");
+}
gfc_expr *
gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
generated by cgit v1.1 at 2025-05-30 16:07:01 +0000