From patchwork Mon Mar 28 16:31:09 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 602515 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 3qYfYq0Jwxz9s5Q for ; Tue, 29 Mar 2016 03:31:41 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=UX0aZndZ; 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:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=IwkQDiVBjYRx9+Pc AVrS4Rix2BkuwozwUkVrfyWcfnEQX+FOWS/IBwuePBcMo4OLl2o2lG11fRBg5OtK EQu1/7mDx7QVya9E7ybnlAthYnYS8ZyorlQzysXD/BrcoNWgBhE8fLNE+LbkVLO0 U+CI5E/lkf1fl8J5bvCyS9jC7rU= 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:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=bTWKtLWwvAGNANypwbV6Tb QRr5k=; b=UX0aZndZ41BxIBAeTdJGh5hNgnwT3bcAVlYmYmCW9+RJp9uD0CFkap C69++83uq8v6/WvVBFZJNK4B7iRqkMORE1NKSGGT60syACsP+fJKnknjFP68NL1S RnyAT3PCWf7SE9TnjKlOrNMZ0HXk76TYCbtgfK08o4jYmDcU0MjeM= Received: (qmail 11821 invoked by alias); 28 Mar 2016 16:31:27 -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 11801 invoked by uid 89); 28 Mar 2016 16:31:26 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.8 required=5.0 tests=BAYES_00, FREEMAIL_FROM, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=no version=3.3.2 spammy=valeryweberhotmailcom, valeryweber@hotmail.com, H*MI:sk:wYha3MX, H*f:sk:wYha3MX X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 28 Mar 2016 16:31:16 +0000 Received: from vepi2 ([88.77.160.134]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0LswqM-1ZjQpx0F2o-012bzb; Mon, 28 Mar 2016 18:31:11 +0200 Date: Mon, 28 Mar 2016 18:31:09 +0200 From: Andre Vehreschild To: Paul Richard Thomas Cc: "fortran@gcc.gnu.org" , gcc patches Subject: Re: [Patch, Fortran, pr70397, gcc-5, v1] [5/6 Regression] ice while allocating ultimate polymorphic Message-ID: <20160328183109.28048105@vepi2> In-Reply-To: References: <20160327184918.2cf9352b@nb-priv.private> <20160327185343.2ef4fcdf@nb-priv.private> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:zkT7ojMn8EI=:z3HC48CWz3b2NtvViEQzME EQf1aRhWW1aIIimxxnq1WQqZXH4d32uJb68f3Xnepe9W3zECt5JywM2wBjCYXtZFdsikGcZ14 Xmqoxz4Mryh6WKBeu0NX45T4yAy6Bu3WRb/sYnh3CeEEb3WHItQbrJwAajo9JW//r5OeU121s KEoPUV7yxV/gRZKJ2Hbmvrz4xYXsvqdKm5fXbNGowNJtfDwfH6vmHjga9P8rSS6808hLavo8b OCiUjcT6NNedO710/+56azfFZYoAQ2D7j0QOImz9iMFStbbI/jBapdUEKU+uGK1AH019z8Usi SoEvlz2lpBzU6ovFJVwbKWS14IL6mlWxsfEEuBNPcta14fgzsrIwUPmuDGzei3ybG7fmhaMfu 0a5mbPVtP3b1Rtp9BUKLbqQ9r9lag5lgWgc5x9+cGtzNpt+EBJhSfeGvB0DeGQe+GqPQsLJsO i/muWQOgGg05mhpwOFA51NgucExeDETjQS/Kil7i6ap/VKYIAsHyTgzXMKkEqwz19n7AD1/y8 kwLt55c/8WmigHgkI8GGW+qWK8rc3DMCGvIFlagPaL9wL6xrgxl2Vi0I6FvpslnGsro8zVG/s dCF5/4J9wFMO3aG4hZg0MuRGgqCUY3SHABvMwH4BhMsm1yhgaP++kfCCeBLVECRIu/8CmbFP1 I4BK8hGn1bVkkA1FdqzxyuP4iP9vsjV3FsSGtqsd0rzVXgaU4TTc5EAXHR+9Wgj4KeBv6/D3J uOxeSZmiJRh6Of0DSZbi/DGLutO63ShvuyVGj9f/dF8B8/0jJOHi9P/M/Nc= Hi Paul, thanks for the quick review. Committed to gcc-5-branch as r234507. The patch for trunk needs more polishing than expected. I hope to present it soon. Regards, Andre On Sun, 27 Mar 2016 19:19:11 +0200 Paul Richard Thomas wrote: > Hi Andre, > > The patch looks to be fine to me for both trunk and 5-branch. > > Thanks for the patch. > > Paul > > On 27 March 2016 at 18:53, Andre Vehreschild wrote: > > Hi all, > > > > and here is already the follow-up. In the initial patch a safe wasn't commenced > > before pulling the patch, which lead to a refactoring of the new functions node > > to be partial only. Sorry for the noise. > > > > - Andre > > > > Am Sun, 27 Mar 2016 18:49:18 +0200 > > schrieb Andre Vehreschild : > > > >> Hi all, > >> > >> attached is a patch to fix an ICE on allocating an unlimited polymorphic > >> entity from a non-poly class or type without an length component. 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 ok on x86_64-linux-gnu/F23. (Might have some > >> line deltas, because my git is a bit older. Sorry, only have limited/slow > >> net-access currently.) > >> > >> The same patch should be adaptable to trunk. To come... > >> > >> Ok for 5-trunk? > >> > >> Regards, > >> Andre > > > > > > Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 234506) +++ gcc/fortran/ChangeLog (Arbeitskopie) @@ -1,3 +1,12 @@ +2016-03-28 Andre Vehreschild + + PR fortran/70397 + * trans-expr.c (gfc_class_len_or_zero_get): Add function to return a + constant zero tree, when the class to get the _len component from is + not unlimited polymorphic. + (gfc_copy_class_to_class): Use the new function. + * trans.h: Added interface of new function gfc_class_len_or_zero_get. + 2016-03-28 Alessandro Fanfarillo Backport from trunk. Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 234506) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -173,6 +173,24 @@ } +/* 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; + 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 +268,7 @@ #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD +#undef CLASS_LEN_FIELD #undef VTABLE_HASH_FIELD #undef VTABLE_SIZE_FIELD #undef VTABLE_EXTENDS_FIELD @@ -1070,7 +1089,7 @@ if (unlimited) { if (from_class_base != NULL_TREE) - from_len = gfc_class_len_get (from_class_base); + from_len = gfc_class_len_or_zero_get (from_class_base); else from_len = integer_zero_node; } Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 234506) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -356,6 +356,7 @@ 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. */ Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 234506) +++ gcc/testsuite/ChangeLog (Arbeitskopie) @@ -1,3 +1,9 @@ +2016-03-28 Andre Vehreschild + + PR fortran/70397 + * gfortran.dg/unlimited_polymorphic_25.f90: New test. + * gfortran.dg/unlimited_polymorphic_26.f90: New test. + 2016-03-28 Kirill Yukhin PR target/70406 Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 =================================================================== --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 (nicht existent) +++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_25.f90 (Arbeitskopie) @@ -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 + Index: gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 =================================================================== --- gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 (nicht existent) +++ gcc/testsuite/gfortran.dg/unlimited_polymorphic_26.f90 (Arbeitskopie) @@ -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 +