From patchwork Sun Feb 23 11:35:43 2020 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 1242639 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-519945-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=fail (p=none dis=none) header.from=gmail.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.a=rsa-sha1 header.s=default header.b=QtfhiUrw; dkim=fail reason="signature verification failed" (2048-bit key; unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20161025 header.b=Pm1RGBiv; dkim-atps=neutral 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 48QNSF6BrTz9sRG for ; Sun, 23 Feb 2020 22:36:09 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:from:date:message-id:subject:to:content-type; q= dns; s=default; b=WfJQV8iuElxjKxMS5jGudTb/4XQ38tRpdezLGGUi5/8Q79 pUuVIV+IIlWlVVhcvYZ/PyxfKf5MZYIMQLBa/AHGKpeFAewUxhHueliLaAWIEqdc Ir4EIPLo7AmPoHDZREzbXBBgvnZT7McJPgMsSvmBVYqxxvc2VmAZtUGyhKetQ= 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 :mime-version:from:date:message-id:subject:to:content-type; s= default; bh=GqbkNYv7DApwLiswdcurPMTBRWk=; b=QtfhiUrwI17Bb/EZ3beu IdcINs+FNr3o63CKxyDf3dSxweoq0tKqM5etphEe6lDczKWxydIqgaAGWZZQfth3 z64ViLSiLarlbNjOx6aZR1t7I5/ok9KW9V2F8xiUBp9rA9lycdlEq7Q2XsYlJUM1 W9Z1DccRbgo7musl7rmvw1o= Received: (qmail 22595 invoked by alias); 23 Feb 2020 11:36:00 -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 22557 invoked by uid 89); 23 Feb 2020 11:35:59 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-14.5 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.1 spammy=contributed, sk:pault@g, sk:paultg, paultgccgnuorg X-HELO: mail-lj1-f172.google.com Received: from mail-lj1-f172.google.com (HELO mail-lj1-f172.google.com) (209.85.208.172) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 23 Feb 2020 11:35:58 +0000 Received: by mail-lj1-f172.google.com with SMTP id x7so6916195ljc.1; Sun, 23 Feb 2020 03:35:57 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=mime-version:from:date:message-id:subject:to; bh=LzEjWnUkVeKotlNALdwUaNeBK89CyLaOHdnjzAprSo0=; b=Pm1RGBivV0JlKzVi6jjuYjNhlRpErfNNzCvuMYsXiDflUvCPksQRPsfrigE61DBv2a pcm4GSg+5qfF2ZUOtvYNBSkjIF+WUjbjM2i9gkq86C2g8O4zO+jgu0DawOEAzevnEePt wlcgHo89hgOCam7uiGZdaSJNAsbeDxGyFL4TD+vIXfOFrmcoWicm7r/80OPn0ltEJ9Fk 1CgrB/nKtK9F2VVXzudfztW3/5BYDfZHx4wEYutYMB6COianNltxbmhZobSDBG97rgJV yGoILBgWhTPs/ilfLqhtFDh4mqiicGNdBmQ9uOYgF6NkY7kj6al5HrHolkoI62nRPtM8 R6kg== MIME-Version: 1.0 From: Paul Richard Thomas Date: Sun, 23 Feb 2020 11:35:43 +0000 Message-ID: Subject: [Patch, fortran] PR57710 - [OOP] [F08] _vptr not set for allocatable CLASS component inside BLOCK To: "fortran@gcc.gnu.org" , gcc-patches This patch is relatively trivial and represents my first foray into gitland. Thus far, it has been... well, "interesting" compared with svn. Class components of derived types are initialized by calls to trans-array.c(gfc_trans_deferred_array) from trans-decl.c(gfc_trans_deferred_vars). The components are nullified in trans-array.c(structure_alloc_comps). The 'same_type_as' intrinsic requires that nullified class components either point to the declared type vtable or, in the case of unlimited polymorphic components, the vptr should be null. See Note 16.28 in the F2018 standard. The attached patch implements that requirement. Regtested on FC31/x86_64 - OK for head? Paul 2020-02-23 Paul Thomas PR fortran/57710 * trans-array.c (structure_alloc_comps): When nullifying class components, the vptr must point to the declared type or, in the case of unlimited polymorphic components, it should be null. 2020-02-23 Paul Thomas PR fortran/57710 * gfortran.dg/same_type_as_3.f03 : New test. diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 66598161fd8..0449d281bf7 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -8827,7 +8827,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, cdesc = gfc_create_var (cdesc, "cdesc"); DECL_ARTIFICIAL (cdesc) = 1; - + gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc), gfc_get_dtype_rank_type (1, tmp)); gfc_conv_descriptor_lbound_set (&tmpblock, cdesc, @@ -8838,7 +8838,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_index_one_node); gfc_conv_descriptor_ubound_set (&tmpblock, cdesc, gfc_index_zero_node, ubound); - + if (attr->dimension) comp = gfc_conv_descriptor_data_get (comp); else @@ -9116,10 +9116,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, && (CLASS_DATA (c)->attr.allocatable || CLASS_DATA (c)->attr.class_pointer)) { + tree vptr_decl; + /* Allocatable CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); + vptr_decl = gfc_class_vptr_get (comp); + comp = gfc_class_data_get (comp); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp))) gfc_conv_descriptor_data_set (&fnblock, comp, @@ -9131,6 +9135,24 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } + + /* The dynamic type of a disassociated pointer or unallocated + allocatable variable is its declared type. An unlimited + polymorphic entity has no declared type. */ + if (!UNLIMITED_POLY (c)) + { + vtab = gfc_find_derived_vtab (c->ts.u.derived); + if (!vtab->backend_decl) + gfc_get_symbol_decl (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, vtab->backend_decl); + } + else + tmp = build_int_cst (TREE_TYPE (vptr_decl), 0); + + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, vptr_decl, tmp); + gfc_add_expr_to_block (&fnblock, tmp); + cmp_has_alloc_comps = false; } /* Coarrays need the component to be nulled before the api-call diff --git a/gcc/testsuite/gfortran.dg/same_type_as_3.f03 b/gcc/testsuite/gfortran.dg/same_type_as_3.f03 new file mode 100644 index 00000000000..3a81e749763 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/same_type_as_3.f03 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Test the fix for PR57710. +! +! Contributed by Tobias Burnus +! +module m + type t + end type t + type t2 + integer :: ii + class(t), allocatable :: x + end type t2 +contains + subroutine fini(x) + type(t) :: x + end subroutine fini +end module m + +use m +block + type(t) :: z + type(t2) :: y + y%ii = 123 + if (.not. same_type_as(y%x, z)) call abort () +end block +end