PR fortran/68401 Improve allocation error message

Improve the error message that is printed when a memory allocation
fails, by including the location, and the size of the allocation that
failed.

Regtested on x86_64-pc-linux-gnu.

gcc/fortran/ChangeLog:

2019-08-17  Janne Blomqvist  <jb@gcc.gnu.org>

	PR fortran/68401
	* trans-decl.c (gfc_build_builtin_function_decls): Replace
	os_error with os_error_at decl.
	* trans.c (trans_runtime_error_vararg): Modify so the error
	function decl is passed directly.
	(gfc_trans_runtime_error): Pass correct error function decl.
	(gfc_trans_runtime_check): Likewise.
	(trans_os_error_at): New function.
	(gfc_call_malloc): Use trans_os_error_at.
	(gfc_allocate_using_malloc): Likewise.
	(gfc_call_realloc): Likewise.
	* trans.h (gfor_fndecl_os_error): Replace with gfor_fndecl_os_error_at.

libgfortran/ChangeLog:

2019-08-17  Janne Blomqvist  <jb@gcc.gnu.org>

	PR fortran/68401
	* gfortran.map: Add GFORTRAN_10 node, add _gfortran_os_error_at
	symbol.
	* libgfortran.h (os_error_at): New prototype.
	* runtime/error.c (os_error_at): New function.

From-SVN: r274599

8 files changed, 126 insertions, 36 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index bab69f3..a3b9e6b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2019-08-17  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/68401
+	* trans-decl.c (gfc_build_builtin_function_decls): Replace
+	os_error with os_error_at decl.
+	* trans.c (trans_runtime_error_vararg): Modify so the error
+	function decl is passed directly.
+	(gfc_trans_runtime_error): Pass correct error function decl.
+	(gfc_trans_runtime_check): Likewise.
+	(trans_os_error_at): New function.
+	(gfc_call_malloc): Use trans_os_error_at.
+	(gfc_allocate_using_malloc): Likewise.
+	(gfc_call_realloc): Likewise.
+	* trans.h (gfor_fndecl_os_error): Replace with gfor_fndecl_os_error_at.
+
 2019-08-16  Jeff Law <law@redhat.com>
 	    Mark Eggleston <mark.eggleston@codethink.com>
 
@@ -18,7 +33,7 @@
 	* trans-common.c (find_equivalence) : New local variable dummy_symbol,
 	accumulated equivalence attributes from each symbol then check for
 	conflicts.
-  
+
 2019-08-16  Richard Biener  <rguenther@suse.de>
 
 	* trans-intrinsic.c (gfc_conv_intrinsic_findloc): Initialize
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2a9b852..3c6ab60 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -102,7 +102,7 @@ tree gfor_fndecl_error_stop_string;
 tree gfor_fndecl_runtime_error;
 tree gfor_fndecl_runtime_error_at;
 tree gfor_fndecl_runtime_warning_at;
-tree gfor_fndecl_os_error;
+tree gfor_fndecl_os_error_at;
 tree gfor_fndecl_generate_error;
 tree gfor_fndecl_set_args;
 tree gfor_fndecl_set_fpe;
@@ -3679,11 +3679,11 @@ gfc_build_builtin_function_decls (void)
 	void_type_node, 3, pvoid_type_node, integer_type_node,
 	pchar_type_node);
 
-  gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
-	get_identifier (PREFIX("os_error")), ".R",
-	void_type_node, 1, pchar_type_node);
-  /* The runtime_error function does not return.  */
-  TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
+  gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("os_error_at")), ".RR",
+	void_type_node, -2, pchar_type_node, pchar_type_node);
+  /* The os_error_at function does not return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1;
 
   gfor_fndecl_set_args = gfc_build_library_function_decl (
 	get_identifier (PREFIX("set_args")),
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 8451147..583f6e3 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -447,7 +447,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
    arguments and a locus.  */
 
 static tree
-trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
+trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid,
 			    va_list ap)
 {
   stmtblock_t block;
@@ -501,18 +501,13 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
   /* Build the function call to runtime_(warning,error)_at; because of the
      variable number of arguments, we can't use build_call_expr_loc dinput_location,
      irectly.  */
-  if (error)
-    fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
-  else
-    fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
+  fntype = TREE_TYPE (errorfunc);
 
   loc = where ? where->lb->location : input_location;
   tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype),
 				   fold_build1_loc (loc, ADDR_EXPR,
 					     build_pointer_type (fntype),
-					     error
-					     ? gfor_fndecl_runtime_error_at
-					     : gfor_fndecl_runtime_warning_at),
+					     errorfunc),
 				   nargs + 2, argarray);
   gfc_add_expr_to_block (&block, tmp);
 
@@ -527,7 +522,10 @@ gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
   tree result;
 
   va_start (ap, msgid);
-  result = trans_runtime_error_vararg (error, where, msgid, ap);
+  result = trans_runtime_error_vararg (error
+				       ? gfor_fndecl_runtime_error_at
+				       : gfor_fndecl_runtime_warning_at,
+				       where, msgid, ap);
   va_end (ap);
   return result;
 }
@@ -566,8 +564,10 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
   /* The code to generate the error.  */
   va_start (ap, msgid);
   gfc_add_expr_to_block (&block,
-			 trans_runtime_error_vararg (error, where,
-						     msgid, ap));
+			 trans_runtime_error_vararg
+			 (error ? gfor_fndecl_runtime_error_at
+			  : gfor_fndecl_runtime_warning_at,
+			  where, msgid, ap));
   va_end (ap);
 
   if (once)
@@ -595,13 +595,28 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 }
 
 
+static tree
+trans_os_error_at (locus* where, const char* msgid, ...)
+{
+  va_list ap;
+  tree result;
+
+  va_start (ap, msgid);
+  result = trans_runtime_error_vararg (gfor_fndecl_os_error_at,
+				       where, msgid, ap);
+  va_end (ap);
+  return result;
+}
+
+
+
 /* Call malloc to allocate size bytes of memory, with special conditions:
       + if size == 0, return a malloced area of size 1,
       + if malloc returns NULL, issue a runtime error.  */
 tree
 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 {
-  tree tmp, msg, malloc_result, null_result, res, malloc_tree;
+  tree tmp, malloc_result, null_result, res, malloc_tree;
   stmtblock_t block2;
 
   /* Create a variable to hold the result.  */
@@ -626,13 +641,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
       null_result = fold_build2_loc (input_location, EQ_EXPR,
 				     logical_type_node, res,
 				     build_int_cst (pvoid_type_node, 0));
-      msg = gfc_build_addr_expr (pchar_type_node,
-	      gfc_build_localized_cstring_const ("Memory allocation failed"));
       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 			     null_result,
-	      build_call_expr_loc (input_location,
-				   gfor_fndecl_os_error, 1, msg),
-				   build_empty_stmt (input_location));
+			     trans_os_error_at (NULL,
+						"Error allocating %lu bytes",
+						fold_convert
+						(long_unsigned_type_node,
+						 size)),
+			     build_empty_stmt (input_location));
       gfc_add_expr_to_block (&block2, tmp);
     }
 
@@ -701,11 +717,9 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
     }
   else
     {
-      /* Here, os_error already implies PRED_NORETURN.  */
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
-		    gfc_build_addr_expr (pchar_type_node,
-				 gfc_build_localized_cstring_const
-				    ("Allocation would exceed memory limit")));
+      /* Here, os_error_at already implies PRED_NORETURN.  */
+      tree lusize = fold_convert (long_unsigned_type_node, size);
+      tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize);
       gfc_add_expr_to_block (&on_error, tmp);
     }
 
@@ -1664,7 +1678,7 @@ internal_realloc (void *mem, size_t size)
 tree
 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 {
-  tree msg, res, nonzero, null_result, tmp;
+  tree res, nonzero, null_result, tmp;
   tree type = TREE_TYPE (mem);
 
   /* Only evaluate the size once.  */
@@ -1684,12 +1698,12 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 			     build_int_cst (size_type_node, 0));
   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
 				 null_result, nonzero);
