Patch for PR94246

gcc/fortran/ChangeLog

+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

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.  */
 

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])

gcc/testsuite/gfortran.dg/bessel_5_redux.f90

+! { 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