aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
authorTobias Burnus <burnus@net-b.de>2008-05-06 19:06:54 +0200
committerTobias Burnus <burnus@gcc.gnu.org>2008-05-06 19:06:54 +0200
commit3c3f4265021e8940d6a57234b7f70b0dbbc05b3a (patch)
tree0de6d06ee3109c2ff08c4951bcfc68a150f4cb9c /gcc/fortran
parent4317a2fa5139e7c4398e15213d73ad66e0f98c32 (diff)
downloadgcc-3c3f4265021e8940d6a57234b7f70b0dbbc05b3a.zip
gcc-3c3f4265021e8940d6a57234b7f70b0dbbc05b3a.tar.gz
gcc-3c3f4265021e8940d6a57234b7f70b0dbbc05b3a.tar.bz2
re PR fortran/36117 (Use MPFR for bessel function (optimization, rejects valid F2008))
2008-05-06 Tobias Burnus <burnus@net-b.de> PR fortran/36117 * intrinsic.c (add_functions): Call gfc_simplify_bessel_*. * intrinsic.h: Add prototypes for gfc_simplify_bessel_*. * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1, gfc_simplify_bessel_jn,gfc_simplify_bessel_y0, gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): New. 2008-05-06 Tobias Burnus <burnus@net-b.de> PR fortran/36117 * gfortran.dg/bessel_2.f90: New. From-SVN: r134988
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog9
-rw-r--r--gcc/fortran/intrinsic.c24
-rw-r--r--gcc/fortran/intrinsic.h6
-rw-r--r--gcc/fortran/simplify.c124
4 files changed, 151 insertions, 12 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index de9c781..83d3bcd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2008-05-06 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/36117
+ * intrinsic.c (add_functions): Call gfc_simplify_bessel_*.
+ * intrinsic.h: Add prototypes for gfc_simplify_bessel_*.
+ * simplify.c (gfc_simplify_bessel_j0,gfc_simplify_bessel_j1,
+ gfc_simplify_bessel_jn,gfc_simplify_bessel_y0,
+ gfc_simplify_bessel_y1,gfc_simplify_bessel_yn): New.
+
2008-05-03 Janus Weil <jaydub66@gmail.com>
* misc.c (gfc_clear_ts): Set interface to NULL.
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 441fbec..f638127 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -1095,73 +1095,73 @@ add_functions (void)
/* Bessel and Neumann functions for G77 compatibility. */
add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_j0", GFC_STD_F2008);
add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008);
add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_j1", GFC_STD_F2008);
add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008);
add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_besn, NULL, gfc_resolve_besn,
+ gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_jn", GFC_STD_F2008);
add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_besn, NULL, gfc_resolve_besn,
+ gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008);
add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_y0", GFC_STD_F2008);
add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008);
add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_y1", GFC_STD_F2008);
add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_fn_d, NULL, gfc_resolve_g77_math1,
+ gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008);
add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
- gfc_check_besn, NULL, gfc_resolve_besn,
+ gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
make_alias ("bessel_yn", GFC_STD_F2008);
add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
- gfc_check_besn, NULL, gfc_resolve_besn,
+ gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 91645fb..ac996b6 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -208,6 +208,12 @@ gfc_expr *gfc_simplify_asinh (gfc_expr *);
gfc_expr *gfc_simplify_atan (gfc_expr *);
gfc_expr *gfc_simplify_atanh (gfc_expr *);
gfc_expr *gfc_simplify_atan2 (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_j0 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_j1 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_jn (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_bessel_y0 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_y1 (gfc_expr *);
+gfc_expr *gfc_simplify_bessel_yn (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_bit_size (gfc_expr *);
gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index cde4770..bf9e00a 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -637,6 +637,130 @@ gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
gfc_expr *
+gfc_simplify_bessel_j0 (gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J0");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_j1 (gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_J1");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_JN");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y0 (gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y0");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_y1 (gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_Y1");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
+{
+#if MPFR_VERSION >= MPFR_VERSION_NUM(2,3,0)
+ gfc_expr *result;
+ long n;
+
+ if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ n = mpz_get_si (order->value.integer);
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "BESSEL_YN");
+#else
+ return NULL;
+#endif
+}
+
+
+gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
gfc_expr *result;