procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
PR fortran/47024

67
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)
{
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;
if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
{
qe = q->expr;
if ((qe->ref && qe->ref->type != REF_COMPONENT)
&& (qe->symtree->n.sym->ts.type != BT_DERIVED)
&& (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
gfc_error ("Allocate-object at %L also appears at %L",
&pe->where, &qe->where);
/* 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",
&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>
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