diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index bab69f3000e..a3b9e6bf486 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2019-08-17 Janne Blomqvist + + 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 Mark Eggleston @@ -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 * trans-intrinsic.c (gfc_conv_intrinsic_findloc): Initialize diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 2a9b852568a..3c6ab60e9b2 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 84511477b39..583f6e3b25b 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 a3726e84140..8082b414df1 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 7a11ca29fd3..23a4c579351 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,11 @@ +2019-08-17 Janne Blomqvist + + 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 PR fortran/91414 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 2b2243b4fd4..3601bc24414 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 c0db96f02a8..9f535b12e73 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 0335a165edc..cbe0642f3f8 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