-  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
-			     ("Allocation would exceed memory limit"));
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 			 null_result,
-			 build_call_expr_loc (input_location,
-					      gfor_fndecl_os_error, 1, msg),
+			 trans_os_error_at (NULL,
+					    "Error reallocating to %lu bytes",
+					    fold_convert
+					    (long_unsigned_type_node, size)),
 			 build_empty_stmt (input_location));
   gfc_add_expr_to_block (block, tmp);
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index a3726e8..8082b41 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -803,7 +803,7 @@ extern GTY(()) tree gfor_fndecl_error_stop_string;
 extern GTY(()) tree gfor_fndecl_runtime_error;
 extern GTY(()) tree gfor_fndecl_runtime_error_at;
 extern GTY(()) tree gfor_fndecl_runtime_warning_at;
-extern GTY(()) tree gfor_fndecl_os_error;
+extern GTY(()) tree gfor_fndecl_os_error_at;
 extern GTY(()) tree gfor_fndecl_generate_error;
 extern GTY(()) tree gfor_fndecl_set_fpe;
 extern GTY(()) tree gfor_fndecl_set_options;
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 7a11ca2..23a4c57 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,11 @@
+2019-08-17  Janne Blomqvist  <jb@gcc.gnu.org>
+
+	PR fortran/68401
+	* gfortran.map: Add GFORTRAN_10 node, add _gfortran_os_error_at
+	symbol.
+	* libgfortran.h (os_error_at): New prototype.
+	* runtime/error.c (os_error_at): New function.
+
 2019-08-13  Janne Blomqvist  <jb@gcc.gnu.org>
 
         PR fortran/91414
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 2b2243b..3601bc2 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1602,3 +1602,8 @@ GFORTRAN_9.2 {
   _gfortran_mfindloc1_r10;
   _gfortran_sfindloc1_r10;
 } GFORTRAN_9;
+
+GFORTRAN_10 {
+  global:
+  _gfortran_os_error_at;
+} GFORTRAN_9.2;
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index c0db96f..9f535b1 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -728,6 +728,10 @@ internal_proto(gfc_xtoa);
 extern _Noreturn void os_error (const char *);
 iexport_proto(os_error);
 
+extern _Noreturn void os_error_at (const char *, const char *, ...)
+  __attribute__ ((format (gfc_printf, 2, 3)));
+iexport_proto(os_error_at);
+
 extern void show_locus (st_parameter_common *);
 internal_proto(show_locus);
 
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index 0335a16..cbe0642 100644
--- a/libgfortran/runtime/error.c
+++ b/libgfortran/runtime/error.c
@@ -403,7 +403,51 @@ os_error (const char *message)
   estr_writev (iov, 5);
   exit_error (1);
 }
-iexport(os_error);
+iexport(os_error); /* TODO, DEPRECATED, ABI: Should not be exported
+		      anymore when bumping so version.  */
+
+
+/* Improved version of os_error with a printf style format string and
+   a locus.  */
+
+void
+os_error_at (const char *where, const char *message, ...)
+{
+  char errmsg[STRERR_MAXSZ];
+  char buffer[STRERR_MAXSZ];
+  struct iovec iov[6];
+  va_list ap;
+  recursion_check ();
+  int written;
+
+  iov[0].iov_base = (char*) where;
+  iov[0].iov_len = strlen (where);
+
+  iov[1].iov_base = (char*) ": ";
+  iov[1].iov_len = strlen (iov[1].iov_base);
+
+  va_start (ap, message);
+  written = vsnprintf (buffer, STRERR_MAXSZ, message, ap);
+  va_end (ap);
+  iov[2].iov_base = buffer;
+  if (written >= 0)
+    iov[2].iov_len = written;
+  else
+    iov[2].iov_len = 0;
+
+  iov[3].iov_base = (char*) ": ";
+  iov[3].iov_len = strlen (iov[3].iov_base);
+
+  iov[4].iov_base = gf_strerror (errno, errmsg, STRERR_MAXSZ);
+  iov[4].iov_len = strlen (iov[4].iov_base);
+
+  iov[5].iov_base = (char*) "\n";
+  iov[5].iov_len = 1;
+
+  estr_writev (iov, 6);
+  exit_error (1);
+}
+iexport(os_error_at);
 
 
 /* void runtime_error()-- These are errors associated with an