+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.
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;
@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
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
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
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;
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;
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));
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);
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);
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));
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));
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;
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,
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);
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,
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);
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);
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);
}
}
/* 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;
/* 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));
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);
/* 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 *);
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;
/* 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,
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);
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));
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
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. */
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. */
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);
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);
}
}
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;
/* 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));
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. */
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,
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);
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);
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);
/* 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;
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);
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))
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);
/* 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);
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;
+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
--- /dev/null
+! { 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'" }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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>
PR fortran/36852
_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;
__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);
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. */
projects / gcc.git / commitdiff