mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-19 22:41:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/37507 (Print location in (DE)ALLOCATION errors)

Browse Source 
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  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.

From-SVN: r140451
This commit is contained in:
Daniel Kraft 2008-09-18 14:02:50 +02:00 committed by Daniel Kraft
parent e7089ecf1c
commit f25a62a5f3
11 changed files with 197 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/fortran/ChangeLog
View File

@ -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

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

@ -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. */

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

@ -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. */

6
gcc/fortran/trans-openmp.c
View File

@ -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);

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

@ -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,

155
gcc/fortran/trans.c
View File

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

8
gcc/fortran/trans.h
View File

@ -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);

7
gcc/testsuite/ChangeLog
View File

@ -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

14
gcc/testsuite/gfortran.dg/allocate_error_1.f90 Normal file
View File

@ -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

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

@ -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

16
gcc/testsuite/gfortran.dg/deallocate_error_2.f90 Normal file
View File

@ -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