From patchwork Thu Jul 26 14:53:37 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 173449 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 0F5292C009F for ; Fri, 27 Jul 2012 00:56: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=1343919366; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:CC:Subject: References:In-Reply-To:Content-Type:Mailing-List:Precedence: List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender: Delivered-To; bh=U82T08C4GaZFbiCpW0S3W8o6ce0=; b=cMEPLTDoVo1udRv /NJHIP4cL2O18OTJYjYimarRlXZsTUx8uGJWgAFrWXo7+YlgKIud61pFd/ja5SXk VdJZ6FW30wypxLFFCrLDinydKLw6SVmmSu0VMQAA2dU/mdTn1j1+SMGU4Jo20x5H pYMh9isj/DM2bOCNClWOK54a71Jw= 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:Received:X-SFR-UUID:Message-ID:Date:From:User-Agent:MIME-Version:To:CC:Subject:References:In-Reply-To:Content-Type:X-IsSubscribed:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=XVOKa/Z4/e/S+Q5Mu26GkMd3z0WiSR8GgWCOm2WErhgr++5r98MVAflBkzVpz4 gb2cceYnCDoHx1FYgzSh8OnXANMvmj9wAENQar6olOJY+EIsENHUN4sz8JcalD07 xwq8mPnrPPhGDjm0GMJV2QXKUDtySfio+uS3vNeoKza8o=; Received: (qmail 975 invoked by alias); 26 Jul 2012 14:55:56 -0000 Received: (qmail 939 invoked by uid 22791); 26 Jul 2012 14:55:55 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, KHOP_THREADED, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from smtp25.services.sfr.fr (HELO smtp25.services.sfr.fr) (93.17.128.118) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 26 Jul 2012 14:55:39 +0000 Received: from filter.sfr.fr (localhost [127.0.0.1]) by msfrf2504.sfr.fr (SMTP Server) with ESMTP id 08F12700004A; Thu, 26 Jul 2012 16:55:38 +0200 (CEST) Received: from [192.168.1.58] (37.15.72.86.rev.sfr.net [86.72.15.37]) by msfrf2504.sfr.fr (SMTP Server) with ESMTP id 6423070000A1; Thu, 26 Jul 2012 16:55:37 +0200 (CEST) X-SFR-UUID: 20120726145537410.6423070000A1@msfrf2504.sfr.fr Message-ID: <501159F1.5060704@sfr.fr> Date: Thu, 26 Jul 2012 16:53:37 +0200 From: Mikael Morin User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:10.0.5) Gecko/20120709 Thunderbird/10.0.5 MIME-Version: 1.0 To: Tobias Burnus CC: gcc patches , gfortran Subject: Re: [Patch, Fortran] assumed-rank some bound intrinsics support, fix failures and improve diagnostcs References: <500930BC.1060801@net-b.de> <500A86BF.1060805@sfr.fr> <500A8DB8.4040904@net-b.de> In-Reply-To: <500A8DB8.4040904@net-b.de> X-IsSubscribed: yes 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 On 21/07/2012 13:08, Tobias Burnus wrote: > Only failing are: > lbound(x) / ubound(x) / shape(x) > Here is a draft for those. Lightly tested with print *, ... Mikael Index: trans-array.c =================================================================== --- trans-array.c (révision 189883) +++ trans-array.c (copie de travail) @@ -249,6 +249,20 @@ gfc_conv_descriptor_dtype (tree desc) tree +gfc_conv_descriptor_rank (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); + tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), + dtype, tmp); + return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); +} + + +tree gfc_get_descriptor_dimension (tree desc) { tree type, field; @@ -3794,6 +3808,40 @@ done: /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + { + gfc_expr *arg; + + /* This is the variant without DIM=... */ + gcc_assert (expr->value.function.actual->next->expr == NULL); + + arg = expr->value.function.actual->expr; + if (arg->rank == -1) + { + gfc_se se; + tree rank, tmp; + + /* The rank (hence the return value's shape) is unknown, + we have to retrieve it. */ + gfc_init_se (&se, NULL); + se.descriptor_only = 1; + gfc_conv_expr (&se, arg); + /* This is a bare variable, so there is no preliminary + or cleanup code. */ + gcc_assert (se.pre.head == NULL_TREE + && se.post.head == NULL_TREE); + rank = gfc_conv_descriptor_rank (se.expr); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, + rank), + gfc_index_one_node); + info->end[0] = gfc_evaluate_now (tmp, &loop->pre); + info->start[0] = gfc_index_zero_node; + info->stride[0] = gfc_index_one_node; + continue; + } + /* Otherwise fall through GFC_SS_FUNCTION. */ + } case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: @@ -4430,22 +4478,11 @@ set_loop_bounds (gfc_loopinfo *loop) continue; } - /* TODO: Pick the best bound if we have a choice between a - function and something else. */ - if (ss_type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } - /* Avoid using an allocatable lhs in an assignment, since there might be a reallocation coming. */ if (loopspec[n] && ss->is_alloc_lhs) continue; - if (ss_type != GFC_SS_SECTION) - continue; - if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first): @@ -4520,6 +4557,20 @@ set_loop_bounds (gfc_loopinfo *loop) gcc_assert (loop->to[n] == NULL_TREE); break; + case GFC_SS_INTRINSIC: + { + gfc_expr *expr = loopspec[n]->info->expr; + + /* The {l,u}bound of an assumed rank. */ + gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND + || expr->value.function.isym->id == GFC_ISYM_UBOUND) + && expr->value.function.actual->next->expr == NULL + && expr->value.function.actual->expr->rank == -1); + + loop->to[n] = info->end[dim]; + break; + } + default: gcc_unreachable (); } Index: trans-array.h =================================================================== --- trans-array.h (révision 189881) +++ trans-array.h (copie de travail) @@ -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_conv_descriptor_rank (tree); tree gfc_get_descriptor_dimension (tree); tree gfc_conv_descriptor_stride_get (tree, tree); tree gfc_conv_descriptor_lbound_get (tree, tree); Index: iresolve.c =================================================================== --- iresolve.c (révision 189881) +++ iresolve.c (copie de travail) @@ -134,9 +134,12 @@ resolve_bound (gfc_expr *f, gfc_expr *array, gfc_e if (dim == NULL) { f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) - : array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], coarray ? gfc_get_corank (array) + : array->rank); + } } f->value.function.name = xstrdup (name); @@ -2225,8 +2228,12 @@ gfc_resolve_shape (gfc_expr *f, gfc_expr *array, g f->ts.kind = gfc_default_integer_kind; f->rank = 1; - f->shape = gfc_get_shape (1); - mpz_init_set_ui (f->shape[0], array->rank); + if (array->rank != -1) + { + f->shape = gfc_get_shape (1); + mpz_init_set_ui (f->shape[0], array->rank); + } + f->value.function.name = gfc_get_string (PREFIX ("shape_%d"), f->ts.kind); } Index: trans-intrinsic.c =================================================================== --- trans-intrinsic.c (révision 189881) +++ trans-intrinsic.c (copie de travail) @@ -1315,20 +1315,6 @@ trans_num_images (gfc_se * se) } -static tree -get_rank_from_desc (tree desc) -{ - tree tmp; - tree dtype; - - dtype = gfc_conv_descriptor_dtype (desc); - tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK); - tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype), - dtype, tmp); - return fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp); -} - - static void gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr) { @@ -1345,7 +1331,7 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *exp gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); - se->expr = get_rank_from_desc (argse.expr); + se->expr = gfc_conv_descriptor_rank (argse.expr); } @@ -1434,7 +1420,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); if (as && as->type == AS_ASSUMED_RANK) - tmp = get_rank_from_desc (desc); + tmp = gfc_conv_descriptor_rank (desc); else tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, @@ -5895,7 +5881,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr_lhs (&arg1se, arg1->expr); if (arg1->expr->rank == -1) { - tmp = get_rank_from_desc (arg1se.expr); + tmp = gfc_conv_descriptor_rank (arg1se.expr); tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, gfc_index_one_node); } Index: simplify.c =================================================================== --- simplify.c (révision 189881) +++ simplify.c (copie de travail) @@ -5470,6 +5470,9 @@ gfc_simplify_shape (gfc_expr *source, gfc_expr *ki gfc_try t; int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind); + if (source->rank == -1) + return NULL; + result = gfc_get_array_expr (BT_INTEGER, k, &source->where); if (source->rank == 0)