From patchwork Tue Jun 26 17:12:19 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 167431 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 6C87CB6FF5 for ; Wed, 27 Jun 2012 03:13:05 +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=1341335585; 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=TGFDO+o dLcUcHXBP8Zy3J3by1/I=; b=AGPrAAkqyjh4uSx16OprldtUkiq/gNOi7wLWg0e EJY8w5fQ15Qj5GO0jhnvpHWoJ44iafWNt3PW3ZGM5A7gnKcztPlqnYO1nUcKpKLs M0h+0KJZ4f0dnYuftJYJV6sc4xercFInewC8/5chEbbY/yqNUzBARmGokYgmaOic 40Io= 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=VylEiMXjEHgJYBQ4ZuPnVKq+CDKnv+S8s9yVAPXcoaf0O8cgtsXMag+QpnLeFK V/PF7CiKjNbGsrWQdUb+JUtkXovc90/1MtsRCXMcZsiTGarFXfIWOEsUgj420Mww xcv8L7ItECn0I/FKrRr44UmTl0qudX23qtLa1CO0mn3QE=; Received: (qmail 4092 invoked by alias); 26 Jun 2012 17:12:54 -0000 Received: (qmail 4065 invoked by uid 22791); 26 Jun 2012 17:12:47 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_VP 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; Tue, 26 Jun 2012 17:12:28 +0000 Received: from [192.168.178.22] (port-92-204-53-225.dynamic.qsc.de [92.204.53.225]) by mx01.qsc.de (Postfix) with ESMTP id 6B17A3E1FC; Tue, 26 Jun 2012 19:12:21 +0200 (CEST) Message-ID: <4FE9ED73.5050807@net-b.de> Date: Tue, 26 Jun 2012 19:12:19 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:13.0) Gecko/20120614 Thunderbird/13.0.1 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] CLASS handling for assumed-rank arrays 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 This patch assumes that the basic assumed-rank support is included, http://gcc.gnu.org/ml/fortran/2012-06/msg00144.html The attached patch implements the support of passing non-assumed-rank type/class arrays to assumed-rank class/type dummy arguments (type was working before). And passing assumed-rank class arrays to assumed-rank class arrays. It does not support passing assumed-rank class arrays to type arrays. The problem with the latter is that gfortran uses the TYPE_SIZE_UNIT to access the array elements, which imlies a copy in/copy out. For arguments with descriptor, a better choice would be to use the stride multiplier. (Catch: The current descriptor doesn't have one.) As the scalarizer doesn't work for assumed-rank arrays, the copy-in/copy-out fails at run time. (See also http://j3-fortran.org/pipermail/j3/2012-June/005438.html for the fun with pointer association when passing a CLASS with TARGET to a TYPE with TARGET.) Additionally, I think that this patch makes gfortran the second front end (after Ada), which uses a range for the assignment: I do not iterate through for dim, but use a.dim[1:rank] = b.dim[1:rank] in the assignment. The reason that I have to do a component wise assignment is that the class container directly contains the descriptor as a component - not as pointer. Thus, the descriptors can have different ranks... Build and regtested on x86-64-linux. OK for the trunk? Tobias 2012-06-26 Tobias Burnus PR fortran/48820 * class.c (gfc_build_class_symbol): Regard assumed-rank arrays as having GFC_MAX_DIMENSIONS. * trans-array.c (gfc_get_descriptor_dimension): New function, which returns the descriptor. (gfc_conv_descriptor_dimension): Use it. * trans-array.h (gfc_get_descriptor_dimension): New prototype. * trans-expr.c (class_array_data_assign): New static function. (gfc_conv_derived_to_class, gfc_conv_class_to_class): Use it. 2012-06-26 Tobias Burnus PR fortran/48820 * gfortran.dg/assumed_rank_7.f90: New. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index c71aa4a..479014e 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -219,7 +219,7 @@ gfc_add_component_ref (gfc_expr *e, const char *name) void gfc_add_class_array_ref (gfc_expr *e) { - int rank = CLASS_DATA (e)->as->rank; + int rank = CLASS_DATA (e)->as->rank; gfc_array_spec *as = CLASS_DATA (e)->as; gfc_ref *ref = NULL; gfc_add_component_ref (e, "_data"); @@ -497,6 +497,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; + int rank; if (as && *as && (*as)->type == AS_ASSUMED_SIZE) { @@ -517,11 +518,12 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, return SUCCESS; /* Determine the name of the encapsulating type. */ + rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) - sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank); else if ((*as)) - sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank); + sprintf (name, "__class_%s_%d_%d", tname, rank, (*as)->corank); else if (attr->pointer) sprintf (name, "__class_%s_p", tname); else if (attr->allocatable) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f135af1..36db6ac 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -247,12 +247,11 @@ gfc_conv_descriptor_dtype (tree desc) desc, field, NULL_TREE); } -static tree -gfc_conv_descriptor_dimension (tree desc, tree dim) + +tree +gfc_get_descriptor_dimension (tree desc) { - tree field; - tree type; - tree tmp; + tree type, field; type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); @@ -262,10 +261,19 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) && TREE_CODE (TREE_TYPE (field)) == ARRAY_TYPE && TREE_CODE (TREE_TYPE (TREE_TYPE (field))) == RECORD_TYPE); - tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), - desc, field, NULL_TREE); - tmp = gfc_build_array_ref (tmp, dim, NULL); - return tmp; + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + + +static tree +gfc_conv_descriptor_dimension (tree desc, tree dim) +{ + tree tmp; + + tmp = gfc_get_descriptor_dimension (desc); + + return gfc_build_array_ref (tmp, dim, NULL); } diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 9bafb94..b7ab806 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -154,6 +154,7 @@ tree gfc_conv_descriptor_data_get (tree); tree gfc_conv_descriptor_data_addr (tree); tree gfc_conv_descriptor_offset_get (tree); tree gfc_conv_descriptor_dtype (tree); +tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); tree gfc_conv_descriptor_ubound_get (tree, tree); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7d1a6d4..82caadd 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -158,7 +158,34 @@ gfc_get_vptr_from_expr (tree expr) tmp = gfc_class_vptr_get (tmp); return tmp; } - + + +static void +class_array_data_assign (stmtblock_t *block, tree lhs_desc, tree rhs_desc, + bool lhs_type) +{ + tree tmp, tmp2, type; + + gfc_conv_descriptor_data_set (block, lhs_desc, + gfc_conv_descriptor_data_get (rhs_desc)); + gfc_conv_descriptor_offset_set (block, lhs_desc, + gfc_conv_descriptor_offset_get (rhs_desc)); + + gfc_add_modify (block, gfc_conv_descriptor_dtype (lhs_desc), + gfc_conv_descriptor_dtype (rhs_desc)); + + /* Assign the dimension as range-ref. */ + tmp = gfc_get_descriptor_dimension (lhs_desc); + tmp2 = gfc_get_descriptor_dimension (rhs_desc); + + type = lhs_type ? TREE_TYPE (tmp) : TREE_TYPE (tmp2); + tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + tmp2 = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp2, + gfc_index_zero_node, NULL_TREE, NULL_TREE); + gfc_add_modify (block, tmp, tmp2); +} + /* Takes a derived type expression and returns the address of a temporary class object of the 'declared' type. If vptr is not NULL, this is @@ -222,7 +249,12 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { parmse->ss = ss; gfc_conv_expr_descriptor (parmse, e, ss); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + + if (e->rank != class_ts.u.derived->components->as->rank) + class_array_data_assign (&parmse->pre, ctree, parmse->expr, + TREE_TYPE (parmse->expr)); + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); } } @@ -273,13 +305,23 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, /* Set the data. */ ctree = gfc_class_data_get (var); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + class_array_data_assign (&parmse->pre, ctree, parmse->expr, false); + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); /* Return the data component, except in the case of scalarized array references, where nullification of the cannot occur and so there is no need. */ if (!elemental && full_array) - gfc_add_modify (&parmse->post, parmse->expr, ctree); + { + if (class_ts.u.derived->components->as + && e->rank != class_ts.u.derived->components->as->rank) + class_array_data_assign (&parmse->post, parmse->expr, ctree, true); + else + gfc_add_modify (&parmse->post, parmse->expr, ctree); + } /* Set the vptr. */ ctree = gfc_class_vptr_get (var); --- /dev/null 2012-06-26 07:11:42.215802679 +0200 +++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_7.f90 2012-06-26 17:46:53.000000000 +0200 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! PR fortran/48820 +! +! Handle type/class for assumed-rank arrays +! +implicit none +type t + integer :: i +end type + +class(T), allocatable :: ac(:,:) +type(T), allocatable :: at(:,:) +integer :: i + +allocate(ac(2:3,2:4)) +allocate(at(2:3,2:4)) + +i = 1 +call foo(ac) +call foo(at) +call bar(ac) +call bar(at) +if (i /= 12) call abort() + +contains + subroutine bar(x) + type(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort() + if (size(x) /= 6) call abort() + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort() + i = i + 1 + call foo(x) + call bar2(x) + end subroutine + subroutine bar2(x) + type(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort() + if (size(x) /= 6) call abort() + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort() + i = i + 1 + end subroutine + subroutine foo(x) + class(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort() + if (size(x) /= 6) call abort() + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort() + i = i + 1 + call foo2(x) +! call bar2(x) ! Passing a CLASS to a TYPE does not yet work + end subroutine + subroutine foo2(x) + class(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) call abort() + if (size(x) /= 6) call abort() + if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort() + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) call abort() + i = i + 1 + end subroutine +end