From patchwork Tue Mar 29 12:55:24 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 602890 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3qZ9kK2Y7Cz9s48 for ; Tue, 29 Mar 2016 23:55:52 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=JZ4Fi274; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:in-reply-to:references:mime-version :content-type; q=dns; s=default; b=xZ4QzbGBCFLTC0EPdm37tFPuICpwY ER11Y6I8FzSYdWW/F8SrPCYv+QnJZA/kKzwcDqjLFKchD59m1+K3tNEvEE1lS+Kp XdiiSCaEhievZqueM4ah979voNgRrxI34njSkjubmyzorUMiYASBLSsiRCASCQPH fknSg9t8qvbWlk= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:in-reply-to:references:mime-version :content-type; s=default; bh=8Tmwhob5C6RfLWF4Fpoi9lEnHX8=; b=JZ4 Fi274DXEehDR3ffpB5q0OxuHJqZxEWnl6lFf3HaSUj40oXE7ynQUDbpsIfwawV4R POZUDaqTtJMpHK55uo6Ilfmp2oqxFEcqUONHorXmOuK2lH8NeZ5rf+AZrK67IZlz uZrBl5Yi7pY0M5txuZ4HYcQwrtiUJA460PDZf0H0= Received: (qmail 78930 invoked by alias); 29 Mar 2016 12:55:41 -0000 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 Received: (qmail 77837 invoked by uid 89); 29 Mar 2016 12:55:40 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.2 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=valeryweberhotmailcom, valeryweber@hotmail.com, 365, 7, 3657 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Tue, 29 Mar 2016 12:55:30 +0000 Received: from vepi2 ([88.77.160.134]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0MT60g-1aKwKR2rhu-00SAjI; Tue, 29 Mar 2016 14:55:25 +0200 Date: Tue, 29 Mar 2016 14:55:24 +0200 From: Andre Vehreschild To: fortran@gcc.gnu.org, gcc-patches Subject: [Patch, Fortran, pr70397, v1] [5/6 Regression] ice while allocating ultimate polymorphic Message-ID: <20160329145524.42d070d4@vepi2> In-Reply-To: <8CC3461C-413F-400D-AD3C-341F5D20AE95@lps.ens.fr> References: <8CC3461C-413F-400D-AD3C-341F5D20AE95@lps.ens.fr> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:1hkla3GR1kE=:l0WuoLZie16IiNwqLcHpX+ P2L0+hlX+uPiFyvVXTKsgtkBnbUlLgxKf39ejb3JG4J6F7mOGoxydG+3eY6iS2x5ysQwYN2bh W7MuWUkxE4zFL8bIXhTubmRfryj6e7UjVWOhPzMjC/C39wyLZswMyU87Z7swl3rV5AiotIt5x /Kx74DwpRsRnru79SICipO07T8eEPWaH20kabUqsEz8RzS3W/w7fvhQPzbofAdCLgRyFEK6OP ao5mwzMYXkE+I6jk+EQQYuPpjWVBt+0yTYoMK23pg9CIemqj9UuCB2H58RT9DwG6WuT6MVss7 u1zdWs/idekuYNHm2xc2L1+qXQQtswakuMYlsJZFJd8I4IGXEYOLaEX7i9J9b93YwEGrMY6Pf epdBN5g/9qR9i3aE6pFVSItG/Kf9K0TuZ0Cqpo6FSnsgqgqyPHgcNgqtOMdyUD6n+4ygsKBQv y5cMMRAw4PGmbgR+oihyqjuS6LS9LdLxSgYFn6q6E/loqApQcEBbT2lHp1WG3EFX5sbx4ooAA n6DjHod2h2BrwG/njJU9mf4ymEe03ISml7fLRfoaLcGrX6CSrkCq3fk3fAhwL4Twqvh+7b0GC wLhoSUzCpwW9LvqhNUp1LY/c4cUWbKvcZncnAyW5XEhT69tb5Ds9NuLeGS8kKzLOwu47HrrPs Ee3g4+vJZOfao1UxiMvyjdu0B74tT1vNhAtRuDelTZ/IZLK57giyeug+buxl3D/HcT5PXEW00 4JTubOn/D8quYzQe7ZTHRK6Ea/CX7HwDezhdoGaULL92vF3udZa0q8h1vBU= Hi all, here is the trunk version of the patch for the regression reported in pr70397. Applying the gcc-5 patch to trunk lead to a regression, which the modified patch resolves now. The technique to solve the ice is the same as for gcc-5: > The routine gfc_copy_class_to_class() assumed that both the source > and destination object's type is unlimited polymorphic, but in this > case it is true for the destination only, which made gfortran look > for a non-existent _len component in the source object and therefore > ICE. This is fixed by the patch by adding a function to return either > the _len component, when it exists, or a constant zero node to init > the destination object's _len component with. Bootstrapped and regtested on x86_64-linux-gnu/F23. Ok for trunk? Regards, Andre PS: Yes, Paul, I know you accepted the patch for gcc-5 for trunk also, but I feel safer when the changes made get additional approval. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 4baadc8..8d039a6 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -173,6 +173,29 @@ gfc_class_len_get (tree decl) } +/* Try to get the _len component of a class. When the class is not unlimited + poly, i.e. no _len field exists, then return a zero node. */ + +tree +gfc_class_len_or_zero_get (tree decl) +{ + tree len; + /* For class arrays decl may be a temporary descriptor handle, the vptr is + then available through the saved descriptor. */ + if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl) + && GFC_DECL_SAVED_DESCRIPTOR (decl)) + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), + CLASS_LEN_FIELD); + return len != NULL_TREE ? fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (len), decl, len, + NULL_TREE) + : integer_zero_node; +} + + /* Get the specified FIELD from the VPTR. */ static tree @@ -250,6 +273,7 @@ gfc_vptr_size_get (tree vptr) #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD +#undef CLASS_LEN_FIELD #undef VTABLE_HASH_FIELD #undef VTABLE_SIZE_FIELD #undef VTABLE_EXTENDS_FIELD @@ -1120,7 +1144,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) if (unlimited) { if (from != NULL_TREE && unlimited) - from_len = gfc_class_len_get (from); + from_len = gfc_class_len_or_zero_get (from); else from_len = integer_zero_node; } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index add0cea..512615a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -365,6 +365,7 @@ tree gfc_class_set_static_fields (tree, tree, tree); tree gfc_class_data_get (tree); tree gfc_class_vptr_get (tree); tree gfc_class_len_get (tree); +tree gfc_class_len_or_zero_get (tree); gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *); /* Get an accessor to the class' vtab's * field, when a class handle is available. */ diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 new file mode 100644 index 0000000..d0b2a2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Test contributed by Valery Weber + +module mod + + TYPE, PUBLIC :: base_type + END TYPE base_type + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(base_type), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + type(base_type) :: a, b + call dict_put(t, a, b) + + if (.NOT. allocated(t%key)) call abort() + select type (x => t%key) + type is (base_type) + class default + call abort() + end select + deallocate(t%key) +end + diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 new file mode 100644 index 0000000..1300069 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Test contributed by Valery Weber + +module mod + + TYPE, PUBLIC :: dict_entry_type + CLASS( * ), ALLOCATABLE :: key + CLASS( * ), ALLOCATABLE :: val + END TYPE dict_entry_type + + +contains + + SUBROUTINE dict_put ( this, key, val ) + CLASS(dict_entry_type), INTENT(INOUT) :: this + CLASS(*), INTENT(IN) :: key, val + INTEGER :: istat + ALLOCATE( this%key, SOURCE=key, STAT=istat ) + ALLOCATE( this%val, SOURCE=val, STAT=istat ) + end SUBROUTINE dict_put +end module mod + +program test + use mod + type(dict_entry_type) :: t + call dict_put(t, "foo", 42) + + if (.NOT. allocated(t%key)) call abort() + select type (x => t%key) + type is (CHARACTER(*)) + if (x /= "foo") call abort() + class default + call abort() + end select + deallocate(t%key) + + if (.NOT. allocated(t%val)) call abort() + select type (x => t%val) + type is (INTEGER) + if (x /= 42) call abort() + class default + call abort() + end select + deallocate(t%val) +end +