From 7d57570b0658b8c1b8a97dafa53dfd4ab4bd3f65 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 28 Mar 2020 19:11:35 +0000 Subject: [PATCH] Patch for PR94246 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/arith.c | 10 +-- gcc/fortran/expr.c | 47 ++++------- gcc/testsuite/gfortran.dg/bessel_5_redux.f90 | 85 ++++++++++++++++++++ 4 files changed, 113 insertions(+), 37 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bessel_5_redux.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 48bf8bfc7fa..217eef29eba 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2020-03-28 Paul Thomas + + 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 PR fortran/94348 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index 7eb82d0ea5e..422ef40c431 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -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. */ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 08b0a92655a..1106341df91 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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]) diff --git a/gcc/testsuite/gfortran.dg/bessel_5_redux.f90 b/gcc/testsuite/gfortran.dg/bessel_5_redux.f90 new file mode 100644 index 00000000000..72d2db43959 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bessel_5_redux.f90 @@ -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 -- 2.30.2