From patchwork Tue Jan 4 08:57:47 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 77419 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 9B4D0B70EF for ; Tue, 4 Jan 2011 19:58:02 +1100 (EST) Received: (qmail 12648 invoked by alias); 4 Jan 2011 08:57:59 -0000 Received: (qmail 12630 invoked by uid 22791); 4 Jan 2011 08:57:57 -0000 X-SWARE-Spam-Status: No, hits=4.1 required=5.0 tests=AWL, BAYES_00, KAM_STOCKTIP, RCVD_IN_DNSWL_NONE, RCVD_IN_JMF_BL, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from cc-smtpout3.netcologne.de (HELO cc-smtpout3.netcologne.de) (89.1.8.213) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 04 Jan 2011 08:57:51 +0000 Received: from cc-smtpin1.netcologne.de (cc-smtpin1.netcologne.de [89.1.8.201]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id DEBB512181; Tue, 4 Jan 2011 09:57:48 +0100 (CET) Received: from [192.168.0.197] (xdsl-78-35-134-207.netcologne.de [78.35.134.207]) by cc-smtpin1.netcologne.de (Postfix) with ESMTP id A26F011E77; Tue, 4 Jan 2011 09:57:47 +0100 (CET) Message-ID: <4D22E10B.7010803@netcologne.de> Date: Tue, 04 Jan 2011 09:57:47 +0100 From: Thomas Koenig User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.1.16) Gecko/20101125 SUSE/3.0.11 Thunderbird/3.0.11 MIME-Version: 1.0 To: "fortran@gcc.gnu.org" CC: gcc-patches Subject: [patch, fortran] Fix PR 45777 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 *);