From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 116092 invoked by alias); 17 Oct 2018 08:35:12 -0000 Mailing-List: contact fortran-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Subscribe: List-Post: List-Help: , Sender: fortran-owner@gcc.gnu.org Received: (qmail 116023 invoked by uid 89); 17 Oct 2018 08:35:08 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-23.7 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_0,GIT_PATCH_1,GIT_PATCH_2,GIT_PATCH_3,KAM_LAZY_DOMAIN_SECURITY autolearn=ham version=3.3.2 spammy= X-HELO: outpost18.zedat.fu-berlin.de Received: from outpost18.zedat.fu-berlin.de (HELO outpost18.zedat.fu-berlin.de) (130.133.4.111) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 17 Oct 2018 08:35:06 +0000 Received: from relay1.zedat.fu-berlin.de ([130.133.4.67]) by outpost.zedat.fu-berlin.de (Exim 4.85) with esmtps (TLSv1.2:DHE-RSA-AES256-GCM-SHA384:256) (envelope-from ) id <1gChIG-000YH7-4P>; Wed, 17 Oct 2018 10:35:04 +0200 Received: from mx.physik.fu-berlin.de ([160.45.64.218]) by relay1.zedat.fu-berlin.de (Exim 4.85) with esmtps (TLSv1.2:DHE-RSA-AES128-SHA:128) (envelope-from ) id <1gChIG-003j9y-0m>; Wed, 17 Oct 2018 10:35:04 +0200 Received: from login1.physik.fu-berlin.de ([160.45.66.207]) by mx.physik.fu-berlin.de with esmtps (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.80) (envelope-from ) id 1gChIC-0002ne-PP; Wed, 17 Oct 2018 10:35:00 +0200 Received: from tburnus by login1.physik.fu-berlin.de with local (Exim 4.89 #2 (Debian)) id 1gChIC-0001qt-O4; Wed, 17 Oct 2018 10:35:00 +0200 Date: Wed, 17 Oct 2018 08:35:00 -0000 From: Tobias Burnus To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [Patch, Fortran] PR87625 - fix reallocate on assign with polymophic arrays Message-ID: <20181017083500.bpcd6blxqdf7fjwf@physik.fu-berlin.de> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="fus2c6ac4gsm2ftl" Content-Disposition: inline User-Agent: NeoMutt/20170113 (1.7.2) Sender: Tobias Burnus X-SW-Source: 2018-10/txt/msg00079.txt.bz2 --fus2c6ac4gsm2ftl Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 406 for some reasons, the two calls to gfc_is_reallocatable_lhs(expr1) differ, the first one is a simple "var" + full-array reference while the second one is "var->_data" + full-array reference. Neither was handled and, hence, using var = [ t(11), t(12) ] didn't do any memory allocation; the program then simply segfaulted on assignment. Build and regtested on x86-64-gnu-linux. OK for the trunk? Tobias --fus2c6ac4gsm2ftl Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="pr87625_realloc_on_assign.diff" Content-length: 2052 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index ea4cf8cd1b8..47fec131c78 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -9616,9 +9616,15 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) if (sym->ts.type == BT_CLASS && !sym->attr.associate_var && CLASS_DATA (sym)->attr.allocatable - && expr->ref && expr->ref->type == REF_COMPONENT - && strcmp (expr->ref->u.c.component->name, "_data") == 0 - && expr->ref->next == NULL) + && expr->ref + && ((expr->ref->type == REF_ARRAY && expr->ref->u.ar.type == AR_FULL + && expr->ref->next == NULL) + || (expr->ref->type == REF_COMPONENT + && strcmp (expr->ref->u.c.component->name, "_data") == 0 + && (expr->ref->next == NULL + || (expr->ref->next->type == REF_ARRAY + && expr->ref->next->u.ar.type == AR_FULL + && expr->ref->next->next == NULL))))) return true; /* An allocatable variable. */ diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_31.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_31.f90 new file mode 100644 index 00000000000..55096d179ba --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_31.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/87625 +! +! Ensure that "var" gets allocated. +! +! Contributed by Tobias Burnus +! +program test + implicit none + type t + integer :: i + end type t + class(t), allocatable :: var(:) + call poly_init() + print *, var(:)%i + if (lbound(var, 1) /= 1 .and. ubound(var, 1) /= 2) call abort() + if (var(1)%i /= 11 .or. var(2)%i /= 12) call abort() + call poly_init2() + !print *, var(:)%i + if (lbound(var, 1) /= 1 .and. ubound(var, 1) /= 3) call abort() + if (var(1)%i /= 11 .or. var(2)%i /= 12 .or. var(3)%i /= 13) call abort() +contains + subroutine poly_init() + !allocate(var(2)) + var = [t :: t(11), t(12)] + end subroutine poly_init + subroutine poly_init2() + var = [t :: t(11), t(12), t(13)] + end subroutine poly_init2 + end program test --fus2c6ac4gsm2ftl--