mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-08 19:31:06 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/36132 (_gfortran_internal_pack on optional arguments)

Browse Source 
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
This commit is contained in:
Tobias Burnus 2008-07-27 12:45:44 +02:00 committed by Tobias Burnus
parent 5aab248830
commit 0d52899f78
22 changed files with 285 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View File

@ -1,3 +1,34 @@
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>
* fortran/options.c (gfc_post_options): Remove flag_unline_trees code.

1
gcc/fortran/gfortran.h
View File

@ -1895,6 +1895,7 @@ typedef struct
int flag_automatic;
int flag_backslash;
int flag_backtrace;
int flag_check_array_temporaries;
int flag_allow_leading_underscore;
int flag_dump_core;
int flag_external_blas;

13
gcc/fortran/invoke.texi
View File

@ -164,7 +164,7 @@ and warnings}.
@xref{Code Gen Options,,Options for code generation conventions}.
@gccoptlist{-fno-automatic -ff2c -fno-underscoring
-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
-fblas-matmul-limit=@var{n} -frecursive -finit-local-zero @gol
-finit-integer=@var{n} -finit-real=@var{<zero|inf|-inf|nan>} @gol
@ -1168,6 +1168,17 @@ the compilation of the main program.
In the future this may also include other forms of checking, e.g., checking
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}
@opindex @code{fmax-stack-var-size}
This option specifies the size in bytes of the largest array that will be put

4
gcc/fortran/lang.opt
View File

@ -156,6 +156,10 @@ fblas-matmul-limit=
Fortran RejectNegative Joined UInteger
-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
Fortran RejectNegative
Use big-endian format for unformatted files

5
gcc/fortran/options.c
View File

@ -101,6 +101,7 @@ gfc_init_options (unsigned int argc, const char **argv)
gfc_option.flag_backslash = 0;
gfc_option.flag_module_private = 0;
gfc_option.flag_backtrace = 0;
gfc_option.flag_check_array_temporaries = 0;
gfc_option.flag_allow_leading_underscore = 0;
gfc_option.flag_dump_core = 0;
gfc_option.flag_external_blas = 0;
@ -540,6 +541,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
gfc_option.flag_backtrace = value;
break;
case OPT_fcheck_array_temporaries:
gfc_option.flag_check_array_temporaries = value;
break;
case OPT_fdump_core:
gfc_option.flag_dump_core = value;
break;

86
gcc/fortran/trans-array.c
View File

@ -1022,7 +1022,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
tree cond = fold_build2 (NE_EXPR, boolean_type_node,
first_len_val, se->string_length);
gfc_trans_runtime_check
(cond, &se->pre, &expr->where,
(true, false, cond, &se->pre, &expr->where,
"Different CHARACTER lengths (%ld/%ld) in array constructor",
fold_convert (long_integer_type_node, first_len_val),
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,
else
asprintf (&msg, "%s, lower bound of dimension %d exceeded (%%ld < %%ld)",
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, tmp));
gfc_free (msg);
@ -2251,7 +2251,7 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n,
else
asprintf (&msg, "%s, upper bound of dimension %d exceeded (%%ld > %%ld)",
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, tmp));
gfc_free (msg);
@ -2445,7 +2445,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
asprintf (&msg, "%s for array '%s', "
"lower bound of dimension %d exceeded (%%ld < %%ld)",
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,
indexse.expr),
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,
asprintf (&msg, "%s for array '%s', "
"upper bound of dimension %d exceeded (%%ld > %%ld)",
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,
indexse.expr),
fold_convert (long_integer_type_node, tmp));
@ -3026,7 +3026,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "Zero stride is not allowed, for dimension %d "
"of array '%s'", 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);
gfc_free (msg);
desc = ss->data.info.descriptor;
@ -3068,7 +3069,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded (%%ld < %%ld)", gfc_msg_fault,
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,
@ -3084,7 +3086,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
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, ubound));
gfc_free (msg);
@ -3106,7 +3109,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, lower bound of dimension %d of array '%s'"
" exceeded (%%ld < %%ld)", gfc_msg_fault,
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,
@ -3121,7 +3125,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, upper bound of dimension %d of array "
"'%s' exceeded (%%ld > %%ld)", gfc_msg_fault,
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, ubound));
gfc_free (msg);
@ -3144,7 +3149,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
asprintf (&msg, "%s, size mismatch for dimension %d "
"of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
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, size[n]));
gfc_free (msg);
@ -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);
asprintf (&msg, "%s for dimension %d of array '%s'",
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);
}
}
@ -5133,7 +5139,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
/* TODO: Optimize passing g77 arrays. */
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 desc;
@ -5230,17 +5237,59 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77)
/* Repack the array. */
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);
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);
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);
/* Copy the data back. */
tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
if (fsym == NULL || fsym->attr.intent != INTENT_IN)
{
tmp = build_call_expr (gfor_fndecl_in_unpack, 2, desc, ptr);
gfc_add_expr_to_block (&block, tmp);
}
/* Free the temporary. */
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)
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);
tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);

3
gcc/fortran/trans-array.h
View File

@ -105,7 +105,8 @@ void gfc_conv_tmp_ref (gfc_se *);
/* Evaluate an array expression. */
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *, gfc_ss *);
/* 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. */
void gfc_conv_array_transpose (gfc_se *, gfc_expr *);

5
gcc/fortran/trans-decl.c
View File

@ -79,6 +79,7 @@ tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_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_generate_error;
tree gfor_fndecl_set_fpe;
@ -2455,6 +2456,10 @@ gfc_build_builtin_function_decls (void)
/* The runtime_error_at function does not return. */
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 =
gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
void_type_node, 3, pvoid_type_node,

