Patchwork [fortran] PR 46017 - Reject ALLOCATE(a, a%b)

login
register
mail settings
Submitter Thomas Koenig
Date Jan. 2, 2011, 3:51 p.m.
Message ID <4D209F09.4010300@netcologne.de>
Download mbox | patch
Permalink /patch/77192/
State New
Headers show

Comments

Thomas Koenig - Jan. 2, 2011, 3:51 p.m.
Hello world,

here's a patch for the PR.  Regression-tested.  OK for trunk?

    Thomas

2011-01-02  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-02  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/46017
    * gfortran.dg/allocate_error_2.f90:  New test.
! { 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
Thomas Koenig - Jan. 4, 2011, 3:17 p.m.
Am 02.01.2011 16:51, schrieb Thomas Koenig:
> Hello world,
> 
> here's a patch for the PR.  Regression-tested.  OK for trunk?

Ping ** 0.25?
Jerry DeLisle - Jan. 5, 2011, 2:36 a.m.
On 01/04/2011 07:17 AM, Thomas Koenig wrote:
> Am 02.01.2011 16:51, schrieb Thomas Koenig:
>> Hello world,
>>
>> here's a patch for the PR.  Regression-tested.  OK for trunk?
>
> Ping ** 0.25?
>

Yes, OK and thanks for the patch!

Jerry
Thomas Koenig - Jan. 5, 2011, 10:03 a.m.
Hi Jerry,

> On 01/04/2011 07:17 AM, Thomas Koenig wrote:
>> Am 02.01.2011 16:51, schrieb Thomas Koenig:
>>> Hello world,
>>>
>>> here's a patch for the PR.  Regression-tested.  OK for trunk?
>>
>> Ping ** 0.25?
>>
> 
> Yes, OK and thanks for the patch!

Sende          fortran/ChangeLog
Sende          fortran/resolve.c
Sende          testsuite/ChangeLog
Hinzufügen     testsuite/gfortran.dg/allocate_error_2.f90
Übertrage Daten ....
Revision 168506 übertragen.

Thanks for the review!

	Thomas

Patch

Index: resolve.c
===================================================================
--- resolve.c	(Revision 168366)
+++ resolve.c	(Arbeitskopie)
@@ -6981,17 +6981,66 @@  resolve_allocate_deallocate (gfc_code *code, const
   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;
+		}
 	    }
 	}
     }