git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/46017 (Reject ALLOCATE(a, a%b) as "a%b" depends on the allocation status of "a") 

2011-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/46017
	* resolve.c (resolve_allocate_deallocate): Follow references to
	check for duplicate occurence of allocation/deallocation objects.

2011-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/46017
	* gfortran.dg/allocate_error_2.f90:  New test.

From-SVN: r168506
This commit is contained in:
Thomas Koenig 2011-01-05 10:03:15 +00:00
parent 8c077737e2
commit 75fee9f255
4 changed files with 89 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2011-01-05 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/46017
* resolve.c (resolve_allocate_deallocate): Follow references to
check for duplicate occurence of allocation/deallocation objects.
2011-01-05 Janus Weil <janus@gcc.gnu.org> 2011-01-05 Janus Weil <janus@gcc.gnu.org>
PR fortran/47024 PR fortran/47024

61
gcc/fortran/resolve.c
View File

@ -6981,17 +6981,66 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
for (p = code->ext.alloc.list; p; p = p->next) for (p = code->ext.alloc.list; p; p = p->next)
{ {
pe = p->expr; pe = p->expr;
if ((pe->ref && pe->ref->type != REF_COMPONENT)
&& (pe->symtree->n.sym->ts.type != BT_DERIVED))
{
for (q = p->next; q; q = q->next) for (q = p->next; q; q = q->next)
{ {
qe = q->expr; qe = q->expr;
if ((qe->ref && qe->ref->type != REF_COMPONENT) if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
&& (qe->symtree->n.sym->ts.type != BT_DERIVED) {
&& (pe->symtree->n.sym->name == qe->symtree->n.sym->name)) /* This is a potential collision. */
gfc_ref *pr = pe->ref;
gfc_ref *qr = qe->ref;
/* Follow the references until
a) They start to differ, in which case there is no error;
you can deallocate a%b and a%c in a single statement
b) Both of them stop, which is an error
c) One of them stops, which is also an error. */
while (1)
{
if (pr == NULL && qr == NULL)
{
gfc_error ("Allocate-object at %L also appears at %L", gfc_error ("Allocate-object at %L also appears at %L",
&pe->where, &qe->where); &pe->where, &qe->where);
break;
}
else if (pr != NULL && qr == NULL)
{
gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &pe->where, &qe->where);
break;
}
else if (pr == NULL && qr != NULL)
{
gfc_error ("Allocate-object at %L is subobject of"
" object at %L", &qe->where, &pe->where);
break;
}
/* Here, pr != NULL && qr != NULL */
gcc_assert(pr->type == qr->type);
if (pr->type == REF_ARRAY)
{
/* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
which are legal. */
gcc_assert (qr->type == REF_ARRAY);
if (pr->next && qr->next)
{
gfc_array_ref *par = &(pr->u.ar);
gfc_array_ref *qar = &(qr->u.ar);
if (gfc_dep_compare_expr (par->start[0],
qar->start[0]) != 0)
break;
}
}
else
{
if (pr->u.c.component->name != qr->u.c.component->name)
break;
}
pr = pr->next;
qr = qr->next;
}
} }
} }
} }

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2011-01-05 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/46017
* gfortran.dg/allocate_error_2.f90: New test.
2011-01-05 Janus Weil <janus@gcc.gnu.org> 2011-01-05 Janus Weil <janus@gcc.gnu.org>
PR fortran/47024 PR fortran/47024

20
gcc/testsuite/gfortran.dg/allocate_error_2.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do compile }
program main
type t1
integer, allocatable :: x(:)
integer, allocatable :: y(:)
end type t1
type(t1), allocatable :: v(:)
allocate (v(3), v(4)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" }
allocate (v(1), v(1)%x(2)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" }
allocate (v(1)%x(2), v(1)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" }
allocate (v(1)%y(2), v(1)%x(1))
allocate (v(2)%x(3), v(2)%x(3)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" }
allocate (v(1)%x(3), v(2)%x(3))
deallocate (v, v) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" }
deallocate (v, v(1)%x) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" }
deallocate (v(1)%x, v) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" }
deallocate (v(1)%y, v(1)%x)
deallocate (v(2)%x, v(2)%x) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" }
deallocate (v(1)%x, v(2)%x)
end program main