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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 13cda0205c01811160f8658c8cffacc88b4c6176..5be47c6d80877bef31f37a8081edb7ff46bd0856 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9a5dcc1040ea5b20d89a80bcf10d141cfd97e9fd..28fec7d9b435f1b211967ceb6174e768c8eef007 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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;
+               }
            }
        }
     }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 4a49afb0f3a539ccf46e7fe7d6940840aa38e155..208304ce79aade84a16fffb4b3cbfe3b75356d8d 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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

diff --git a/gcc/testsuite/gfortran.dg/allocate_error_2.f90 b/gcc/testsuite/gfortran.dg/allocate_error_2.f90
new file mode 100644 (file)
index 0000000..1a301de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_error_2.f90
@@ -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