Commit 0d52899f by Tobias Burnus Committed by Tobias Burnus

re PR fortran/36132 (_gfortran_internal_pack on optional arguments)

2008-07-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/36132
        PR fortran/29952
        PR fortran/36909
        * trans.c (gfc_trans_runtime_check): Allow run-time warning
        * besides
        run-time error.
        * trans.h (gfc_trans_runtime_check): Update declaration.
        * trans-array.c
        * (gfc_trans_array_ctor_element,gfc_trans_array_bound_check,
        gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias):
        Updated gfc_trans_runtime_check calls.
        (gfc_conv_array_parameter): Implement flag_check_array_temporaries,
        fix packing/unpacking for nonpresent optional actuals to optional
        formals.
        * trans-array.h (gfc_conv_array_parameter): Update declaration.
        * trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign,
        gfc_conv_function_call): Updated gfc_trans_runtime_check calls.
        (gfc_conv_function_call): Update gfc_conv_array_parameter calls.
        * trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check
        calls.
        * trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto.
        (gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for
        gfc_conv_array_parameter.
        * trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto.
        * trans-decl.c (gfc_build_builtin_function_decls): Add
        gfor_fndecl_runtime_warning_at.
        * lang.opt: New option fcheck-array-temporaries.
        * gfortran.h (gfc_options): New flag_check_array_temporaries.
        * options.c (gfc_init_options, gfc_handle_option): Handle flag.
        * invoke.texi: New option fcheck-array-temporaries.

2008-07-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/36132
        PR fortran/29952
        PR fortran/36909
        * runtime/error.c: New function runtime_error_at.
        * gfortran.map: Ditto.
        * libgfortran.h: Ditto.

2008-07-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/36132
        PR fortran/29952
        PR fortran/36909
        gfortran.dg/internal_pack_4.f90: New.
        gfortran.dg/internal_pack_5.f90: New.
        gfortran.dg/array_temporaries_2.f90: New.

From-SVN: r138186
parent 5aab2488
2008-07-27 Tobias Burnus <burnus@net-b.de>
PR fortran/36132
PR fortran/29952
PR fortran/36909
* trans.c (gfc_trans_runtime_check): Allow run-time warning besides
run-time error.
* trans.h (gfc_trans_runtime_check): Update declaration.
* trans-array.c (gfc_trans_array_ctor_element,gfc_trans_array_bound_check,
gfc_conv_array_ref,gfc_conv_ss_startstride,gfc_trans_dummy_array_bias):
Updated gfc_trans_runtime_check calls.
(gfc_conv_array_parameter): Implement flag_check_array_temporaries,
fix packing/unpacking for nonpresent optional actuals to optional
formals.
* trans-array.h (gfc_conv_array_parameter): Update declaration.
* trans-expr.c (gfc_conv_substring,gfc_trans_arrayfunc_assign,
gfc_conv_function_call): Updated gfc_trans_runtime_check calls.
(gfc_conv_function_call): Update gfc_conv_array_parameter calls.
* trans-expr.c (gfc_trans_goto): Updated gfc_trans_runtime_check
calls.
* trans-io.c (set_string,gfc_conv_intrinsic_repeat): Ditto.
(gfc_conv_intrinsic_transfer,gfc_conv_intrinsic_loc): Same for
gfc_conv_array_parameter.
* trans-intrinsics.c (gfc_conv_intrinsic_bound): Ditto.
* trans-decl.c (gfc_build_builtin_function_decls): Add
gfor_fndecl_runtime_warning_at.
* lang.opt: New option fcheck-array-temporaries.
* gfortran.h (gfc_options): New flag_check_array_temporaries.
* options.c (gfc_init_options, gfc_handle_option): Handle flag.
* invoke.texi: New option fcheck-array-temporaries.
2008-07-24 Jan Hubicka <jh@suse.cz> 2008-07-24 Jan Hubicka <jh@suse.cz>
* fortran/options.c (gfc_post_options): Remove flag_unline_trees code. * fortran/options.c (gfc_post_options): Remove flag_unline_trees code.
......
...@@ -1895,6 +1895,7 @@ typedef struct ...@@ -1895,6 +1895,7 @@ typedef struct
int flag_automatic; int flag_automatic;
int flag_backslash; int flag_backslash;
int flag_backtrace; int flag_backtrace;
int flag_check_array_temporaries;
int flag_allow_leading_underscore; int flag_allow_leading_underscore;
int flag_dump_core; int flag_dump_core;
int flag_external_blas; int flag_external_blas;
......
...@@ -164,7 +164,7 @@ and warnings}. ...@@ -164,7 +164,7 @@ and warnings}.
@xref{Code Gen Options,,Options for code generation conventions}. @xref{Code Gen Options,,Options for code generation conventions}.
@gccoptlist{-fno-automatic -ff2c -fno-underscoring @gccoptlist{-fno-automatic -ff2c -fno-underscoring
-fsecond-underscore @gol -fsecond-underscore @gol
-fbounds-check -fmax-stack-var-size=@var{n} @gol -fbounds-check -fcheck-array-temporaries -fmax-stack-var-size=@var{n} @gol
-fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol -fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol
-fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol -fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
-finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan>} @gol -finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan>} @gol
...@@ -1168,6 +1168,17 @@ the compilation of the main program. ...@@ -1168,6 +1168,17 @@ the compilation of the main program.
In the future this may also include other forms of checking, e.g., checking In the future this may also include other forms of checking, e.g., checking
substring references. substring references.
@item fcheck-array-temporaries
@opindex @code{fcheck-array-temporaries}
@cindex checking array temporaries
Warns at run time when for passing an actual argument a temporary array
had to be generated. The information generated by this warning is
sometimes useful in optimization, in order to avoid such temporaries.
Note: The warning is only printed once per location.
@item -fmax-stack-var-size=@var{n} @item -fmax-stack-var-size=@var{n}
@opindex @code{fmax-stack-var-size} @opindex @code{fmax-stack-var-size}
This option specifies the size in bytes of the largest array that will be put This option specifies the size in bytes of the largest array that will be put
......
...@@ -156,6 +156,10 @@ fblas-matmul-limit= ...@@ -156,6 +156,10 @@ fblas-matmul-limit=
Fortran RejectNegative Joined UInteger Fortran RejectNegative Joined UInteger
-fblas-matmul-limit=<n> Size of the smallest matrix for which matmul will use BLAS -fblas-matmul-limit=<n> Size of the smallest matrix for which matmul will use BLAS
fcheck-array-temporaries
Fortran
Produce a warning at runtime if a array temporary has been created for a procedure argument
fconvert=big-endian fconvert=big-endian
Fortran RejectNegative Fortran RejectNegative
Use big-endian format for unformatted files Use big-endian format for unformatted files
......
...@@ -101,6 +101,7 @@ gfc_init_options (unsigned int argc, const char **argv) ...@@ -101,6 +101,7 @@ gfc_init_options (unsigned int argc, const char **argv)
gfc_option.flag_backslash = 0; gfc_option.flag_backslash = 0;
gfc_option.flag_module_private = 0; gfc_option.flag_module_private = 0;
gfc_option.flag_backtrace = 0; gfc_option.flag_backtrace = 0;
gfc_option.flag_check_array_temporaries = 0;
gfc_option.flag_allow_leading_underscore = 0; gfc_option.flag_allow_leading_underscore = 0;
gfc_option.flag_dump_core = 0; gfc_option.flag_dump_core = 0;
gfc_option.flag_external_blas = 0; gfc_option.flag_external_blas = 0;
...@@ -540,6 +541,10 @@ gfc_handle_option (size_t scode, const char *arg, int value) ...@@ -540,6 +541,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
gfc_option.flag_backtrace = value; gfc_option.flag_backtrace = value;
break; break;
case OPT_fcheck_array_temporaries:
gfc_option.flag_check_array_temporaries = value;
break;
case OPT_fdump_core: case OPT_fdump_core:
gfc_option.flag_dump_core = value; gfc_option.flag_dump_core = value;
break; break;
......
...@@ -1022,7 +1022,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, ...@@ -1022,7 +1022,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree cond = fold_build2 (NE_EXPR, boolean_type_node, tree cond = fold_build2 (NE_EXPR, boolean_type_node,
first_len_val, se->string_length); first_len_val, se->string_length);
gfc_trans_runtime_check gfc_trans_runtime_check
(cond, &se->pre, &expr->where, (true, false, cond, &se->pre, &expr->where,
"Different CHARACTER lengths (%ld/%ld) in array constructor", "Different CHARACTER lengths (%ld/%ld) in array constructor",
fold_convert (long_integer_type_node, first_len_val), fold_convert (long_integer_type_node, first_len_val),
fold_convert (long_integer_type_node, se->string_length)); fold_convert (long_integer_type_node, se->string_length));
...@@ -2235,7 +2235,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, ...@@ -2235,7 +2235,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
else else
asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)", asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
gfc_msg_fault, n+1); gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, &se->pre, where, msg, gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, index),
fold_convert (long_integer_type_node, tmp)); fold_convert (long_integer_type_node, tmp));
gfc_free (msg); gfc_free (msg);
...@@ -2251,7 +2251,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, ...@@ -2251,7 +2251,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
else else
asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)", asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
gfc_msg_fault, n+1); gfc_msg_fault, n+1);
gfc_trans_runtime_check (fault, &se->pre, where, msg, gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, index),
fold_convert (long_integer_type_node, tmp)); fold_convert (long_integer_type_node, tmp));
gfc_free (msg); gfc_free (msg);
...@@ -2445,7 +2445,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, ...@@ -2445,7 +2445,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
asprintf (&msg, "%s for array '%s', " asprintf (&msg, "%s for array '%s', "
"lower bound of dimension %d exceeded (%%ld < %%ld)", "lower bound of dimension %d exceeded (%%ld < %%ld)",
gfc_msg_fault, sym->name, n+1); gfc_msg_fault, sym->name, n+1);
gfc_trans_runtime_check (cond, &se->pre, where, msg, gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
indexse.expr), indexse.expr),
fold_convert (long_integer_type_node, tmp)); fold_convert (long_integer_type_node, tmp));
...@@ -2462,7 +2462,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, ...@@ -2462,7 +2462,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
asprintf (&msg, "%s for array '%s', " asprintf (&msg, "%s for array '%s', "
"upper bound of dimension %d exceeded (%%ld > %%ld)", "upper bound of dimension %d exceeded (%%ld > %%ld)",
gfc_msg_fault, sym->name, n+1); gfc_msg_fault, sym->name, n+1);
gfc_trans_runtime_check (cond, &se->pre, where, msg, gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg,
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
indexse.expr), indexse.expr),
fold_convert (long_integer_type_node, tmp)); fold_convert (long_integer_type_node, tmp));
...@@ -3026,7 +3026,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3026,7 +3026,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "Zero stride is not allowed, for dimension %d " asprintf (&msg, "Zero stride is not allowed, for dimension %d "
"of array '%s'", info->dim[n]+1, "of array '%s'", info->dim[n]+1,
ss->expr->symtree->name); ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg); gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg);
gfc_free (msg); gfc_free (msg);
desc = ss->data.info.descriptor; desc = ss->data.info.descriptor;
...@@ -3068,7 +3069,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3068,7 +3069,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded (%%ld < %%ld)", gfc_msg_fault, " exceeded (%%ld < %%ld)", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name); info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
info->start[n]), info->start[n]),
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
...@@ -3084,7 +3086,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3084,7 +3086,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, upper bound of dimension %d of array " asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name); info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, info->start[n]), fold_convert (long_integer_type_node, info->start[n]),
fold_convert (long_integer_type_node, ubound)); fold_convert (long_integer_type_node, ubound));
gfc_free (msg); gfc_free (msg);
...@@ -3106,7 +3109,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3106,7 +3109,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'" asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded (%%ld < %%ld)", gfc_msg_fault, " exceeded (%%ld < %%ld)", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name); info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
tmp2), tmp2),
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
...@@ -3121,7 +3125,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3121,7 +3125,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, upper bound of dimension %d of array " asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded (%%ld > %%ld)", gfc_msg_fault, "'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
info->dim[n]+1, ss->expr->symtree->name); info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp, &inner, &ss->expr->where, msg, gfc_trans_runtime_check (true, false, tmp, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp2), fold_convert (long_integer_type_node, tmp2),
fold_convert (long_integer_type_node, ubound)); fold_convert (long_integer_type_node, ubound));
gfc_free (msg); gfc_free (msg);
...@@ -3144,7 +3149,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) ...@@ -3144,7 +3149,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, size mismatch for dimension %d " asprintf (&msg, "%s, size mismatch for dimension %d "
"of array '%s' (%%ld/%%ld)", gfc_msg_bounds, "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
info->dim[n]+1, ss->expr->symtree->name); info->dim[n]+1, ss->expr->symtree->name);
gfc_trans_runtime_check (tmp3, &inner, &ss->expr->where, msg, gfc_trans_runtime_check (true, false, tmp3, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n])); fold_convert (long_integer_type_node, size[n]));
gfc_free (msg); gfc_free (msg);
...@@ -4383,7 +4389,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ...@@ -4383,7 +4389,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2); tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
asprintf (&msg, "%s for dimension %d of array '%s'", asprintf (&msg, "%s for dimension %d of array '%s'",
gfc_msg_bounds, n+1, sym->name); gfc_msg_bounds, n+1, sym->name);
gfc_trans_runtime_check (tmp, &block, &loc, msg); gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
gfc_free (msg); gfc_free (msg);
} }
} }
...@@ -5133,7 +5139,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) ...@@ -5133,7 +5139,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* TODO: Optimize passing g77 arrays. */ /* TODO: Optimize passing g77 arrays. */
void void
gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
const gfc_symbol *fsym, const char *proc_name)
{ {
tree ptr; tree ptr;
tree desc; tree desc;
...@@ -5230,17 +5237,59 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) ...@@ -5230,17 +5237,59 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
/* Repack the array. */ /* Repack the array. */
if (gfc_option.warn_array_temp) if (gfc_option.warn_array_temp)
gfc_warning ("Creating array temporary at %L", &expr->where); {
if (fsym)
gfc_warning ("Creating array temporary at %L for argument '%s'",
&expr->where, fsym->name);
else
gfc_warning ("Creating array temporary at %L", &expr->where);
}
ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc); ptr = build_call_expr (gfor_fndecl_in_pack, 1, desc);
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
{
tmp = gfc_conv_expr_present (sym);
ptr = build3 (COND_EXPR, TREE_TYPE (se->expr), tmp, ptr,
null_pointer_node);
}
ptr = gfc_evaluate_now (ptr, &se->pre); ptr = gfc_evaluate_now (ptr, &se->pre);
se->expr = ptr; se->expr = ptr;
if (gfc_option.flag_check_array_temporaries)
{
char * msg;
if (fsym && proc_name)
asprintf (&msg, "An array temporary was created for argument "
"'%s' of procedure '%s'", fsym->name, proc_name);
else
asprintf (&msg, "An array temporary was created");
tmp = build_fold_indirect_ref (desc);
tmp = gfc_conv_array_data (tmp);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp);
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
gfc_conv_expr_present (sym), tmp);
gfc_trans_runtime_check (false, true, tmp, &se->pre,
&expr->where, msg);
gfc_free (msg);
}
gfc_start_block (&block); gfc_start_block (&block);
/* Copy the data back. */ /* Copy the data back. */
tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr); if (fsym == NULL || fsym->attr.intent != INTENT_IN)
gfc_add_expr_to_block (&block, tmp); {
tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
/* Free the temporary. */ /* Free the temporary. */
tmp = gfc_call_free (convert (pvoid_type_node, ptr)); tmp = gfc_call_free (convert (pvoid_type_node, ptr));
...@@ -5255,6 +5304,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77) ...@@ -5255,6 +5304,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
tmp = gfc_conv_array_data (tmp); tmp = gfc_conv_array_data (tmp);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp = fold_build2 (NE_EXPR, boolean_type_node,
fold_convert (TREE_TYPE (tmp), ptr), tmp); fold_convert (TREE_TYPE (tmp), ptr), tmp);
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
gfc_conv_expr_present (sym), tmp);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
......
...@@ -105,7 +105,8 @@ void gfc_conv_tmp_ref (gfc_se *); ...@@ -105,7 +105,8 @@ void gfc_conv_tmp_ref (gfc_se *);
/* Evaluate an array expression. */ /* Evaluate an array expression. */
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *); void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
/* Convert an array for passing as an actual function parameter. */ /* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int); void gfc_conv_array_parameter (gfc_se *, gfc_expr *, gfc_ss *, int,
const gfc_symbol *, const char *);
/* Evaluate and transpose a matrix expression. */ /* Evaluate and transpose a matrix expression. */
void gfc_conv_array_transpose (gfc_se *, gfc_expr *); void gfc_conv_array_transpose (gfc_se *, gfc_expr *);
......
...@@ -79,6 +79,7 @@ tree gfor_fndecl_stop_numeric; ...@@ -79,6 +79,7 @@ tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string; tree gfor_fndecl_stop_string;
tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at; tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_runtime_warning_at;
tree gfor_fndecl_os_error; tree gfor_fndecl_os_error;
tree gfor_fndecl_generate_error; tree gfor_fndecl_generate_error;
tree gfor_fndecl_set_fpe; tree gfor_fndecl_set_fpe;
...@@ -2455,6 +2456,10 @@ gfc_build_builtin_function_decls (void) ...@@ -2455,6 +2456,10 @@ gfc_build_builtin_function_decls (void)
/* The runtime_error_at function does not return. */ /* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
gfor_fndecl_runtime_warning_at =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
void_type_node, -2, pchar_type_node,
pchar_type_node);
gfor_fndecl_generate_error = gfor_fndecl_generate_error =
gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")), gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
void_type_node, 3, pvoid_type_node, void_type_node, 3, pvoid_type_node,
......
...@@ -328,7 +328,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, ...@@ -328,7 +328,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
else else
asprintf (&msg, "Substring out of bounds: lower bound (%%ld)" asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
"is less than one"); "is less than one");
gfc_trans_runtime_check (fault, &se->pre, where, msg, gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
start.expr)); start.expr));
gfc_free (msg); gfc_free (msg);
...@@ -344,7 +344,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, ...@@ -344,7 +344,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
else else
asprintf (&msg, "Substring out of bounds: upper bound (%%ld) " asprintf (&msg, "Substring out of bounds: upper bound (%%ld) "
"exceeds string length (%%ld)"); "exceeds string length (%%ld)");
gfc_trans_runtime_check (fault, &se->pre, where, msg, gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg,
fold_convert (long_integer_type_node, end.expr), fold_convert (long_integer_type_node, end.expr),
fold_convert (long_integer_type_node, fold_convert (long_integer_type_node,
se->string_length)); se->string_length));
...@@ -2299,7 +2299,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, ...@@ -2299,7 +2299,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
f = f || !sym->attr.always_explicit; f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr); argss = gfc_walk_expr (arg->expr);
gfc_conv_array_parameter (se, arg->expr, argss, f); gfc_conv_array_parameter (se, arg->expr, argss, f, NULL, NULL);
} }
/* TODO -- the following two lines shouldn't be necessary, but /* TODO -- the following two lines shouldn't be necessary, but
...@@ -2535,7 +2535,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, ...@@ -2535,7 +2535,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_subref_array_arg (&parmse, e, f, gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT); fsym ? fsym->attr.intent : INTENT_INOUT);
else else
gfc_conv_array_parameter (&parmse, e, argss, f); gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */ allocated on entry, it must be deallocated. */
...@@ -2836,7 +2837,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, ...@@ -2836,7 +2837,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp = fold_build2 (NE_EXPR, boolean_type_node,
tmp, info->data); tmp, info->data);
gfc_trans_runtime_check (tmp, &se->pre, NULL, gfc_msg_fault); gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL,
gfc_msg_fault);
} }
se->expr = info->descriptor; se->expr = info->descriptor;
/* Bundle in the string length. */ /* Bundle in the string length. */
...@@ -4143,7 +4145,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ...@@ -4143,7 +4145,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre); gfc_start_block (&se.pre);
se.want_pointer = 1; se.want_pointer = 1;
gfc_conv_array_parameter (&se, expr1, ss, 0); gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL);
se.direct_byref = 1; se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2); se.ss = gfc_walk_expr (expr2);
......
...@@ -864,7 +864,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ...@@ -864,7 +864,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
gfc_msg_fault);
} }
} }
...@@ -3632,7 +3633,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) ...@@ -3632,7 +3633,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
if (ss == gfc_ss_terminator) if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (&argse, arg->expr); gfc_conv_expr_reference (&argse, arg->expr);
else else
gfc_conv_array_parameter (&argse, arg->expr, ss, 1); gfc_conv_array_parameter (&argse, arg->expr, ss, 1, NULL, NULL);
gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post); gfc_add_block_to_block (&se->post, &argse.post);
ptr = argse.expr; ptr = argse.expr;
...@@ -3958,7 +3959,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) ...@@ -3958,7 +3959,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* Check that NCOPIES is not negative. */ /* Check that NCOPIES is not negative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
build_int_cst (ncopies_type, 0)); build_int_cst (ncopies_type, 0));
gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is negative " "Argument NCOPIES of REPEAT intrinsic is negative "
"(its value is %lld)", "(its value is %lld)",
fold_convert (long_integer_type_node, ncopies)); fold_convert (long_integer_type_node, ncopies));
...@@ -3990,7 +3991,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) ...@@ -3990,7 +3991,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
build_int_cst (size_type_node, 0)); build_int_cst (size_type_node, 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node, cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
cond); cond);
gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is too large"); "Argument NCOPIES of REPEAT intrinsic is too large");
/* Compute the destination length. */ /* Compute the destination length. */
...@@ -4094,7 +4095,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) ...@@ -4094,7 +4095,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (ss == gfc_ss_terminator) if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr); gfc_conv_expr_reference (se, arg_expr);
else else
gfc_conv_array_parameter (se, arg_expr, ss, 1); gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
/* Create a temporary variable for loc return value. Without this, /* Create a temporary variable for loc return value. Without this,
......
...@@ -668,7 +668,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, ...@@ -668,7 +668,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format " asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
"label", e->symtree->name); "label", e->symtree->name);
gfc_trans_runtime_check (cond, &se.pre, &e->where, msg, gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
fold_convert (long_integer_type_node, tmp)); fold_convert (long_integer_type_node, tmp));
gfc_free (msg); gfc_free (msg);
......
...@@ -154,7 +154,7 @@ gfc_trans_goto (gfc_code * code) ...@@ -154,7 +154,7 @@ gfc_trans_goto (gfc_code * code)
tmp = GFC_DECL_STRING_LEN (se.expr); tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), -1)); build_int_cst (TREE_TYPE (tmp), -1));
gfc_trans_runtime_check (tmp, &se.pre, &loc, gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
"Assigned label is not a target label"); "Assigned label is not a target label");
assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
...@@ -180,7 +180,7 @@ gfc_trans_goto (gfc_code * code) ...@@ -180,7 +180,7 @@ gfc_trans_goto (gfc_code * code)
code = code->block; code = code->block;
} }
while (code != NULL); while (code != NULL);
gfc_trans_runtime_check (boolean_true_node, &se.pre, &loc, gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
"Assigned label is not in the list"); "Assigned label is not in the list");
return gfc_finish_block (&se.pre); return gfc_finish_block (&se.pre);
......
...@@ -351,13 +351,14 @@ gfc_build_array_ref (tree base, tree offset, tree decl) ...@@ -351,13 +351,14 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
/* Generate a runtime error if COND is true. */ /* Generate a runtime error if COND is true. */
void void
gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
const char * msgid, ...) locus * where, const char * msgid, ...)
{ {
va_list ap; va_list ap;
stmtblock_t block; stmtblock_t block;
tree body; tree body;
tree tmp; tree tmp;
tree tmpvar = NULL;
tree arg, arg2; tree arg, arg2;
tree *argarray; tree *argarray;
tree fntype; tree fntype;
...@@ -377,6 +378,14 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, ...@@ -377,6 +378,14 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
nargs++; nargs++;
} }
if (once)
{
tmpvar = gfc_create_var (boolean_type_node, "print_warning");
TREE_STATIC (tmpvar) = 1;
DECL_INITIAL (tmpvar) = boolean_true_node;
gfc_add_expr_to_block (pblock, tmpvar);
}
/* The code to generate the error. */ /* The code to generate the error. */
gfc_start_block (&block); gfc_start_block (&block);
...@@ -408,16 +417,25 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, ...@@ -408,16 +417,25 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
argarray[2+i] = va_arg (ap, tree); argarray[2+i] = va_arg (ap, tree);
va_end (ap); va_end (ap);
/* Build the function call to runtime_error_at; because of the variable /* Build the function call to runtime_(warning,error)_at; because of the
number of arguments, we can't use build_call_expr directly. */ variable number of arguments, we can't use build_call_expr directly. */
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at); if (error)
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
else
fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
tmp = fold_builtin_call_array (TREE_TYPE (fntype), tmp = fold_builtin_call_array (TREE_TYPE (fntype),
fold_build1 (ADDR_EXPR, fold_build1 (ADDR_EXPR,
build_pointer_type (fntype), build_pointer_type (fntype),
gfor_fndecl_runtime_error_at), error
? gfor_fndecl_runtime_error_at
: gfor_fndecl_runtime_warning_at),
nargs + 2, argarray); nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
if (once)
gfc_add_modify_expr (&block, tmpvar, boolean_false_node);
body = gfc_finish_block (&block); body = gfc_finish_block (&block);
if (integer_onep (cond)) if (integer_onep (cond))
...@@ -427,7 +445,12 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where, ...@@ -427,7 +445,12 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
else else
{ {
/* Tell the compiler that this isn't likely. */ /* Tell the compiler that this isn't likely. */
cond = fold_convert (long_integer_type_node, cond); if (once)
cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
cond);
else
cond = fold_convert (long_integer_type_node, cond);
tmp = build_int_cst (long_integer_type_node, 0); tmp = build_int_cst (long_integer_type_node, 0);
cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
cond = fold_convert (boolean_type_node, cond); cond = fold_convert (boolean_type_node, cond);
......
...@@ -444,8 +444,9 @@ void gfc_generate_constructors (void); ...@@ -444,8 +444,9 @@ void gfc_generate_constructors (void);
/* Get the string length of an array constructor. */ /* Get the string length of an array constructor. */
bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *); bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
/* Generate a runtime error check. */ /* Generate a runtime warning/error check. */
void gfc_trans_runtime_check (tree, stmtblock_t *, locus *, const char *, ...); void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
const char *, ...);
/* Generate a call to free() after checking that its arg is non-NULL. */ /* Generate a call to free() after checking that its arg is non-NULL. */
tree gfc_call_free (tree); tree gfc_call_free (tree);
...@@ -510,6 +511,7 @@ extern GTY(()) tree gfor_fndecl_stop_numeric; ...@@ -510,6 +511,7 @@ extern GTY(()) tree gfor_fndecl_stop_numeric;
extern GTY(()) tree gfor_fndecl_stop_string; extern GTY(()) tree gfor_fndecl_stop_string;
extern GTY(()) tree gfor_fndecl_runtime_error; extern GTY(()) tree gfor_fndecl_runtime_error;
extern GTY(()) tree gfor_fndecl_runtime_error_at; 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;
extern GTY(()) tree gfor_fndecl_generate_error; extern GTY(()) tree gfor_fndecl_generate_error;
extern GTY(()) tree gfor_fndecl_set_fpe; extern GTY(()) tree gfor_fndecl_set_fpe;
......
2008-07-27 Tobias Burnus <burnus@net-b.de>
PR fortran/36132
PR fortran/29952
PR fortran/36909
gfortran.dg/internal_pack_4.f90: New.
gfortran.dg/internal_pack_5.f90: New.
gfortran.dg/array_temporaries_2.f90: New.
2008-07-26 Thomas Koenig <tkoenig@gcc.gnu.org> 2008-07-26 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36934 PR fortran/36934
......
! { dg-do run }
! { dg-options "-fcheck-array-temporaries" }
program test
implicit none
integer :: a(3,3)
call foo(a(:,1)) ! OK, no temporary created
call foo(a(1,:)) ! BAD, temporary var created
contains
subroutine foo(x)
integer :: x(3)
x = 5
end subroutine foo
end program test
! { dg-output "At line 7 of file .*array_temporaries_2.f90(\n|\r\n|\r)Fortran runtime warning: An array temporary was created for argument 'x' of procedure 'foo'" }
! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/36132
!
! Before invalid memory was accessed because an absent, optional
! argument was packed before passing it as absent actual.
! Getting it to crash is difficult, but valgrind shows the problem.
!
MODULE M1
INTEGER, PARAMETER :: dp=KIND(0.0D0)
CONTAINS
SUBROUTINE S1(a)
REAL(dp), DIMENSION(45), INTENT(OUT), &
OPTIONAL :: a
if (present(a)) call abort()
END SUBROUTINE S1
SUBROUTINE S2(a)
REAL(dp), DIMENSION(:, :), INTENT(OUT), &
OPTIONAL :: a
CALL S1(a)
END SUBROUTINE
END MODULE M1
USE M1
CALL S2()
END
! { dg-final { scan-tree-dump-times "a != 0B \\? _gfortran_internal_pack" 1 "original" } }
! { dg-final { scan-tree-dump-times "if \\(a != 0B &&" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/36909
!
! Check that no unneeded internal_unpack is
! called (INTENT(IN)!).
!
program test
implicit none
integer :: a(3,3)
call foo(a(1,:))
contains
subroutine foo(x)
integer,intent(in) :: x(3)
end subroutine foo
end program test
! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
2008-07-27 Tobias Burnus <burnus@net-b.de>
PR fortran/36132
PR fortran/29952
PR fortran/36909
* runtime/error.c: New function runtime_error_at.
* gfortran.map: Ditto.
* libgfortran.h: Ditto.
2008-07-22 Jerry DeLisle <jvdelisle@gcc.gnu.org> 2008-07-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/36852 PR fortran/36852
......
...@@ -1072,6 +1072,7 @@ GFORTRAN_1.1 { ...@@ -1072,6 +1072,7 @@ GFORTRAN_1.1 {
_gfortran_pack_char4; _gfortran_pack_char4;
_gfortran_pack_s_char4; _gfortran_pack_s_char4;
_gfortran_reshape_char4; _gfortran_reshape_char4;
_gfortran_runtime_warning_at;
_gfortran_selected_char_kind; _gfortran_selected_char_kind;
_gfortran_select_string_char4; _gfortran_select_string_char4;
_gfortran_spread_char4; _gfortran_spread_char4;
......
...@@ -643,6 +643,9 @@ extern void runtime_error_at (const char *, const char *, ...) ...@@ -643,6 +643,9 @@ extern void runtime_error_at (const char *, const char *, ...)
__attribute__ ((noreturn, format (printf, 2, 3))); __attribute__ ((noreturn, format (printf, 2, 3)));
iexport_proto(runtime_error_at); iexport_proto(runtime_error_at);
extern void runtime_warning_at (const char *, const char *, ...);
iexport_proto(runtime_warning_at);
extern void internal_error (st_parameter_common *, const char *) extern void internal_error (st_parameter_common *, const char *)
__attribute__ ((noreturn)); __attribute__ ((noreturn));
internal_proto(internal_error); internal_proto(internal_error);
......
...@@ -285,6 +285,21 @@ runtime_error_at (const char *where, const char *message, ...) ...@@ -285,6 +285,21 @@ runtime_error_at (const char *where, const char *message, ...)
iexport(runtime_error_at); iexport(runtime_error_at);
void
runtime_warning_at (const char *where, const char *message, ...)
{
va_list ap;
st_printf ("%s\n", where);
st_printf ("Fortran runtime warning: ");
va_start (ap, message);
st_vprintf (message, ap);
va_end (ap);
st_printf ("\n");
}
iexport(runtime_warning_at);
/* void internal_error()-- These are this-can't-happen errors /* void internal_error()-- These are this-can't-happen errors
* that indicate something deeply wrong. */ * that indicate something deeply wrong. */
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment