diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 73424965b53d..d3d36903beca 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,25 @@
+2008-09-18 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37507
+ * trans.h (gfc_trans_runtime_error): New method.
+ (gfc_trans_runtime_error_vararg): New method.
+ (gfc_allocate_array_with_status): New argument `expr' for locus/varname.
+ (gfc_deallocate_array_with_status): Ditto.
+ * trans-array.h (gfc_array_deallocate): Ditto.
+ * trans.c (gfc_trans_runtime_error): New method.
+ (gfc_trans_runtime_error_vararg): New method, moved parts of the code
+ from gfc_trans_runtime_check here.
+ (gfc_trans_runtime_error_check): Moved code partly to new method.
+ (gfc_call_malloc): Fix tab-indentation.
+ (gfc_allocate_array_with_status): New argument `expr' and call
+ gfc_trans_runtime_error for error reporting to include locus.
+ (gfc_deallocate_with_status): Ditto.
+ * trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument.
+ * trans-array.c (gfc_array_allocate): Ditto.
+ (gfc_array_deallocate): New argument `expr', passed on.
+ (gfc_trans_dealloc_allocated): Pass NULL for expr.
+ * trans-openmp.c (gfc_omp_clause_default): Ditto.
+
2008-09-18 Paul Thomas <pault@gcc.gnu.org>
PR fortran/37274
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 1ab58e1d7eba..f4af4f25da18 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3796,7 +3796,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
- tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat);
+ tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
else
tmp = gfc_allocate_with_status (&se->pre, size, pstat);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
@@ -3822,7 +3822,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor, tree pstat)
+gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
{
tree var;
tree tmp;
@@ -3834,7 +3834,7 @@ gfc_array_deallocate (tree descriptor, tree pstat)
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = gfc_deallocate_with_status (var, pstat, false);
+ tmp = gfc_deallocate_with_status (var, pstat, false, expr);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@@ -5341,7 +5341,7 @@ gfc_trans_dealloc_allocated (tree descriptor)
/* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = gfc_deallocate_with_status (var, NULL_TREE, true);
+ tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 18de51c8437f..2cc9d5caf28c 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -20,7 +20,7 @@ along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
/* Generate code to free an array. */
-tree gfc_array_deallocate (tree, tree);
+tree gfc_array_deallocate (tree, tree, gfc_expr*);
/* Generate code to initialize an allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 11a1f40dface..04ec4d4c12c3 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -163,7 +163,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
ptr = gfc_allocate_array_with_status (&cond_block,
build_int_cst (pvoid_type_node, 0),
- size, NULL);
+ size, NULL, NULL);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
then_b = gfc_finish_block (&cond_block);
@@ -215,7 +215,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_allocate_array_with_status (&block,
build_int_cst (pvoid_type_node, 0),
- size, NULL);
+ size, NULL, NULL);
gfc_conv_descriptor_data_set (&block, dest, ptr);
call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
fold_convert (pvoid_type_node,
@@ -619,7 +619,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_allocate_array_with_status (&block,
build_int_cst (pvoid_type_node, 0),
- size, NULL);
+ size, NULL, NULL);
gfc_conv_descriptor_data_set (&block, decl, ptr);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
stmt = gfc_finish_block (&block);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 26ea70ce3d81..da227523e72d 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4005,16 +4005,16 @@ gfc_trans_deallocate (gfc_code * code)
&& !(!last && expr->symtree->n.sym->attr.pointer))
{
tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
- expr->rank);
+ expr->rank);
gfc_add_expr_to_block (&se.pre, tmp);
}
}
if (expr->rank)
- tmp = gfc_array_deallocate (se.expr, pstat);
+ tmp = gfc_array_deallocate (se.expr, pstat, expr);
else
{
- tmp = gfc_deallocate_with_status (se.expr, pstat, false);
+ tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = fold_build2 (MODIFY_EXPR, void_type_node,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 1b115f435fc8..b8f0d2dd35bd 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -347,17 +347,24 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
}
-/* Generate a runtime error if COND is true. */
+/* Generate a call to print a runtime error possibly including multiple
+ arguments and a locus. */
-void
-gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
- locus * where, const char * msgid, ...)
+tree
+gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
{
va_list ap;
+
+ va_start (ap, msgid);
+ return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
+}
+
+tree
+gfc_trans_runtime_error_vararg (bool error, 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;
@@ -365,9 +372,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
const char *p;
int line, nargs, i;
- if (integer_zerop (cond))
- return;
-
/* Compute the number of extra arguments from the format string. */
for (p = msgid, nargs = 0; *p; p++)
if (*p == '%')
@@ -377,14 +381,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
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);
@@ -411,9 +407,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
argarray[0] = arg;
argarray[1] = arg2;
- va_start (ap, msgid);
for (i = 0; i < nargs; i++)
- argarray[2+i] = va_arg (ap, tree);
+ argarray[2 + i] = va_arg (ap, tree);
va_end (ap);
/* Build the function call to runtime_(warning,error)_at; because of the
@@ -432,6 +427,41 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
nargs + 2, argarray);
gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+}
+
+
+/* Generate a runtime error if COND is true. */
+
+void
+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;
+
+ if (integer_zerop (cond))
+ return;
+
+ 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);
+ }
+
+ gfc_start_block (&block);
+
+ /* The code to generate the error. */
+ va_start (ap, msgid);
+ gfc_add_expr_to_block (&block,
+ gfc_trans_runtime_error_vararg (error, where,
+ msgid, ap));
+
if (once)
gfc_add_modify (&block, tmpvar, boolean_false_node);
@@ -524,30 +554,30 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
void *newmem;
if (stat)
- *stat = 0;
+ *stat = 0;
// The only time this can happen is the size wraps around.
if (size < 0)
{
- if (stat)
- {
- *stat = LIBERROR_ALLOCATION;
- newmem = NULL;
- }
- else
- runtime_error ("Attempt to allocate negative amount of memory. "
- "Possible integer overflow");
+ if (stat)
+ {
+ *stat = LIBERROR_ALLOCATION;
+ newmem = NULL;
+ }
+ else
+ runtime_error ("Attempt to allocate negative amount of memory. "
+ "Possible integer overflow");
}
else
{
- newmem = malloc (MAX (size, 1));
- if (newmem == NULL)
- {
- if (stat)
- *stat = LIBERROR_ALLOCATION;
- else
- runtime_error ("Out of memory");
- }
+ newmem = malloc (MAX (size, 1));
+ if (newmem == NULL)
+ {
+ if (stat)
+ *stat = LIBERROR_ALLOCATION;
+ else
+ runtime_error ("Out of memory");
+ }
}
return newmem;
@@ -668,13 +698,16 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
}
else
runtime_error ("Attempting to allocate already allocated array");
- } */
+ }
+
+ expr must be set to the original expression being allocated for its locus
+ and variable name in case a runtime error has to be printed. */
tree
gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
- tree status)
+ tree status, gfc_expr* expr)
{
stmtblock_t alloc_block;
- tree res, tmp, null_mem, alloc, error, msg;
+ tree res, tmp, null_mem, alloc, error;
tree type = TREE_TYPE (mem);
if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
@@ -692,9 +725,23 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
alloc = gfc_finish_block (&alloc_block);
/* Otherwise, we issue a runtime error or set the status variable. */
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Attempting to allocate already allocated array"));
- error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+ if (expr)
+ {
+ tree varname;
+
+ gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
+ varname = gfc_build_cstring_const (expr->symtree->name);
+ varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+ error = gfc_trans_runtime_error (true, &expr->where,
+ "Attempting to allocate already"
+ " allocated array '%s'",
+ varname);
+ }
+ else
+ error = gfc_trans_runtime_error (true, NULL,
+ "Attempting to allocate already allocated"
+ "array");
if (status != NULL_TREE && !integer_zerop (status))
{
@@ -775,12 +822,16 @@ gfc_call_free (tree var)
Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
even when no status variable is passed to us (this is used for
unconditional deallocation generated by the front-end at end of
- each procedure). */
+ each procedure).
+
+ If a runtime-message is possible, `expr' must point to the original
+ expression being deallocated for its locus and variable name. */
tree
-gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
+gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
+ gfc_expr* expr)
{
stmtblock_t null, non_null;
- tree cond, tmp, error, msg;
+ tree cond, tmp, error;
cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
build_int_cst (TREE_TYPE (pointer), 0));
@@ -790,10 +841,16 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
gfc_start_block (&null);
if (!can_fail)
{
- msg = gfc_build_addr_expr (pchar_type_node,
- gfc_build_localized_cstring_const
- ("Attempt to DEALLOCATE unallocated memory."));
- error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
+ tree varname;
+
+ gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
+
+ varname = gfc_build_cstring_const (expr->symtree->name);
+ varname = gfc_build_addr_expr (pchar_type_node, varname);
+
+ error = gfc_trans_runtime_error (true, &expr->where,
+ "Attempt to DEALLOCATE unallocated '%s'",
+ varname);
}
else
error = build_empty_stmt ();
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 5d729eaab837..36553ea255bf 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -450,6 +450,10 @@ 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 call. */
+tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
+tree gfc_trans_runtime_error_vararg (bool, locus*, const char*, va_list);
+
/* Generate a runtime warning/error check. */
void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
const char *, ...);
@@ -461,13 +465,13 @@ tree gfc_call_free (tree);
tree gfc_call_malloc (stmtblock_t *, tree, tree);
/* Allocate memory for arrays, with optional status variable. */
-tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree);
+tree gfc_allocate_array_with_status (stmtblock_t*, tree, tree, tree, gfc_expr*);
/* Allocate memory, with optional status variable. */
tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
/* Generate code to deallocate an array. */
-tree gfc_deallocate_with_status (tree, tree, bool);
+tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index cebd6736e5d0..e905405bbd9e 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2008-09-18 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37507
+ * gfortran.dg/allocate_error_1.f90: New test.
+ * gfortran.dg/deallocate_error_1.f90: New test.
+ * gfortran.dg/deallocate_error_2.f90: New test.
+
2008-09-18 Richard Guenther <rguenther@suse.de>
PR tree-optimization/37456
diff --git a/gcc/testsuite/gfortran.dg/allocate_error_1.f90 b/gcc/testsuite/gfortran.dg/allocate_error_1.f90
new file mode 100644
index 000000000000..42a12159e282
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_error_1.f90
@@ -0,0 +1,14 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 13.*Attempting to allocate .* 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for ALLOCATE errors.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER, ALLOCATABLE :: arr(:)
+
+ ALLOCATE (arr(5))
+ ALLOCATE (arr(6))
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_1.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90
new file mode 100644
index 000000000000..98ffdb3b91ad
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 14.*Attempt to DEALLOCATE unallocated 'arr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER, ALLOCATABLE :: arr(:)
+
+ ALLOCATE (arr(5))
+ DEALLOCATE (arr)
+ DEALLOCATE (arr)
+END PROGRAM main
diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_2.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90
new file mode 100644
index 000000000000..bda1adff514c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90
@@ -0,0 +1,16 @@
+! { dg-do run }
+! { dg-shouldfail "runtime error" }
+! { dg-output "At line 15.*Attempt to DEALLOCATE unallocated 'ptr'" }
+
+! PR fortran/37507
+! Check that locus is printed for DEALLOCATE errors.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER, POINTER :: ptr
+ INTEGER, ALLOCATABLE :: arr(:)
+
+ ALLOCATE (ptr, arr(5))
+ DEALLOCATE (ptr)
+ DEALLOCATE (arr, ptr)
+END PROGRAM main