From patchwork Mon Sep 17 12:00:28 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 184389 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 594F52C0087 for ; Mon, 17 Sep 2012 22:01:08 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1348488068; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=m4KOtbV Jd58BhUbHCa/4gs17rtg=; b=cO9EysXDlzOowDSLyTqWLY1VeuqeVf/8fNNfYkN R4BbLWrx1ztXKi2cvYNGsdZcvFlNhvBl4QPR6idmr0tNMVN9OjnSyDDgf0YwsG5d J33pNgj6cYrak3MpGtpesc9ZGI8RZMSkzAQ6jw0x47UlPhpFDd4uszAdQfeZoEQ3 zyUQ= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=km3hHFLffHemQDoF6mzOkPPVi/8xhaq1ItpGQkyIgkhVsh4KM7pG6gfsGwZo3/ 7uHaJKeAtR7eCISfy0B3obOmLCY1BbfnV9vUJe9vlcZ9IhlTCJOX6nUZUUGjIiZY hL1E2syjsJ7KUe2RrWj1ias6PUPOqGTnJyRiFmD7LJvQU=; Received: (qmail 29963 invoked by alias); 17 Sep 2012 12:01:03 -0000 Received: (qmail 29932 invoked by uid 22791); 17 Sep 2012 12:01:00 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 17 Sep 2012 12:00:42 +0000 Received: from [192.168.178.22] (port-92-204-67-8.dynamic.qsc.de [92.204.67.8]) by mx01.qsc.de (Postfix) with ESMTP id C3E323CBF7; Mon, 17 Sep 2012 14:00:30 +0200 (CEST) Message-ID: <505710DC.7080708@net-b.de> Date: Mon, 17 Sep 2012 14:00:28 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:15.0) Gecko/20120825 Thunderbird/15.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] PR54603 - fix structure constructors with proc-pointers 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 structure constructures with proc-pointer arguments were either leading to wrong results or to ICEs. I use now the same condition as in gfc_trans_pointer_assignment. Build and regtested on x86-64-linux. OK for the trunk? Tobias 2012-09-17 Tobias Burnus PR fortran/54603 * trans-expr.c (gfc_trans_subcomponent_assign): Handle proc-pointer components. 2012-09-17 Tobias Burnus PR fortran/54603 * gfortran.dg/structure_constructor_11.f90: New. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 84a4b34..98634c3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5506,11 +5506,11 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_start_block (&block); - if (cm->attr.pointer) + if (cm->attr.pointer || cm->attr.proc_pointer) { gfc_init_se (&se, NULL); /* Pointer component. */ - if (cm->attr.dimension) + if (cm->attr.dimension && !cm->attr.proc_pointer) { /* Array pointer. */ if (expr->expr_type == EXPR_NULL) @@ -5530,6 +5530,11 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) se.want_pointer = 1; gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); + + if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer + && expr->symtree->n.sym->attr.dummy) + se.expr = build_fold_indirect_ref_loc (input_location, se.expr); + gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest), se.expr)); gfc_add_block_to_block (&block, &se.post); --- /dev/null 2012-09-17 07:46:24.707708299 +0200 +++ gcc/gcc/testsuite/gfortran.dg/structure_constructor_11.f90 2012-09-17 12:11:02.000000000 +0200 @@ -0,0 +1,96 @@ +! { dg-do run} +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54603 +! +! Contributed by Kacper Kowalik +! +module foo + implicit none + + interface + subroutine cg_ext + implicit none + end subroutine cg_ext + end interface + + type :: ext_ptr + procedure(cg_ext), nopass, pointer :: init + procedure(cg_ext), nopass, pointer :: cleanup + end type ext_ptr + + type :: ext_ptr_array + type(ext_ptr) :: a + contains + procedure :: epa_init + end type ext_ptr_array + + type(ext_ptr_array) :: bar + +contains + subroutine epa_init(this, init, cleanup) + implicit none + class(ext_ptr_array), intent(inout) :: this + procedure(cg_ext), pointer, intent(in) :: init + procedure(cg_ext), pointer, intent(in) :: cleanup + + this%a = ext_ptr(null(), null()) ! Wrong code + this%a = ext_ptr(init, cleanup) ! Wrong code + + this%a%init => init ! OK + this%a%cleanup => cleanup ! OK + + this%a = ext_ptr(this%a%init,this%a%cleanup) ! ICE in fold_convert_loc + end subroutine epa_init + +end module foo + +program ala + use foo, only: bar + implicit none + integer :: count1, count2 + count1 = 0 + count2 = 0 + + call setme + call bar%a%cleanup() + call bar%a%init() + + ! They should be called once + if (count1 /= 23 .or. count2 /= 42) call abort () + +contains + + subroutine dummy1 + implicit none + !print *, 'dummy1' + count1 = 23 + end subroutine dummy1 + + subroutine dummy2 + implicit none + !print *, 'dummy2' + count2 = 42 + end subroutine dummy2 + + subroutine setme + use foo, only: bar, cg_ext + implicit none + procedure(cg_ext), pointer :: a_init, a_clean + + a_init => dummy1 + a_clean => dummy2 + call bar%epa_init(a_init, a_clean) + end subroutine setme + +end program ala + +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.1.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.init = \\*init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "this->_data->a.cleanup = \\*cleanup;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.init = this->_data->a.init;" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_ptr.\[0-9\]+.cleanup = this->_data->a.cleanup;" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } }