diff mbox

[Fortran] PR44556 Fix 4.5/4.6 regression in (DE)ALLOCATE stat/errmsg checking

Message ID 4C1B2106.5040807@net-b.de
State New
Headers show

Commit Message

Tobias Burnus June 18, 2010, 7:32 a.m. UTC 
Since 4.5, gfortran has a check which prevents "allocate(a, stat=a)",
i.e. that the allocate and stat variable is the same. However, the
current check fails for different components of the same derived type.

The attached patch fixes this.

Build and regtested on x86-64-linux.
OK for the trunk?

Tobias

Comments

Steve Kargl June 18, 2010, 10:07 p.m. UTC | #1 
On Fri, Jun 18, 2010 at 09:32:22AM +0200, Tobias Burnus wrote:
> Since 4.5, gfortran has a check which prevents "allocate(a, stat=a)",
> i.e. that the allocate and stat variable is the same. However, the
> current check fails for different components of the same derived type.
> 
> The attached patch fixes this.
> 
> Build and regtested on x86-64-linux.
> OK for the trunk?
> 

OK.
Tobias Burnus June 18, 2010, 10:24 p.m. UTC | #2 
Steve Kargl wrote:
> On Fri, Jun 18, 2010 at 09:32:22AM +0200, Tobias Burnus wrote:
>   
>> The attached patch fixes this.
>> Build and regtested on x86-64-linux.
>> OK for the trunk
> OK.
>   

Thanks for the review  (committed as Rev. 161011).
I intent to commit the patch to the 4.5 branch in the next days.

Tobias
diff mbox

Patch

2010-06-18  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44556
	* resolve.c (resolve_allocate_deallocate): Properly check
	part-refs in stat=/errmsg= for invalid use.

2010-06-18  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44556
	* gfortran.dg/allocate_alloc_opt_11.f90: New.

Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 160936)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -6589,8 +6589,29 @@  resolve_allocate_deallocate (gfc_code *c
 
       for (p = code->ext.alloc.list; p; p = p->next)
 	if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
-	  gfc_error ("Stat-variable at %L shall not be %sd within "
-		     "the same %s statement", &stat->where, fcn, fcn);
+	  {
+	    gfc_ref *ref1, *ref2;
+	    bool found = true;
+
+	    for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2;
+		 ref1 = ref1->next, ref2 = ref2->next)
+	      {
+		if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+		  continue;
+		if (ref1->u.c.component->name != ref2->u.c.component->name)
+		  {
+		    found = false;
+		    break;
+		  }
+	      }
+
+	    if (found)
+	      {
+		gfc_error ("Stat-variable at %L shall not be %sd within "
+			   "the same %s statement", &stat->where, fcn, fcn);
+		break;
+	      }
+	  }
     }
 
   /* Check the errmsg variable.  */
@@ -6618,8 +6639,29 @@  resolve_allocate_deallocate (gfc_code *c
 
       for (p = code->ext.alloc.list; p; p = p->next)
 	if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
-	  gfc_error ("Errmsg-variable at %L shall not be %sd within "
-		     "the same %s statement", &errmsg->where, fcn, fcn);
+	  {
+	    gfc_ref *ref1, *ref2;
+	    bool found = true;
+
+	    for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2;
+		 ref1 = ref1->next, ref2 = ref2->next)
+	      {
+		if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT)
+		  continue;
+		if (ref1->u.c.component->name != ref2->u.c.component->name)
+		  {
+		    found = false;
+		    break;
+		  }
+	      }
+
+	    if (found)
+	      {
+		gfc_error ("Errmsg-variable at %L shall not be %sd within "
+			   "the same %s statement", &errmsg->where, fcn, fcn);
+		break;
+	      }
+	  }
     }
 
   /* Check that an allocate-object appears only once in the statement.  

Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_11.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_alloc_opt_11.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_11.f90	(Revision 0)
@@ -0,0 +1,26 @@ 
+! { dg-do compile }
+!
+! PR fortran/44556
+!
+! Contributed by Jonathan Hogg and Steve Kargl.
+!
+program oh_my
+   implicit none
+   type a
+      integer, allocatable :: b(:), d(:)
+      character(len=80) :: err
+      character(len=80), allocatable :: str(:)
+      integer :: src
+   end type a
+
+   integer j
+   type(a) :: c
+   c%err = 'ok'
+   allocate(c%d(1)) 
+   allocate(c%b(2), errmsg=c%err, stat=c%d(1)) ! OK
+   deallocate(c%b, errmsg=c%err, stat=c%d(1))  ! OK
+   allocate(c%b(2), errmsg=c%err, stat=c%b(1)) ! { dg-error "the same ALLOCATE statement" }
+   deallocate(c%b, errmsg=c%err, stat=c%b(1))  ! { dg-error "the same DEALLOCATE statement" }
+   allocate(c%str(2), errmsg=c%str(1), stat=j) ! { dg-error "the same ALLOCATE statement" }
+   deallocate(c%str, errmsg=c%str(1), stat=j)  ! { dg-error "the same DEALLOCATE statement" }
+end program oh_my