Fortran: Escalate failure when Hollerith constant to real conversion fails

gcc/fortran/
	PR target/103628
	* target-memory.cc (gfc_interpret_float): Return FAIL when
	native_interpret_expr gets a NULL tree.
	* arith.cc (gfc_hollerith2real): Return NULL when
	gfc_interpret_float fails.
	* error.cc (gfc_buffered_p): Define.
	* gfortran.h (gfc_buffered_p): Declare.
	* intrinsic.cc: Add diagnostic.h to include list.
	(do_simplify): Save errorcount and check it at finish.  Report a
	"Cannot simplify expression" error on a bad result if error count
	doesn't change and no other errors buffered.

gcc/testsuite/
	PR target/103628
	* gfortran.dg/assumed_size_refs_2.f90: Check "Cannot simplify
	expression" error.
	* gfortran.dg/unpack_field_1.f90: Likewise.
	* gfortran.dg/pr103628.f90: New.

Co-Authored-By: Tobias Burnus <tobias@codesourcery.com>

5 files changed, 29 insertions, 9 deletions

diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc
index 37aeaf1..ddf9874 100644
--- a/gcc/fortran/arith.cc
+++ b/gcc/fortran/arith.cc
@@ -2753,10 +2753,12 @@ gfc_hollerith2real (gfc_expr *src, int kind)
   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
 
   hollerith2representation (result, src);
-  gfc_interpret_float (kind, (unsigned char *) result->representation.string,
-		       result->representation.length, result->value.real);
-
-  return result;
+  if (gfc_interpret_float (kind,
+			   (unsigned char *) result->representation.string,
+			   result->representation.length, result->value.real))
+    return result;
+  else
+    return NULL;
 }
 
 /* Convert character to real.  The constant will be padded or truncated.  */
diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc
index 05d3a0e..6cae672 100644
--- a/gcc/fortran/error.cc
+++ b/gcc/fortran/error.cc
@@ -49,6 +49,13 @@ static gfc_error_buffer error_buffer;
 static output_buffer *pp_error_buffer, *pp_warning_buffer;
 static int warningcount_buffered, werrorcount_buffered;
 
+/* Return buffered_p.  */
+bool
+gfc_buffered_p (void)
+{
+  return buffered_p;
+}
+
 /* Return true if there output_buffer is empty.  */
 
 static bool
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 9bab2c4..130d5d7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3331,6 +3331,7 @@ void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC
 void gfc_clear_error (void);
 bool gfc_error_check (void);
 bool gfc_error_flag_test (void);
+bool gfc_buffered_p (void);
 
 notification gfc_notification_std (int);
 bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3);
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 64821c8..1a26b7a 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -25,6 +25,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "options.h"
 #include "gfortran.h"
 #include "intrinsic.h"
+#include "diagnostic.h" /* For errorcount.  */
 
 /* Namespace to hold the resolved symbols for intrinsic subroutines.  */
 static gfc_namespace *gfc_intrinsic_namespace;
@@ -4620,6 +4621,7 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
 {
   gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6;
   gfc_actual_arglist *arg;
+  int old_errorcount = errorcount;
 
   /* Max and min require special handling due to the variable number
      of args.  */
@@ -4708,7 +4710,12 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
 
 finish:
   if (result == &gfc_bad_expr)
-    return false;
+    {
+      if (errorcount == old_errorcount
+	  && (!gfc_buffered_p () || !gfc_error_flag_test ()))
+       gfc_error ("Cannot simplify expression at %L", &e->where);
+      return false;
+    }
 
   if (result == NULL)
     resolve_intrinsic (specific, e);	/* Must call at run-time */
diff --git a/gcc/fortran/target-memory.cc b/gcc/fortran/target-memory.cc
index 05b8255..edc30bd 100644
--- a/gcc/fortran/target-memory.cc
+++ b/gcc/fortran/target-memory.cc
@@ -416,11 +416,14 @@ gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 		     mpfr_t real)
 {
   gfc_set_model_kind (kind);
-  mpfr_init (real);
-  gfc_conv_tree_to_mpfr (real,
-			 native_interpret_expr (gfc_get_real_type (kind),
-						buffer, buffer_size));
 
+  tree source = native_interpret_expr (gfc_get_real_type (kind), buffer,
+				       buffer_size);
+  if (!source)
+    return 0;
+
+  mpfr_init (real);
+  gfc_conv_tree_to_mpfr (real, source);
   return size_float (kind);
 }