14
gcc/fortran/trans-expr.c
View File

@ -328,7 +328,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
else
asprintf (&msg, "Substring out of bounds: lower bound (%%ld)"
"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,
start.expr));
gfc_free (msg);
@ -344,7 +344,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind,
else
asprintf (&msg, "Substring out of bounds: upper bound (%%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,
se->string_length));
@ -2299,7 +2299,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
f = f || !sym->attr.always_explicit;
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
@ -2535,7 +2535,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_subref_array_arg (&parmse, e, f,
fsym ? fsym->attr.intent : INTENT_INOUT);
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
allocated on entry, it must be deallocated. */
@ -2836,7 +2837,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
tmp = gfc_conv_descriptor_data_get (info->descriptor);
tmp = fold_build2 (NE_EXPR, boolean_type_node,
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;
/* Bundle in the string length. */
@ -4143,7 +4145,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_start_block (&se.pre);
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.ss = gfc_walk_expr (expr2);

11
gcc/fortran/trans-intrinsic.c
View File

@ -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 = fold_build2 (GE_EXPR, boolean_type_node, bound, 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)
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (&argse, arg->expr);
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->post, &argse.post);
ptr = argse.expr;
@ -3958,7 +3959,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
/* Check that NCOPIES is not negative. */
cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
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 "
"(its value is %lld)",
fold_convert (long_integer_type_node, ncopies));
@ -3990,7 +3991,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
build_int_cst (size_type_node, 0));
cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
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");
/* Compute the destination length. */
@ -4094,7 +4095,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr);
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);
/* Create a temporary variable for loc return value. Without this,

2
gcc/fortran/trans-io.c
View File

@ -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 "
"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));
gfc_free (msg);

4
gcc/fortran/trans-stmt.c
View File

@ -154,7 +154,7 @@ gfc_trans_goto (gfc_code * code)
tmp = GFC_DECL_STRING_LEN (se.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
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_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
@ -180,7 +180,7 @@ gfc_trans_goto (gfc_code * code)
code = code->block;
}
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");
return gfc_finish_block (&se.pre);

37
gcc/fortran/trans.c
View File

@ -351,13 +351,14 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
/* Generate a runtime error if COND is true. */
void
gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
const char * msgid, ...)
gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
locus * where, const char * msgid, ...)
{
va_list ap;
stmtblock_t block;
tree body;
tree tmp;
tree tmpvar = NULL;
tree arg, arg2;
tree *argarray;
tree fntype;
@ -377,6 +378,14 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
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. */
gfc_start_block (&block);
@ -408,16 +417,25 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
argarray[2+i] = va_arg (ap, tree);
va_end (ap);
/* Build the function call to runtime_error_at; because of the variable
number of arguments, we can't use build_call_expr directly. */
fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
/* Build the function call to runtime_(warning,error)_at; because of the
variable number of arguments, we can't use build_call_expr directly. */
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),
fold_build1 (ADDR_EXPR,
build_pointer_type (fntype),
gfor_fndecl_runtime_error_at),
error
? gfor_fndecl_runtime_error_at
: gfor_fndecl_runtime_warning_at),
nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp);
if (once)
gfc_add_modify_expr (&block, tmpvar, boolean_false_node);
body = gfc_finish_block (&block);
if (integer_onep (cond))
@ -427,7 +445,12 @@ gfc_trans_runtime_check (tree cond, stmtblock_t * pblock, locus * where,
else
{
/* 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);
cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
cond = fold_convert (boolean_type_node, cond);

6
gcc/fortran/trans.h
View File

@ -444,8 +444,9 @@ void gfc_generate_constructors (void);
/* Get the string length of an array constructor. */
bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
/* Generate a runtime error check. */
void gfc_trans_runtime_check (tree, stmtblock_t *, locus *, const char *, ...);
/* Generate a runtime warning/error check. */
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. */
tree gfc_call_free (tree);
@ -510,6 +511,7 @@ extern GTY(()) tree gfor_fndecl_stop_numeric;
extern GTY(()) tree gfor_fndecl_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_generate_error;
extern GTY(()) tree gfor_fndecl_set_fpe;

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
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>
PR fortran/36934

15
gcc/testsuite/gfortran.dg/array_temporaries_2.f90 Normal file
View File

@ -0,0 +1,15 @@
! { 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'" }

31
gcc/testsuite/gfortran.dg/internal_pack_4.f90 Normal file
View File

@ -0,0 +1,31 @@
! { 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" } }

21
gcc/testsuite/gfortran.dg/internal_pack_5.f90 Normal file
View File

@ -0,0 +1,21 @@
! { 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" } }

9
libgfortran/ChangeLog
View File

@ -1,3 +1,12 @@
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>
PR fortran/36852

1
libgfortran/gfortran.map
View File

@ -1072,6 +1072,7 @@ GFORTRAN_1.1 {
_gfortran_pack_char4;
_gfortran_pack_s_char4;
_gfortran_reshape_char4;
_gfortran_runtime_warning_at;
_gfortran_selected_char_kind;
_gfortran_select_string_char4;
_gfortran_spread_char4;

3
libgfortran/libgfortran.h
View File

@ -643,6 +643,9 @@ extern void runtime_error_at (const char *, const char *, ...)
__attribute__ ((noreturn, format (printf, 2, 3)));
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 *)
__attribute__ ((noreturn));
internal_proto(internal_error);

15
libgfortran/runtime/error.c
View File

@ -285,6 +285,21 @@ runtime_error_at (const char *where, const char *message, ...)
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
* that indicate something deeply wrong. */