OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Patch for PR94246

Browse Source
This commit is contained in:
Paul Thomas 2020-03-28 19:11:35 +00:00
parent 3fb7f2fbd5
commit 7d57570b06
4 changed files with 113 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2020-03-28 Paul Thomas <pault@gcc.gnu.org>
PR fortran/94246
* arith.c : Remove trailing white space.
* expr.c (scalarize_intrinsic_call): Remove the error checking.
Make a copy of the expression to be simplified and only replace
the original if the simplification succeeds.
2020-03-28 Tobias Burnus <tobias@codesourcery.com>
PR fortran/94348

10
gcc/fortran/arith.c
View File

@ -524,7 +524,7 @@ gfc_range_check (gfc_expr *e)
if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
if (rc == ARITH_OVERFLOW)
mpfr_set_inf (mpc_imagref (e->value.complex),
mpfr_set_inf (mpc_imagref (e->value.complex),
mpfr_sgn (mpc_imagref (e->value.complex)));
if (rc == ARITH_NAN)
mpfr_set_nan (mpc_imagref (e->value.complex));
@ -1100,7 +1100,7 @@ compare_complex (gfc_expr *op1, gfc_expr *op2)
/* Given two constant strings and the inverse collating sequence, compare the
strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
strings. We return -1 for a < b, 0 for a == b and 1 for a > b.
We use the processor's default collating sequence. */
int
@ -2176,7 +2176,7 @@ gfc_real2real (gfc_expr *src, int kind)
if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
{
int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
/* Calculate the difference between the constant and the rounded
value and check it against zero. */
@ -2358,7 +2358,7 @@ gfc_complex2real (gfc_expr *src, int kind)
/* Calculate the difference between the real constant and the rounded
value and check it against zero. */
if (kind > src->ts.kind
&& wprecision_real_real (mpc_realref (src->value.complex),
src->ts.kind, kind))
@ -2502,7 +2502,7 @@ gfc_character2character (gfc_expr *src, int kind)
return result;
}
/* Helper function to set the representation in a Hollerith conversion.
/* Helper function to set the representation in a Hollerith conversion.
This assumes that the ts.type and ts.kind of the result have already
been set. */

47
gcc/fortran/expr.c
View File

@ -2057,18 +2057,6 @@ simplify_parameter_variable (gfc_expr *p, int type)
}
gfc_expression_rank (p);
/* Is this an inquiry? */
bool inquiry = false;
gfc_ref* ref = p->ref;
while (ref)
{
if (ref->type == REF_INQUIRY)
break;
ref = ref->next;
}
if (ref && ref->type == REF_INQUIRY)
inquiry = ref->u.i == INQUIRY_LEN || ref->u.i == INQUIRY_KIND;
if (gfc_is_size_zero_array (p))
{
if (p->expr_type == EXPR_ARRAY)
@ -2081,22 +2069,15 @@ simplify_parameter_variable (gfc_expr *p, int type)
e->value.constructor = NULL;
e->shape = gfc_copy_shape (p->shape, p->rank);
e->where = p->where;
/* If %kind and %len are not used then we're done, otherwise
drop through for simplification. */
if (!inquiry)
{
gfc_replace_expr (p, e);
return true;
}
gfc_replace_expr (p, e);
return true;
}
else
{
e = gfc_copy_expr (p->symtree->n.sym->value);
if (e == NULL)
return false;
e->rank = p->rank;
}
e = gfc_copy_expr (p->symtree->n.sym->value);
if (e == NULL)
return false;
e->rank = p->rank;
if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL)
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, p->ts.u.cl);
@ -2145,6 +2126,7 @@ gfc_simplify_expr (gfc_expr *p, int type)
gfc_actual_arglist *ap;
gfc_intrinsic_sym* isym = NULL;
if (p == NULL)
return true;
@ -2314,9 +2296,8 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
gfc_constructor_base ctor;
gfc_constructor *args[5] = {}; /* Avoid uninitialized warnings. */
gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
gfc_expr *expr, *old, *p;
int n, i, rank[5], array_arg;
int errors = 0;
if (e == NULL)
return false;
@ -2384,8 +2365,6 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
n++;
}
gfc_get_errors (NULL, &errors);
/* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
@ -2419,8 +2398,12 @@ scalarize_intrinsic_call (gfc_expr *e, bool init_flag)
/* Simplify the function calls. If the simplification fails, the
error will be flagged up down-stream or the library will deal
with it. */
if (errors == 0)
gfc_simplify_expr (new_ctor->expr, 0);
p = gfc_copy_expr (new_ctor->expr);
if (!gfc_simplify_expr (p, init_flag))
gfc_free_expr (p);
else
gfc_replace_expr (new_ctor->expr, p);
for (i = 0; i < n; i++)
if (args[i])

85
gcc/testsuite/gfortran.dg/bessel_5_redux.f90 Normal file
View File

@ -0,0 +1,85 @@
! { dg-do compile }
! { dg-options "-Wall" }
!
! Check fix for PR94246 in which the errors in line 63 caused a segfault
! because the cleanup was not done correctly without the -fno-range-check option.
!
! This is a copy of bessel_5.f90 with the error messages added.
!
! -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
integer :: i
! Difference to mpfr_jn <= 1 epsilon
if (any (abs (BESSEL_JN(2, 5, 2.457) - [(BESSEL_JN(i, 2.457), i = 2, 5)]) &
> epsilon(0.0))) then
print *, 'FAIL 1'
STOP 1
end if
! Difference to mpfr_yn <= 4 epsilon
if (any (abs (BESSEL_YN(2, 5, 2.457) - [(BESSEL_YN(i, 2.457), i = 2, 5)]) &
> epsilon(0.0)*4)) then
STOP 2
end if
! Difference to mpfr_jn <= 1 epsilon
if (any (abs (BESSEL_JN(0, 10, 4.457) &
- [ (BESSEL_JN(i, 4.457), i = 0, 10) ]) &
> epsilon(0.0))) then
STOP 3
end if
! Difference to mpfr_yn <= 192 epsilon
if (any (abs (BESSEL_YN(0, 10, 4.457) &
- [ (BESSEL_YN(i, 4.457), i = 0, 10) ]) &
> epsilon(0.0)*192)) then
STOP 4
end if
! Difference to mpfr_jn: None. (Special case: X = 0.0)
if (any (BESSEL_JN(0, 10, 0.0) /= [ (BESSEL_JN(i, 0.0), i = 0, 10) ])) &
then
STOP 5
end if
! Difference to mpfr_yn: None. (Special case: X = 0.0)
if (any (BESSEL_YN(0, 10, 0.0) /= [ (BESSEL_YN(i, 0.0), i = 0, 10) ])) & ! { dg-error "overflows|-INF" }
then
STOP 6
end if
! Difference to mpfr_jn <= 1 epsilon
if (any (abs (BESSEL_JN(0, 10, 1.0) &
- [ (BESSEL_JN(i, 1.0), i = 0, 10) ]) &
> epsilon(0.0)*1)) then
STOP 7
end if
! Difference to mpfr_yn <= 32 epsilon
if (any (abs (BESSEL_YN(0, 10, 1.0) &
- [ (BESSEL_YN(i, 1.0), i = 0, 10) ]) &
> epsilon(0.0)*32)) then
STOP 8
end if
end