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;
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")),
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;
/* 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);
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;
}
/* 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)
}
+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. */
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);
}
}
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);
}
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. */
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);
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
projects / gcc.git / commitdiff