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

4 files changed, 89 insertions, 9 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 13cda02..5be47c6 100644
--- 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 9a5dcc1..28fec7d 100644
--- 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 4a49afb..208304c 100644
--- 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
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