diff mbox

[fortran] Fix PR 45777

Message ID 4D22E10B.7010803@netcologne.de
State New
Headers show

Commit Message

Thomas Koenig Jan. 4, 2011, 8:57 a.m. UTC 
Hello world,

this patch fixes one of the fortran-90 wrong-code bugs still left. I
have taken the liberty of moving one function to where it is actually
needed.

OK for trunk?

	Thomas

2011-01-04  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45777
	* symbol.c (gfc_symbols_could_alias):  Strip gfc_ prefix,
	make static and move in front of its only caller, to ...
	* trans-array.c (symbols_could_alias): ... here.
	Pass information about pointer and target status as
	arguments.  Allocatable arrays don't alias anything
	unless they have the POINTER attribute.
	(gfc_could_be_alias):  Keep track of pointer and target
	status when following references.  Also check if typespecs
	of components match those of other components or symbols.

2011-01-04  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/45777
	* gfortran.dg/dependency_39.f90:  New test.
! { dg-do run }
! PR 45777 - component ref aliases when both are pointers
module m1
  type t1
     integer, dimension(:), allocatable :: data
  end type t1
contains
  subroutine s1(t,d)
    integer, dimension(:), pointer :: d
    type(t1), pointer :: t
    d(1:5)=t%data(3:7)
  end subroutine s1
  subroutine s2(d,t)
    integer, dimension(:), pointer :: d
    type(t1), pointer :: t
    t%data(3:7) = d(1:5)
  end subroutine s2
end module m1

program main
  use m1
  type(t1), pointer :: t
  integer, dimension(:), pointer :: d
  allocate(t)
  allocate(t%data(10))
  t%data=(/(i,i=1,10)/)
  d=>t%data(5:9)
  call s1(t,d)
  if (any(d.ne.(/3,4,5,6,7/))) call abort()
  t%data=(/(i,i=1,10)/)
  d=>t%data(1:5)
  call s2(d,t)
  if (any(t%data.ne.(/1,2,1,2,3,4,5,8,9,10/))) call abort
  deallocate(t%data)
  deallocate(t)
end program main
! { dg-final { cleanup-modules "m1" } }

Comments

Thomas Koenig Jan. 7, 2011, 7:53 p.m. UTC | #1 
Am 04.01.2011 09:57, schrieb Thomas Koenig:
> Hello world,
> 
> this patch fixes one of the fortran-90 wrong-code bugs still left. I
> have taken the liberty of moving one function to where it is actually
> needed.
> 
> OK for trunk?

Ping ** 0.5

	Thomas
Jerry DeLisle Jan. 8, 2011, 1:01 a.m. UTC | #2 
On 01/07/2011 11:53 AM, Thomas Koenig wrote:
> Am 04.01.2011 09:57, schrieb Thomas Koenig:
>> Hello world,
>>
>> this patch fixes one of the fortran-90 wrong-code bugs still left. I
>> have taken the liberty of moving one function to where it is actually
>> needed.
>>
>> OK for trunk?
>
> Ping ** 0.5
>
> 	Thomas
>

Yes, OK, thanks for the patch.

Jerry
Thomas Koenig Jan. 8, 2011, 9:40 a.m. UTC | #3 
Hi Jerry,

> On 01/07/2011 11:53 AM, Thomas Koenig wrote:
>> Am 04.01.2011 09:57, schrieb Thomas Koenig:
>>> Hello world,
>>>
>>> this patch fixes one of the fortran-90 wrong-code bugs still left. I
>>> have taken the liberty of moving one function to where it is actually
>>> needed.
>>>
>>> OK for trunk?
>>
>> Ping ** 0.5
>>
>>     Thomas
>>
> 
> Yes, OK, thanks for the patch.

Sending        fortran/ChangeLog
Sending        fortran/gfortran.h
Sending        fortran/symbol.c
Sending        fortran/trans-array.c
Sending        testsuite/ChangeLog
Adding         testsuite/gfortran.dg/dependency_39.f90
Transmitting file data ......
Committed revision 168596.

Thanks for the review!

I expect this also affects 4.5.  I'll test and backport (if affected) in
a few days.

	Thomas
diff mbox

Patch

Index: trans-array.c
===================================================================
--- trans-array.c	(Revision 168201)
+++ trans-array.c	(Arbeitskopie)
@@ -3449,7 +3449,38 @@  gfc_conv_ss_startstride (gfc_loopinfo * loop)
     }
 }
 
+/* Return true if both symbols could refer to the same data object.  Does
+   not take account of aliasing due to equivalence statements.  */
 
