This turned out to be relatively trivial, following a fair amount of head scratching:-(
Regtests on FC31/x64_86 - OK for both branches? Paul 2020-03-26 Paul Thomas <pa...@gcc.gnu.org> PR fortran/94246 * 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-26 Paul Thomas <pa...@gcc.gnu.org> PR fortran/94246 * gfortran.dg/bessel_5_redux.f90 : New test. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 79e00b4112a..1106341df91 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2296,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; @@ -2366,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. */ @@ -2401,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])
! { 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