@@ -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")),
@@ -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);
@@ -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;
@@ -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;
@@ -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);
@@ -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