From patchwork Sat Jul 27 19:51:24 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 262502 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client CN "localhost", Issuer "www.qmailtoaster.com" (not verified)) by ozlabs.org (Postfix) with ESMTPS id 542382C010B for ; Sun, 28 Jul 2013 05:51:49 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; q=dns; s=default; b=B1xf+RSWq2bHp9X8X /+WjPFEGxHjtM1F4pl/vyE2DBF4vPIANdSssS57gLAORqT2pgQQh96UHtrmi7qDh 1zsVhfI2EL5uREtSPJCfLsx1ZCAyYNkKPYRkqDM2DeoORFQG8Ei+I836BJueHKDp 8ejH+lmP/g9wNtcNO3mot/mS9o= 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 :message-id:date:from:mime-version:to:cc:subject:references :in-reply-to:content-type; s=default; bh=Suvql3IbuVdn7ZDGtf3WUhS iMME=; b=FStskg0Fk6Fxb4EjNUiGvpA0x5c95b6Yhu63p27I0z0J5dqAzmLcEir Hu31UkgYG6C1ZKkHQRVmPJtI46yVYSoteA+XAaPHo6pOjPyMY5Ar1x8Tznuh16UI fWWDGOtTEl4kgN+oz7sPnrVpXoTsbslmKaVnfRFP8oAJk95muh6w= Received: (qmail 2226 invoked by alias); 27 Jul 2013 19:51:36 -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 2203 invoked by uid 89); 27 Jul 2013 19:51:36 -0000 X-Spam-SWARE-Status: No, score=-0.7 required=5.0 tests=AWL, BAYES_50, KHOP_THREADED, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO, RDNS_NONE autolearn=no version=3.3.1 X-Spam-User: qpsmtpd, 3 recipients Received: from Unknown (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.84/v0.84-167-ge50287c) with ESMTP; Sat, 27 Jul 2013 19:51:34 +0000 Received: from archimedes.net-b.de (port-92-206-165-137.dynamic.qsc.de [92.206.165.137]) by mx02.qsc.de (Postfix) with ESMTP id B52A72489D; Sat, 27 Jul 2013 21:51:24 +0200 (CEST) Message-ID: <51F424BC.6080002@net-b.de> Date: Sat, 27 Jul 2013 21:51:24 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/20130620 Thunderbird/17.0.7 MIME-Version: 1.0 To: Janus Weil CC: gcc patches , gfortran Subject: Re: [Patch, Fortran] PR57530 (Part 2 of 3) Support TYPE => CLASS References: <51F1A31F.3040404@net-b.de> <51F39827.8020607@net-b.de> <51F3BAAF.8040005@net-b.de> <51F3D986.9050300@net-b.de> In-Reply-To: <51F3D986.9050300@net-b.de> X-Virus-Found: No Tobias Burnus wrote: > Giving up on the class.c version, would be the following change okay? > > + if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS > + && expr2->expr_type != EXPR_FUNCTION) > + { > + gfc_add_data_component (expr2); > + /* The following is required as gfc_add_data_component doesn't > + update ts.type if there is a tailing REF_ARRAY. */ > + expr2->ts.type = BT_DERIVED; > + } > > It still feels a bit like a hack - but it is definitely much cleaner > than my previous band aid. > Built and regtested on x86-64-gnu-linux. > OK? Attached is now the patch which does what I wrote above. OK? Tobias 2013-07-25 Tobias Burnus PR fortran/57530 * trans-expr.c (gfc_trans_class_assign): Handle CLASS array functions. (gfc_trans_pointer_assign): Ditto and support pointer assignment of a polymorphic var to a nonpolymorphic var. 2013-07-25 Tobias Burnus PR fortran/57530 * gfortran.dg/pointer_assign_8.f90: New. * gfortran.dg/pointer_assign_9.f90: New. * gfortran.dg/pointer_assign_10.f90: New. * gfortran.dg/pointer_assign_11.f90: New. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e0cdd49..ac2fdb0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1043,7 +1043,7 @@ assign_vptr: gfc_add_data_component (expr2); goto assign; } - else if (CLASS_DATA (expr2)->attr.dimension) + else if (CLASS_DATA (expr2)->attr.dimension && expr2->expr_type != EXPR_FUNCTION) { /* Insert an additional assignment which sets the '_vptr' field. */ lhs = gfc_copy_expr (expr1); @@ -1061,9 +1061,10 @@ assign_vptr: /* Do the actual CLASS assignment. */ if (expr2->ts.type == BT_CLASS - && !CLASS_DATA (expr2)->attr.dimension) + && !CLASS_DATA (expr2)->attr.dimension) op = EXEC_ASSIGN; - else + else if (expr2->expr_type != EXPR_FUNCTION || expr2->ts.type != BT_CLASS + || !CLASS_DATA (expr2)->attr.dimension) gfc_add_data_component (expr1); assign: @@ -6417,6 +6418,7 @@ gfc_trans_pointer_assign (gfc_code * code) tree gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) { + gfc_expr *expr1_vptr = NULL; gfc_se lse; gfc_se rse; stmtblock_t block; @@ -6437,6 +6518,15 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) if (!scalar) gfc_free_ss_chain (ss); + if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS + && expr2->expr_type != EXPR_FUNCTION) + { + gfc_add_data_component (expr2); + /* The following is required as gfc_add_data_component doesn't + update ts.type if there is a tailing REF_ARRAY. */ + expr2->ts.type = BT_DERIVED; + } + if (scalar) { /* Scalar pointers. */ @@ -6485,8 +6575,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) build_int_cst (gfc_charlen_type_node, 0)); } + if (expr1->ts.type == BT_DERIVED && expr2->ts.type == BT_CLASS) + rse.expr = gfc_class_data_get (rse.expr); + gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), rse.expr)); + fold_convert (TREE_TYPE (lse.expr), rse.expr)); gfc_add_block_to_block (&block, &rse.post); gfc_add_block_to_block (&block, &lse.post); @@ -6508,8 +6601,12 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) break; rank_remap = (remap && remap->u.ar.end[0]); + gfc_init_se (&lse, NULL); if (remap) lse.descriptor_only = 1; + if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS + && expr1->ts.type == BT_CLASS) + expr1_vptr = gfc_copy_expr (expr1); gfc_conv_expr_descriptor (&lse, expr1); strlen_lhs = lse.string_length; desc = lse.expr; @@ -6526,8 +6623,51 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_init_se (&rse, NULL); rse.direct_byref = 1; rse.byref_noassign = 1; - gfc_conv_expr_descriptor (&rse, expr2); - strlen_rhs = rse.string_length; + + if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) + { + gfc_conv_function_expr (&rse, expr2); + + if (expr1->ts.type != BT_CLASS) + rse.expr = gfc_class_data_get (rse.expr); + else + { + tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); + gfc_add_modify (&lse.pre, tmp, rse.expr); + + gfc_add_vptr_component (expr1_vptr); + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_expr (&rse, expr1_vptr); + gfc_add_modify (&lse.pre, rse.expr, + fold_convert (TREE_TYPE (rse.expr), + gfc_class_vptr_get (tmp))); + rse.expr = gfc_class_data_get (tmp); + } + } + else if (expr2->expr_type == EXPR_FUNCTION) + { + tree bound[GFC_MAX_DIMENSIONS]; + int i; + + for (i = 0; i < expr2->rank; i++) + bound[i] = NULL_TREE; + tmp = gfc_typenode_for_spec (&expr2->ts); + tmp = gfc_get_array_type_bounds (tmp, expr2->rank, 0, + bound, bound, 0, + GFC_ARRAY_POINTER_CONT, false); + tmp = gfc_create_var (tmp, "ptrtemp"); + lse.expr = tmp; + lse.direct_byref = 1; + gfc_conv_expr_descriptor (&lse, expr2); + strlen_rhs = lse.string_length; + rse.expr = tmp; + } + else + { + gfc_conv_expr_descriptor (&rse, expr2); + strlen_rhs = rse.string_length; + } } else if (expr2->expr_type == EXPR_VARIABLE) { @@ -6551,12 +6691,37 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp); } } + else if (expr2->expr_type == EXPR_FUNCTION && expr2->ts.type == BT_CLASS) + { + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_function_expr (&rse, expr2); + if (expr1->ts.type != BT_CLASS) + { + rse.expr = gfc_class_data_get (rse.expr); + gfc_add_modify (&lse.pre, desc, rse.expr); + } + else + { + tmp = gfc_create_var (TREE_TYPE (rse.expr), "ptrtemp"); + gfc_add_modify (&lse.pre, tmp, rse.expr); + + gfc_add_vptr_component (expr1_vptr); + gfc_init_se (&rse, NULL); + rse.want_pointer = 1; + gfc_conv_expr (&rse, expr1_vptr); + gfc_add_modify (&lse.pre, rse.expr, + fold_convert (TREE_TYPE (rse.expr), + gfc_class_vptr_get (tmp))); + rse.expr = gfc_class_data_get (tmp); + gfc_add_modify (&lse.pre, desc, rse.expr); + } + } else { /* Assign to a temporary descriptor and then copy that temporary to the pointer. */ tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp"); - lse.expr = tmp; lse.direct_byref = 1; gfc_conv_expr_descriptor (&lse, expr2); @@ -6564,6 +6729,9 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) gfc_add_modify (&lse.pre, desc, tmp); } + if (expr1_vptr) + gfc_free_expr (expr1_vptr); + gfc_add_block_to_block (&block, &lse.pre); if (rank_remap) gfc_add_block_to_block (&block, &rse.pre); --- /dev/null 2013-07-25 08:57:59.308780984 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_8.f90 2013-06-20 22:42:28.356836418 +0200 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => CLASS pointer assignment for variables +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + subroutine sub (tgt, tgt2) + class(t), target :: tgt, tgt2(:) + type(t), pointer :: ptr, ptr2(:), ptr3(:,:) + + if (tgt%ii /= 43) call abort() + if (size (tgt2) /= 3) call abort() + if (any (tgt2(:)%ii /= [11,22,33])) call abort() + + ptr => tgt ! TYPE => CLASS + ptr2 => tgt2 ! TYPE => CLASS + ptr3(-3:-3,1:3) => tgt2 ! TYPE => CLASS + + if (.not. associated(ptr)) call abort() + if (.not. associated(ptr2)) call abort() + if (.not. associated(ptr3)) call abort() + if (.not. associated(ptr,tgt)) call abort() + if (.not. associated(ptr2,tgt2)) call abort() + if (ptr%ii /= 43) call abort() + if (size (ptr2) /= 3) call abort() + if (size (ptr3) /= 3) call abort() + if (any (ptr2(:)%ii /= [11,22,33])) call abort() + if (any (shape (ptr3) /= [1,3])) call abort() + if (any (ptr3(-3,:)%ii /= [11,22,33])) call abort() + end subroutine sub +end module m + +use m +type(t), target :: x +type(t), target :: y(3) +x%ii = 43 +y(:)%ii = [11,22,33] +call sub(x,y) +end --- /dev/null 2013-07-25 08:57:59.308780984 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_9.f90 2013-07-25 12:52:22.811020919 +0200 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => CLASS pointer assignment for functions +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + function f1() + class(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + class(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + type(t), pointer :: p1, p2(:),p3(:,:) + p1 => f1() + if (p1%ii /= 123) call abort () + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) call abort () + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort () +end program test --- /dev/null 2013-07-25 08:57:59.308780984 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_10.f90 2013-07-25 23:40:34.033925340 +0200 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! TYPE => TYPE pointer assignment for functions +! +module m + implicit none + type t + integer :: ii = 55 + end type t +contains + function f1() + type(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + type(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + type(t), pointer :: p1, p2(:), p3(:,:) + p1 => f1() + if (p1%ii /= 123) call abort () + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) call abort () + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort () +end program test --- /dev/null 2013-07-25 08:57:59.308780984 +0200 +++ gcc/gcc/testsuite/gfortran.dg/pointer_assign_11.f90 2013-07-25 22:28:35.930346080 +0200 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! PR fortran/57530 +! +! +! CLASS => CLASS pointer assignment for function results +! +module m + implicit none + type t + integer :: ii = 55 + end type t + type, extends(t) :: t2 + end type t2 +contains + function f1() + class(t), pointer :: f1 + allocate (f1) + f1%ii = 123 + end function f1 + function f2() + class(t), pointer :: f2(:) + allocate (f2(3)) + f2(:)%ii = [-11,-22,-33] + end function f2 +end module m + +program test + use m + implicit none + class(t), pointer :: p1, p2(:), p3(:,:) + type(t) :: my_t + type(t2) :: my_t2 + + allocate (t2 :: p1, p2(1), p3(1,1)) + if (.not. same_type_as (p1, my_t2)) call abort() + if (.not. same_type_as (p2, my_t2)) call abort() + if (.not. same_type_as (p3, my_t2)) call abort() + + p1 => f1() + if (p1%ii /= 123) call abort () + if (.not. same_type_as (p1, my_t)) call abort() + + p2 => f2() + if (any (p2%ii /= [-11,-22,-33])) call abort () + if (.not. same_type_as (p2, my_t)) call abort() + + p3(2:2,1:3) => f2() + if (any (p3(2,:)%ii /= [-11,-22,-33])) call abort () + if (.not. same_type_as (p3, my_t)) call abort() +end program test