+static int
+symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym, bool lsym_pointer,
+		     bool lsym_target, bool rsym_pointer, bool rsym_target)
+{
+  /* Aliasing isn't possible if the symbols have different base types.  */
+  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
+    return 0;
+
+  /* Pointers can point to other pointers and target objects.  */
+
+  if ((lsym_pointer && (rsym_pointer || rsym_target))
+      || (rsym_pointer && (lsym_pointer || lsym_target)))
+    return 1;
+
+  /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
+     and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
+     checked above.  */
+  if (lsym_target && rsym_target
+      && ((lsym->attr.dummy && !lsym->attr.contiguous
+	   && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
+	  || (rsym->attr.dummy && !rsym->attr.contiguous
+	      && (!rsym->attr.dimension
+		  || rsym->as->type == AS_ASSUMED_SHAPE))))
+    return 1;
+
+  return 0;
+}
+
+
 /* Return true if the two SS could be aliased, i.e. both point to the same data
    object.  */
 /* TODO: resolve aliases based on frontend expressions.  */
@@ -3461,10 +3492,18 @@  gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
   gfc_ref *rref;
   gfc_symbol *lsym;
   gfc_symbol *rsym;
+  bool lsym_pointer, lsym_target, rsym_pointer, rsym_target;
 
   lsym = lss->expr->symtree->n.sym;
   rsym = rss->expr->symtree->n.sym;
-  if (gfc_symbols_could_alias (lsym, rsym))
+
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  rsym_pointer = rsym->attr.pointer;
+  rsym_target = rsym->attr.target;
+
+  if (symbols_could_alias (lsym, rsym, lsym_pointer, lsym_target,
+			   rsym_pointer, rsym_target))
     return 1;
 
   if (rsym->ts.type != BT_DERIVED && rsym->ts.type != BT_CLASS
@@ -3479,27 +3518,75 @@  gfc_could_be_alias (gfc_ss * lss, gfc_ss * rss)
       if (lref->type != REF_COMPONENT)
 	continue;
 
-      if (gfc_symbols_could_alias (lref->u.c.sym, rsym))
+      lsym_pointer = lsym_pointer || lref->u.c.sym->attr.pointer;
+      lsym_target  = lsym_target  || lref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (lref->u.c.sym, rsym, lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
 	return 1;
 
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lref->u.c.component->ts,
+				 &rsym->ts))
+	    return 1;
+	}
+
       for (rref = rss->expr->ref; rref != rss->data.info.ref;
 	   rref = rref->next)
 	{
 	  if (rref->type != REF_COMPONENT)
 	    continue;
 
-	  if (gfc_symbols_could_alias (lref->u.c.sym, rref->u.c.sym))
+	  rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+	  rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+	  if (symbols_could_alias (lref->u.c.sym, rref->u.c.sym,
+				   lsym_pointer, lsym_target,
+				   rsym_pointer, rsym_target))
 	    return 1;
+
+	  if ((lsym_pointer && (rsym_pointer || rsym_target))
+	      || (rsym_pointer && (lsym_pointer || lsym_target)))
+	    {
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.sym->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.sym->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	      if (gfc_compare_types (&lref->u.c.component->ts,
+				     &rref->u.c.component->ts))
+		return 1;
+	    }
 	}
     }
 
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+  lsym_pointer = lsym->attr.pointer;
+  lsym_target = lsym->attr.target;
+
   for (rref = rss->expr->ref; rref != rss->data.info.ref; rref = rref->next)
     {
       if (rref->type != REF_COMPONENT)
 	break;
 
-      if (gfc_symbols_could_alias (rref->u.c.sym, lsym))
+      rsym_pointer = rsym_pointer || rref->u.c.sym->attr.pointer;
+      rsym_target  = lsym_target  || rref->u.c.sym->attr.target;
+
+      if (symbols_could_alias (rref->u.c.sym, lsym,
+			       lsym_pointer, lsym_target,
+			       rsym_pointer, rsym_target))
 	return 1;
+
+      if ((lsym_pointer && (rsym_pointer || rsym_target))
+	  || (rsym_pointer && (lsym_pointer || lsym_target)))
+	{
+	  if (gfc_compare_types (&lsym->ts, &rref->u.c.component->ts))
+	    return 1;
+	}
     }
 
   return 0;
Index: symbol.c
===================================================================
--- symbol.c	(Revision 168201)
+++ symbol.c	(Arbeitskopie)
@@ -2842,41 +2842,6 @@  gfc_get_ha_symbol (const char *name, gfc_symbol **
   return i;
 }
 
-/* Return true if both symbols could refer to the same data object.  Does
-   not take account of aliasing due to equivalence statements.  */
-
-int
-gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
-{
-  /* Aliasing isn't possible if the symbols have different base types.  */
-  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
-    return 0;
-
-  /* Pointers can point to other pointers, target objects and allocatable
-     objects.  Two allocatable objects cannot share the same storage.  */
-  if (lsym->attr.pointer
-      && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
-    return 1;
-  if (lsym->attr.target && rsym->attr.pointer)
-    return 1;
-  if (lsym->attr.allocatable && rsym->attr.pointer)
-    return 1;
-
-  /* Special case: Argument association, cf. F90 12.4.1.6, F2003 12.4.1.7
-     and F2008 12.5.2.13 items 3b and 4b. The pointer case (a) is already
-     checked above.  */
-  if (lsym->attr.target && rsym->attr.target
-      && ((lsym->attr.dummy && !lsym->attr.contiguous
-	   && (!lsym->attr.dimension || lsym->as->type == AS_ASSUMED_SHAPE))
-	  || (rsym->attr.dummy && !rsym->attr.contiguous
-	      && (!rsym->attr.dimension
-		  || rsym->as->type == AS_ASSUMED_SHAPE))))
-    return 1;
-
-  return 0;
-}
-
-
 /* Undoes all the changes made to symbols in the current statement.
    This subroutine is made simpler due to the fact that attributes are
    never removed once added.  */
Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 168201)
+++ gfortran.h	(Arbeitskopie)
@@ -2563,8 +2563,6 @@  int gfc_get_sym_tree (const char *, gfc_namespace
 int gfc_get_ha_symbol (const char *, gfc_symbol **);
 int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
 
-int gfc_symbols_could_alias (gfc_symbol *, gfc_symbol *);
-
 void gfc_undo_symbols (void);
 void gfc_commit_symbols (void);
 void gfc_commit_symbol (gfc_symbol *);