2010-08-17 Tobias Burnus <burnus@net-b.de>
PR fortran/36158
PR fortran/33197
* check.c (gfc_check_bessel_n2): New function.
* gfortran.h (gfc_isym_id): Add GFC_ISYM_JN2 and GFC_ISYM_YN2.
* intrinsic.c (add_functions): Add transformational version
of the Bessel_jn/yn intrinsics.
* intrinsic.h (gfc_check_bessel_n2,gfc_simplify_bessel_jn2,
gfc_simplify_bessel_yn2): New prototypes.
* intrinsic.texi (Bessel_jn, Bessel_yn): Document
transformational variant.
* simplify.c (gfc_simplify_bessel_jn, gfc_simplify_bessel_yn):
Check for negative order.
(gfc_simplify_bessel_n2,gfc_simplify_bessel_jn2,
gfc_simplify_bessel_yn2): New functions.
2010-08-17 Tobias Burnus <burnus@net-b.de>
PR fortran/36158
PR fortran/33197
* gfortran.dg/bessel_3.f90: New.
* gfortran.dg/bessel_4.f90: New.
* gfortran.dg/bessel_5.f90: New.
===================================================================
@@ -892,6 +892,31 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x
}
+/* Transformational version of the Bessel JN and YN functions. */
+
+gfc_try
+gfc_check_bessel_n2 (gfc_expr *n1, gfc_expr *n2, gfc_expr *x)
+{
+ if (type_check (n1, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (scalar_check (n1, 0) == FAILURE)
+ return FAILURE;
+
+
+ if (type_check (n2, 1, BT_INTEGER) == FAILURE)
+ return FAILURE;
+ if (scalar_check (n2, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (x, 2, BT_REAL) == FAILURE)
+ return FAILURE;
+ if (scalar_check (x, 0) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
gfc_try
gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos)
{
===================================================================
@@ -422,6 +422,7 @@ enum gfc_isym_id
GFC_ISYM_J0,
GFC_ISYM_J1,
GFC_ISYM_JN,
+ GFC_ISYM_JN2,
GFC_ISYM_KILL,
GFC_ISYM_KIND,
GFC_ISYM_LBOUND,
@@ -531,7 +532,8 @@ enum gfc_isym_id
GFC_ISYM_XOR,
GFC_ISYM_Y0,
GFC_ISYM_Y1,
- GFC_ISYM_YN
+ GFC_ISYM_YN,
+ GFC_ISYM_YN2
};
typedef enum gfc_isym_id gfc_isym_id;
===================================================================
@@ -1317,6 +1317,11 @@ add_functions (void)
gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
+ add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+ gfc_check_bessel_n2, gfc_simplify_bessel_jn2, NULL,
+ "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
+ x, BT_REAL, dr, 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,
@@ -1353,6 +1358,11 @@ add_functions (void)
gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
+ add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
+ gfc_check_bessel_n2, gfc_simplify_bessel_yn2, NULL,
+ "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED,
+ x, BT_REAL, dr, REQUIRED);
+
make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
===================================================================
@@ -40,6 +40,7 @@ gfc_try gfc_check_associated (gfc_expr *
gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_besn (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_bitfcn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_char (gfc_expr *, gfc_expr *);
gfc_try gfc_check_chdir (gfc_expr *);
@@ -223,9 +224,11 @@ gfc_expr *gfc_simplify_atan2 (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_jn2 (gfc_expr *, 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_bessel_yn2 (gfc_expr *, 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 *);
===================================================================
@@ -1630,23 +1630,31 @@ end program test_besj1
@item @emph{Description}:
@code{BESSEL_JN(N, X)} computes the Bessel function of the first kind of
order @var{N} of @var{X}. This function is available under the name
-@code{BESJN} as a GNU extension.
+@code{BESJN} as a GNU extension. If @var{N} and @var{X} are arrays,
+their ranks and shapes shall conform.
-If both arguments are arrays, their ranks and shapes shall conform.
+@code{BESSEL_JN(N1, N2, X)} returns an array with the Bessel functions
+of the first kind of the orders @var{N1} to @var{N2}.
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later, negative @var{N}, @var{N1}, @var{N2} are
+allowed as GNU extension
@item @emph{Class}:
-Elemental function
+Elemental function, except for the tranformational function
+@code{BESSEL_JN(N1, N2, X)}
@item @emph{Syntax}:
@code{RESULT = BESSEL_JN(N, X)}
+@code{RESULT = BESSEL_JN(N1, N2, X)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}.
+@item @var{N1} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{N2} @tab Shall be a scalar of type @code{INTEGER}.
@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}.
+for @code{BESSEL_JN(N1, N2, X)} it shall be scalar.
@end multitable
@item @emph{Return value}:
@@ -1778,23 +1786,31 @@ end program test_besy1
@item @emph{Description}:
@code{BESSEL_YN(N, X)} computes the Bessel function of the second kind of
order @var{N} of @var{X}. This function is available under the name
-@code{BESYN} as a GNU extension.
+@code{BESYN} as a GNU extension. If @var{N} and @var{X} are arrays,
+their ranks and shapes shall conform.
-If both arguments are arrays, their ranks and shapes shall conform.
+@code{BESSEL_YN(N1, N2, X)} returns an array with the Bessel functions
+of the first kind of the orders @var{N1} to @var{N2}.
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later, negative @var{N}, @var{N1}, @var{N2} are
+allowed as GNU extension
@item @emph{Class}:
-Elemental function
+Elemental function, except for the tranformational function
+@code{BESSEL_YN(N1, N2, X)}
@item @emph{Syntax}:
@code{RESULT = BESSEL_YN(N, X)}
+@code{RESULT = BESSEL_YN(N1, N2, X)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER}.
-@item @var{X} @tab Shall be a scalar or an array of type @code{REAL}.
+@item @var{N} @tab Shall be a scalar or an array of type @code{INTEGER} .
+@item @var{N1} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{N2} @tab Shall be a scalar of type @code{INTEGER}.
+@item @var{X} @tab Shall be a scalar or an array of type @code{REAL};
+for @code{BESSEL_JN(N1, N2, X)} it shall be scalar.
@end multitable
@item @emph{Return value}:
===================================================================
@@ -1183,12 +1183,19 @@ gfc_expr *
gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
- long n;
+ long n = 0;
+
+ if (order->expr_type == EXPR_CONSTANT)
+ {
+ n = mpz_get_si (order->value.integer);
+ if (n < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negativ argument "
+ "N at %L", &order->where) == FAILURE)
+ return &gfc_bad_expr;
+ }
if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
return NULL;
- n = mpz_get_si (order->value.integer);
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
@@ -1196,6 +1203,72 @@ gfc_simplify_bessel_jn (gfc_expr *order,
}
+/* Simplify transformational form of JN and YN. */
+
+static gfc_expr *
+gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
+ bool jn)
+{
+ gfc_expr *result;
+ long n1 = 0, n2 = 0;
+ int i;
+
+ if (order1->expr_type == EXPR_CONSTANT)
+ {
+ n1 = mpz_get_si (order1->value.integer);
+ if (n1 < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negativ argument "
+ "N1 at %L", &order1->where) == FAILURE)
+ return &gfc_bad_expr;
+ }
+
+ if (order2->expr_type == EXPR_CONSTANT)
+ {
+ n2 = mpz_get_si (order2->value.integer);
+ if (n2 < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negativ argument "
+ "N2 at %L", &order2->where) == FAILURE)
+ return &gfc_bad_expr;
+ }
+
+ if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
+ || order2->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Sorry, non-constant transformational Bessel function at %L"
+ " not yet supported", &order2->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
+ result->rank = 1;
+ result->shape = gfc_get_shape (1);
+ mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
+
+ for (i = n1; i <= n2; ++i)
+ {
+ gfc_expr *e;
+
+ e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
+ if (jn)
+ mpfr_jn (e->value.real, i, x->value.real, GFC_RND_MODE);
+ else
+ mpfr_yn (e->value.real, i, x->value.real, GFC_RND_MODE);
+
+ if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
+ return &gfc_bad_expr;
+ gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
+ }
+
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+ return gfc_simplify_bessel_n2 (order1, order2, x, true);
+}
+
+
gfc_expr *
gfc_simplify_bessel_y0 (gfc_expr *x)
{
@@ -1230,12 +1303,19 @@ gfc_expr *
gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
- long n;
+ long n = 0;
+
+ if (order->expr_type == EXPR_CONSTANT)
+ {
+ n = mpz_get_si (order->value.integer);
+ if (n < 0 && gfc_notify_std (GFC_STD_GNU, "Extension: Negativ argument "
+ "N at %L", &order->where) == FAILURE)
+ return &gfc_bad_expr;
+ }
if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
return NULL;
- n = mpz_get_si (order->value.integer);
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
@@ -1243,6 +1323,13 @@ gfc_simplify_bessel_yn (gfc_expr *order,
}
+gfc_expr *
+gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
+{
+ return gfc_simplify_bessel_n2 (order1, order2, x, false);
+}
+
+
gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
===================================================================
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-std=f2003 -Wimplicit-procedure" }
+!
+! PR fortran/36158 - Transformational BESSEL_JN/YN
+! PR fortran/33197 - F2008 math functions
+!
+IMPLICIT NONE
+print *, SIN (1.0)
+print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" })
+print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type" }
+
+print *, BESSEL_Y0(1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_Y1(1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type" }
+print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type" }
+end
===================================================================
@@ -0,0 +1,16 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/36158 - Transformational BESSEL_JN/YN
+! PR fortran/33197 - F2008 math functions
+!
+implicit none
+! OK, elemental function:
+ print *, bessel_yn(1, [1.0, 2.0])
+ print *, bessel_yn([1, 2], 2.0)
+! Wrong, transformational function:
+ print *, bessel_yn(1, 2, [2.0, 3.0]) ! { dg-error "Too many arguments" }
+! Wrong in F2008: Negative argument, ok as GNU extension
+ print *, bessel_yn(-1, 3.0) ! { dg-error "Extension: Negativ argument N " }
+ print *, bessel_yn(-1, 2, 3.0) ! { dg-error "Extension: Negativ argument N1" }
+end
===================================================================
@@ -0,0 +1,35 @@
+! { dg-do run }
+! { dg-options "-Wall" }
+!
+! PR fortran/36158 - Transformational BESSEL_JN/YN
+! PR fortran/33197 - F2008 math functions
+!
+! This is a dg-do run test as the middle end cannot simplify the
+! the scalarization of the elemental function (cf. PR 45305).
+!
+! -Wall has been specified to disabled -pedantic, which warns about the
+! negative order (GNU extension) to the order of the Bessel functions of
+! first and second kind.
+!
+implicit none
+if (any (abs (BESSEL_JN(2, 5, 2.457) - BESSEL_JN([2,3,4,5], 2.457)) &
+ > epsilon(0.0))) &
+ call abort()
+if (any (abs (BESSEL_YN(2, 5, 2.457) - BESSEL_YN([2,3,4,5], 2.457)) &
+ > epsilon(0.0))) &
+ call abort()
+if (any (abs (BESSEL_JN(-1, 1, 2.457) &
+ - [ BESSEL_JN(-1, 2.457), BESSEL_JN(0, 2.457), BESSEL_JN(1, 2.457) ]) &
+ > epsilon(0.0))) &
+ call abort()
+if (any (abs (BESSEL_YN(-1, 1, 2.457) &
+ - [ BESSEL_YN(-1, 2.457), BESSEL_YN(0, 2.457), BESSEL_YN(1, 2.457) ]) &
+ > epsilon(0.0))) &
+ call abort()
+if (any (abs (BESSEL_JN(0, 1, 2.457) - [BESSEL_J0(2.457), BESSEL_J1(2.457)]) &
+ > epsilon(0.0))) &
+ call abort()
+if (any (abs (BESSEL_YN(0, 1, 2.457) - [BESSEL_Y0(2.457), BESSEL_Y1(2.457)]) &
+ > epsilon(0.0))) &
+ call abort()
+end