This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, Fortran] PRs 36132, 29952, 36909 - optional array arg; temp array; missed opt
- From: Tobias Burnus <tobias dot burnus at physik dot fu-berlin dot de>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Sat, 26 Jul 2008 18:47:27 +0200
- Subject: [Patch, Fortran] PRs 36132, 29952, 36909 - optional array arg; temp array; missed opt
Dear all,
this patch fixes three bugs, which look quite different but affect the
same spot in the source code, gfc_conv_array_parameter, and require all
that formal-argument information is available.
a) wrong-code PR 36132. If the actual argument is an optional array
and the corresponding dummy argument is also optional and not
assumed-shape, then _gfortran_internal_pack is called. The problem
is that the call was also done when the argument was not present.
b) diagnostic PR 29952 'Flag to give runtime information
"array temporary was created for argument"'
This is the run-time version of Thomas' recent patch.
Also here the formal argument is needed plus the name of the
procedure. Additionally, we need now to support printing a
run-time warning, before the library only supported run-time
errors.
c) missed-optimization PR 36909. When doing packing/unpacking
of array arguments, one can save the unpacking when the
formal argument is INTENT(IN).
Also here, the formal argument information was required.
Built and check-gfortraned on x86-64-linux.
OK for the trunk?
Joosts wants to know whether one can backport (4.3.x) the
wrong-code PR 36132 as it seemingly causes a crash in CP2k.
Is that OK? Should I post a patch for that for review?
Tobias
2008-07-26 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-26 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-26 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.
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 138169)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -328,7 +328,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref
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, 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
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, 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
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
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
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, 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 * e
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);
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 138169)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -1022,7 +1022,7 @@ gfc_trans_array_ctor_element (stmtblock_
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, 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
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, 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
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, 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_arr
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, 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_arr
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, 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 *
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, tmp, &inner, &ss->expr->where,
+ msg);
gfc_free (msg);
desc = ss->data.info.descriptor;
@@ -3068,7 +3069,7 @@ gfc_conv_ss_startstride (gfc_loopinfo *
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, tmp, &inner, &ss->expr->where, msg,
fold_convert (long_integer_type_node,
info->start[n]),
fold_convert (long_integer_type_node,
@@ -3084,7 +3085,7 @@ gfc_conv_ss_startstride (gfc_loopinfo *
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, 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 +3107,7 @@ gfc_conv_ss_startstride (gfc_loopinfo *
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, tmp, &inner, &ss->expr->where, msg,
fold_convert (long_integer_type_node,
tmp2),
fold_convert (long_integer_type_node,
@@ -3121,7 +3122,7 @@ gfc_conv_ss_startstride (gfc_loopinfo *
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, 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 +3145,8 @@ gfc_conv_ss_startstride (gfc_loopinfo *
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, 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 +4385,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
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, tmp, &block, &loc, msg);
gfc_free (msg);
}
}
@@ -5133,7 +5135,8 @@ gfc_conv_expr_descriptor (gfc_se * se, g
/* 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 +5233,53 @@ gfc_conv_array_parameter (gfc_se * se, g
/* 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);
+ gfc_trans_runtime_check (false, 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 +5294,11 @@ gfc_conv_array_parameter (gfc_se * se, g
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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (Revision 138169)
+++ gcc/fortran/trans-array.h (Arbeitskopie)
@@ -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 *);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 138169)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -1895,6 +1893,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;
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt (Revision 138169)
+++ gcc/fortran/lang.opt (Arbeitskopie)
@@ -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
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 138169)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -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, 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, boolean_true_node, &se.pre, &loc,
"Assigned label is not in the list");
return gfc_finish_block (&se.pre);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (Revision 138169)
+++ gcc/fortran/trans.c (Arbeitskopie)
@@ -351,8 +351,8 @@ gfc_build_array_ref (tree base, tree off
/* 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, tree cond, stmtblock_t * pblock,
+ locus * where, const char * msgid, ...)
{
va_list ap;
stmtblock_t block;
@@ -408,13 +408,19 @@ gfc_trans_runtime_check (tree cond, stmt
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);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (Revision 138169)
+++ gcc/fortran/trans.h (Arbeitskopie)
@@ -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, 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_num
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;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (Revision 138169)
+++ gcc/fortran/trans-io.c (Arbeitskopie)
@@ -668,7 +668,7 @@ set_string (stmtblock_t * block, stmtblo
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, cond, &se.pre, &e->where, msg,
fold_convert (long_integer_type_node, tmp));
gfc_free (msg);
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 138169)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -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,
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (Revision 138169)
+++ gcc/fortran/trans-intrinsic.c (Arbeitskopie)
@@ -864,7 +864,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, g
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, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
}
}
@@ -3632,7 +3648,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se
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 +3974,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se,
/* 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, 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 +4006,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se,
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, cond, &se->pre, &expr->where,
"Argument NCOPIES of REPEAT intrinsic is too large");
/* Compute the destination length. */
@@ -4094,7 +4110,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc
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,
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c (Revision 138169)
+++ gcc/fortran/options.c (Arbeitskopie)
@@ -101,6 +101,7 @@ gfc_init_options (unsigned int argc, con
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 c
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;
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c (Revision 138169)
+++ libgfortran/runtime/error.c (Arbeitskopie)
@@ -285,6 +285,21 @@ runtime_error_at (const char *where, con
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. */
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (Revision 138169)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1071,6 +1071,7 @@ GFORTRAN_1.1 {
_gfortran_erfc_scaled_r8;
_gfortran_pack_char4;
_gfortran_pack_s_char4;
_gfortran_reshape_char4;
+ _gfortran_runtime_warning_at;
_gfortran_selected_char_kind;
_gfortran_select_string_char4;
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (Revision 138169)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -643,6 +643,9 @@ extern void runtime_error_at (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);
Index: gcc/testsuite/gfortran.dg/internal_pack_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/internal_pack_4.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/internal_pack_4.f90 (Revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/internal_pack_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/internal_pack_5.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/internal_pack_5.f90 (Revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/array_temporaries_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/array_temporaries_2.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/array_temporaries_2.f90 (Revision 0)
@@ -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'" }
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi (Revision 138169)
+++ gcc/fortran/invoke.texi (Arbeitskopie)
@@ -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,15 @@ 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}
+@index 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.
+
+
@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