From patchwork Tue Jan 4 08:57:47 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [fortran] Fix PR 45777 Date: Mon, 03 Jan 2011 22:57:47 -0000 From: Thomas Koenig X-Patchwork-Id: 77419 Message-Id: <4D22E10B.7010803@netcologne.de> To: "fortran@gcc.gnu.org" Cc: gcc-patches 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 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 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" } } 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 *);