From patchwork Wed Oct 20 20:03:35 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 46464 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 37A753857827 for ; Wed, 20 Oct 2021 20:04:15 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id E68393858409; Wed, 20 Oct 2021 20:03:43 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org E68393858409 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: EjnN4j9DCejRs5CwuG4PZDgy6AJmkIJhh37ern3+V2DqSzBAG4099mCQz/hly7Q8+CJVdXIFXI CU1h0MneYTMaxsuftBLZRaQeKJaXW113BXCnFCBNyALmNmyZb6GjrXgncUHiy9uKWhCmj3nKe8 rAD45QdRVKuHnv4rWYGxIoyij6IkWizvgERX+hkiDd8+nmW7ALPmLlkouetTv6qQju7LZoK011 GOUgRnUoc/XMyeypoFiXeBvoSxYnN5VMAty+w0YKxiuki9Z8tuAFYCe9v7ar4GWRoTAkFhLCXP b2WQlhw87DDl985+ZSkrMUk3 X-IronPort-AV: E=Sophos;i="5.87,167,1631606400"; d="scan'208";a="69907747" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 20 Oct 2021 12:03:43 -0800 IronPort-SDR: 93ugR4zUmAaS/HH04TonZhRCe84Ogp43/Tlgsxj54uzmYo0U0XYXLhamd6ITuwzZT5ZYniAtp1 W9s04JxiJII7j8eW2ekNiNVfdTkO7vrXkJ4b4GvHCNMP4VheYuZ3twislgm3tAN0/7JwneJJ6x OwqRg0hozpPHp0T5lParJMMk11QPJ2GnLwYoaMHzgRLtKYh/hS2O/yk6qCQTJz8DHorZOWP1nW o4i/JnXL04d11qFP0RsbqK3xrBGNN6ITiBiBtj93KeYMIXGmXIuOJtpfgKxfqw8vT173dp1qDq 6As= To: "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" From: Sandra Loosemore Subject: [PATCH] Fortran: Fixes and additional tests for shape/ubound/size [PR94070] Message-ID: Date: Wed, 20 Oct 2021 14:03:35 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-05.mgc.mentorg.com (147.34.90.205) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-9.1 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_STOCKGEN, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Tobias Burnus Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch started out as some additional testcases for the SHAPE, UBOUND, and SIZE intrinsic extensions for assumed-rank arrays added by TS29113; I realized a while ago that I had not added test coverage for polymorphic arguments. My guess that this was a likely trouble spot was correct as the new test cases did not work. :-( The one that was most concerning was an ICE when calling the SHAPE intrinsic with an assumed-rank class type argument, as reported in PR94070. (I think this ICE is similar to the one reported in PR102641 that Tobias thinks is a problem with the scalarizer.) In this case, SHAPE was calling a library function and trying to copy the array contents to a temporary, which is really stupid because SHAPE only needs to look at the descriptor and not the array contents. I thought we could handle this inline the same as UBOUND and LBOUND, by extending gfc_trans_intrinsic_bound, and avoid the library function entirely. Then, I found some other existing problems in gfc_trans_intrinsic_bound; the conditional it was building to test for the extent-zero special cases for LBOUND and UBOUND was completely wrong, and the compile-time test for the assumed-rank/assumed-size case was wrong too. So I ended up rewriting large parts of that function. I also fixed a bug in the SIZE intrinsic where it was not taking the class types into account. (SIZE is already being handled inline in a separate place, otherwise I might've merged it into gfc_trans_intrinsic_bound as well.) While I was at it I also added 3 more testcases for these functions to test for correct behavior with bind(c). All 6 new tests PASS now, and there are no other regressions. OK to commit? -Sandra commit c74d3f5ae059b74a552428d6f1602885ca239094 Author: Sandra Loosemore Date: Tue Oct 19 21:11:15 2021 -0700 Fortran: Fixes and additional tests for shape/ubound/size [PR94070] This patch reimplements the SHAPE intrinsic to be inlined similarly to LBOUND and UBOUND, instead of as a library call, to avoid an unnecessary array copy. Various bugs are also fixed. gcc/fortran/ PR fortran/94070 * expr.c (gfc_simplify_expr): Handle GFC_ISYM_SHAPE along with GFC_ISYM_LBOUND and GFC_ISYM_UBOUND. * trans-array.c (gfc_conv_ss_startstride): Likewise. (set_loop_bounds): Likewise. (gfc_tree_array_size): Handle class arrays. * trans-intrinsic.c (gfc_trans_intrinsic_bound): Extend to handle SHAPE. Correct logic for zero-size special cases and detecting assumed-rank arrays associated with an assumed-size argument. (gfc_conv_intrinsic_shape): Deleted. (gfc_conv_intrinsic_function): Handle GFC_ISYM_SHAPE like GFC_ISYM_LBOUND and GFC_ISYM_UBOUND. (gfc_add_intrinsic_ss_code): Likewise. (gfc_walk_intrinsic_bound): Likewise. gcc/testsuite/gfortran.dg/ PR fortran/94070 * c-interop/shape-bindc.f90: New test. * c-interop/shape-poly.f90: New test. * c-interop/size-bindc.f90: New test. * c-interop/size-poly.f90: New test. * c-interop/ubound-bindc.f90: New test. * c-interop/ubound-poly.f90: New test. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 66f24c6..b19d3a2 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -2205,7 +2205,8 @@ gfc_simplify_expr (gfc_expr *p, int type) (p->value.function.isym->id == GFC_ISYM_LBOUND || p->value.function.isym->id == GFC_ISYM_UBOUND || p->value.function.isym->id == GFC_ISYM_LCOBOUND - || p->value.function.isym->id == GFC_ISYM_UCOBOUND)) + || p->value.function.isym->id == GFC_ISYM_UCOBOUND + || p->value.function.isym->id == GFC_ISYM_SHAPE)) ap = ap->next; for ( ; ap; ap = ap->next) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f8c087e..323edcb 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4507,6 +4507,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_ISYM_UBOUND: case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: + case GFC_ISYM_SHAPE: case GFC_ISYM_THIS_IMAGE: loop->dimen = ss->dimen; goto done; @@ -4558,12 +4559,14 @@ done: /* Fall through to supply start and stride. */ case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: + /* This is the variant without DIM=... */ + gcc_assert (expr->value.function.actual->next->expr == NULL); + /* Fall through. */ + + case GFC_ISYM_SHAPE: { 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) { @@ -5350,10 +5353,13 @@ set_loop_bounds (gfc_loopinfo *loop) 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); + if (expr->value.function.isym->id == GFC_ISYM_SHAPE) + gcc_assert (expr->value.function.actual->expr->rank == -1); + else + 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; @@ -8054,9 +8060,18 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim) return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc)); } tree size, tmp, rank = NULL_TREE, cond = NULL_TREE; - symbol_attribute attr = gfc_expr_attr (expr); + symbol_attribute attr; gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); + + if (expr->ts.type == BT_CLASS) + { + attr = CLASS_DATA (expr->symtree->n.sym)->attr; + attr.pointer = attr.class_pointer; + } + else + attr = gfc_expr_attr (expr); + if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK) || !dim) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 2a2829c..21f74b5 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -2922,7 +2922,7 @@ gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg) /* TODO: bound intrinsic generates way too much unnecessary code. */ static void -gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) +gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op) { gfc_actual_arglist *arg; gfc_actual_arglist *arg2; @@ -2930,9 +2930,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond, cond1, cond3, cond4, size; + tree cond, cond1; tree ubound; tree lbound; + tree size; gfc_se argse; gfc_array_spec * as; bool assumed_rank_lb_one; @@ -2943,7 +2944,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (se->ss) { /* Create an implicit second parameter from the loop variable. */ - gcc_assert (!arg2->expr); + gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE); gcc_assert (se->loop->dimen == 1); gcc_assert (se->ss->info->expr == expr); gfc_advance_se_ss_chain (se); @@ -2979,12 +2980,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (INTEGER_CST_P (bound)) { + gcc_assert (op != GFC_ISYM_SHAPE); if (((!as || as->type != AS_ASSUMED_RANK) && wi::geu_p (wi::to_wide (bound), GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))) || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS)) gfc_error ("% argument of %s intrinsic at %L is not a valid " - "dimension index", upper ? "UBOUND" : "LBOUND", + "dimension index", + (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND", &expr->where); } @@ -3008,8 +3011,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) } } - /* Take care of the lbound shift for assumed-rank arrays, which are - nonallocatable and nonpointers. Those has a lbound of 1. */ + /* Take care of the lbound shift for assumed-rank arrays that are + nonallocatable and nonpointers. Those have a lbound of 1. */ assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK && ((arg->expr->ts.type != BT_CLASS && !arg->expr->symtree->n.sym->attr.allocatable @@ -3020,6 +3023,10 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (desc, bound); + size = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, ubound, lbound); + size = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, size, gfc_index_one_node); /* 13.14.53: Result value for LBOUND @@ -3042,106 +3049,82 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) not have size zero and has value zero if dimension DIM has size zero. */ - if (!upper && assumed_rank_lb_one) + if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one) se->expr = gfc_index_one_node; else if (as) { - tree stride = gfc_conv_descriptor_stride_get (desc, bound); - - cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, - stride, gfc_index_zero_node); - cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, - stride, gfc_index_zero_node); - - if (upper) + if (op == GFC_ISYM_UBOUND) { - tree cond5; - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond3, cond4); - cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - gfc_index_one_node, lbound); - cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - logical_type_node, cond4, cond5); - - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond5); - - if (assumed_rank_lb_one) + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + size, gfc_index_zero_node); + se->expr = fold_build3_loc (input_location, COND_EXPR, + gfc_array_index_type, cond, + (assumed_rank_lb_one ? size : ubound), + gfc_index_zero_node); + } + else if (op == GFC_ISYM_LBOUND) + { + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, + size, gfc_index_zero_node); + if (as->type == AS_ASSUMED_SIZE) { - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, gfc_index_one_node); + cond1 = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank - 1)); + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + logical_type_node, cond, cond1); } - else - tmp = ubound; - se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - tmp, gfc_index_zero_node); + lbound, gfc_index_one_node); } + else if (op == GFC_ISYM_SHAPE) + se->expr = size; else - { - if (as->type == AS_ASSUMED_SIZE) - cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, - bound, build_int_cst (TREE_TYPE (bound), - arg->expr->rank - 1)); - else - cond = logical_false_node; + gcc_unreachable (); - cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond3, cond4); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, + /* According to F2018 16.9.172, para 5, an assumed rank object, + argument associated with and assumed size array, has the ubound + of the final dimension set to -1 and UBOUND must return this. + Similarly for the SHAPE intrinsic. */ + if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one) + { + tree minus_one = build_int_cst (gfc_array_index_type, -1); + tree rank = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_rank (desc)); + rank = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, rank, minus_one); + + /* Fix the expression to stop it from becoming even more + complicated. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); + + /* Descriptors for assumed-size arrays have ubound = -1 + in the last dimension. */ + cond1 = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, ubound, minus_one); + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, bound, rank); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, cond, cond1); - se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, - lbound, gfc_index_one_node); + minus_one, se->expr); } } - else + else /* as is null; this is an old-fashioned 1-based array. */ { - if (upper) + if (op != GFC_ISYM_LBOUND) { - size = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, ubound, lbound); - se->expr = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, size, - gfc_index_one_node); se->expr = fold_build2_loc (input_location, MAX_EXPR, - gfc_array_index_type, se->expr, + gfc_array_index_type, size, gfc_index_zero_node); } else se->expr = gfc_index_one_node; } - /* According to F2018 16.9.172, para 5, an assumed rank object, argument - associated with and assumed size array, has the ubound of the final - dimension set to -1 and UBOUND must return this. */ - if (upper && as && as->type == AS_ASSUMED_RANK) - { - tree minus_one = build_int_cst (gfc_array_index_type, -1); - tree rank = fold_convert (gfc_array_index_type, - gfc_conv_descriptor_rank (desc)); - rank = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, rank, minus_one); - /* Fix the expression to stop it from becoming even more complicated. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, bound, rank); - cond1 = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, ubound, minus_one); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - logical_type_node, cond, cond1); - se->expr = fold_build3_loc (input_location, COND_EXPR, - gfc_array_index_type, cond, - se->expr, minus_one); - } type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); @@ -6691,85 +6674,6 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) } static void -gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr) -{ - gfc_actual_arglist *s, *k; - gfc_expr *e; - gfc_array_spec *as; - gfc_ss *ss; - symbol_attribute attr; - tree result_desc = se->expr; - - /* Remove the KIND argument, if present. */ - s = expr->value.function.actual; - k = s->next; - e = k->expr; - gfc_free_expr (e); - k->expr = NULL; - - gfc_conv_intrinsic_funcall (se, expr); - - /* According to F2018 16.9.172, para 5, an assumed rank entity, argument - associated with an assumed size array, has the ubound of the final - dimension set to -1 and SHAPE must return this. */ - - as = gfc_get_full_arrayspec_from_expr (s->expr); - if (!as || as->type != AS_ASSUMED_RANK) - return; - attr = gfc_expr_attr (s->expr); - ss = gfc_walk_expr (s->expr); - if (attr.pointer || attr.allocatable - || !ss || ss->info->type != GFC_SS_SECTION) - return; - if (se->expr) - result_desc = se->expr; - if (POINTER_TYPE_P (TREE_TYPE (result_desc))) - result_desc = build_fold_indirect_ref_loc (input_location, result_desc); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (result_desc))) - { - tree rank, minus_one, cond, ubound, tmp; - stmtblock_t block; - gfc_se ase; - - minus_one = build_int_cst (gfc_array_index_type, -1); - - /* Recover the descriptor for the array. */ - gfc_init_se (&ase, NULL); - ase.descriptor_only = 1; - gfc_conv_expr_lhs (&ase, ss->info->expr); - - /* Obtain rank-1 so that we can address both descriptors. */ - rank = gfc_conv_descriptor_rank (ase.expr); - rank = fold_convert (gfc_array_index_type, rank); - rank = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - rank, minus_one); - rank = gfc_evaluate_now (rank, &se->pre); - - /* The ubound for the final dimension will be tested for being -1. */ - ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank); - ubound = gfc_evaluate_now (ubound, &se->pre); - cond = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, - ubound, minus_one); - - /* Obtain the last element of the result from the library shape - intrinsic and set it to -1 if that is the value of ubound. */ - tmp = gfc_conv_array_data (result_desc); - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, rank, NULL, NULL); - - gfc_init_block (&block); - gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1)); - - cond = build3_v (COND_EXPR, cond, - gfc_finish_block (&block), - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&se->pre, cond); - } -} - -static void gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, bool arithmetic) { @@ -10178,10 +10082,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); break; - case GFC_ISYM_SHAPE: - gfc_conv_intrinsic_shape (se, expr); - break; - default: gfc_conv_intrinsic_funcall (se, expr); break; @@ -10575,7 +10475,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_LBOUND: - gfc_conv_intrinsic_bound (se, expr, 0); + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_LBOUND); break; case GFC_ISYM_LCOBOUND: @@ -10710,6 +10610,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_scale (se, expr); break; + case GFC_ISYM_SHAPE: + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_SHAPE); + break; + case GFC_ISYM_SIGN: gfc_conv_intrinsic_sign (se, expr); break; @@ -10756,7 +10660,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_UBOUND: - gfc_conv_intrinsic_bound (se, expr, 1); + gfc_conv_intrinsic_bound (se, expr, GFC_ISYM_UBOUND); break; case GFC_ISYM_UCOBOUND: @@ -11030,6 +10934,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) case GFC_ISYM_UCOBOUND: case GFC_ISYM_LCOBOUND: case GFC_ISYM_THIS_IMAGE: + case GFC_ISYM_SHAPE: break; default: @@ -11038,8 +10943,8 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) } -/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter - are expanded into code inside the scalarization loop. */ +/* The LBOUND, LCOBOUND, UBOUND, UCOBOUND, and SHAPE intrinsics with + one parameter are expanded into code inside the scalarization loop. */ static gfc_ss * gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) @@ -11048,7 +10953,8 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) gfc_add_class_array_ref (expr->value.function.actual->expr); /* The two argument version returns a scalar. */ - if (expr->value.function.actual->next->expr) + if (expr->value.function.isym->id != GFC_ISYM_SHAPE + && expr->value.function.actual->next->expr) return ss; return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC); @@ -11148,7 +11054,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr) case GFC_ISYM_PARITY: case GFC_ISYM_PRODUCT: case GFC_ISYM_SUM: - case GFC_ISYM_SHAPE: case GFC_ISYM_SPREAD: case GFC_ISYM_YN2: /* Ignore absent optional parameters. */ @@ -11198,6 +11103,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, case GFC_ISYM_UBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: + case GFC_ISYM_SHAPE: return gfc_walk_intrinsic_bound (ss, expr); case GFC_ISYM_TRANSFER: diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape-bindc.f90 new file mode 100644 index 0000000..d9e193a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/shape-bindc.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.1 SHAPE +! +! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010 +! is changed for an assumed-rank array that is associated with an +! assumed-size array; an assumed-size array has no shape, but in this +! case the result has a value equal to +! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ] +! with KIND omitted from SIZE if it was omitted from SHAPE. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + +contains + + subroutine testit (a) bind(c) + integer :: a(..) + + integer :: r + r = rank(a) + + block + integer :: s(r) + s = shape(a) + do i = 1, r + if (s(i) .ne. size(a,i)) stop 101 + end do + end block + + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape-poly.f90 new file mode 100644 index 0000000..e17ca88 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/shape-poly.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.1 SHAPE +! +! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010 +! is changed for an assumed-rank array that is associated with an +! assumed-size array; an assumed-size array has no shape, but in this +! case the result has a value equal to +! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ] +! with KIND omitted from SIZE if it was omitted from SHAPE. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is the polymorphic version of shape.f90. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + +contains + + subroutine testit (a) + use m + class(t) :: a(..) + + integer :: r + r = rank(a) + + block + integer :: s(r) + s = shape(a) + do i = 1, r + if (s(i) .ne. size(a,i)) stop 101 + end do + end block + + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/c-interop/size-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/size-bindc.f90 new file mode 100644 index 0000000..132ca50 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/size-bindc.f90 @@ -0,0 +1,106 @@ +! Reported as pr94070. +! { dg-do run } +! +! TS 29113 +! 6.4.2 SIZE +! +! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010 +! is changed in the following cases: +! +! (1) for an assumed-rank object that is associated with an assumed-size +! array, the result has the value −1 if DIM is present and equal to the +! rank of ARRAY, and a negative value that is equal to +! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] ) +! if DIM is not present; +! +! (2) for an assumed-rank object that is associated with a scalar, the +! result has the value 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a, r, sizes) bind(c) + integer :: a(..) + integer :: r + integer :: sizes(r) + + integer :: totalsize, thissize + totalsize = 1 + + if (r .ne. rank(a)) stop 101 + + do i = 1, r + thissize = size (a, i) + print *, 'got size ', thissize, ' expected ', sizes(i) + if (thissize .ne. sizes(i)) stop 102 + totalsize = totalsize * thissize + end do + + if (size(a) .ne. totalsize) stop 103 + end subroutine + + subroutine test0 (a) bind(c) + integer :: a(..) + + if (size (a) .ne. 1) stop 103 + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + integer :: sizes(1) + sizes(1) = -1 + call testit (a, 1, sizes) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + integer :: sizes(3) + sizes(1) = u1 - l1 + 1 + sizes(2) = u2 - l2 + 1 + sizes(3) = -1 + + call testit (a, 3, sizes) + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/c-interop/size-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/size-poly.f90 new file mode 100644 index 0000000..2241ab8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/size-poly.f90 @@ -0,0 +1,118 @@ +! Reported as pr94070. +! { dg-do run } +! +! TS 29113 +! 6.4.2 SIZE +! +! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010 +! is changed in the following cases: +! +! (1) for an assumed-rank object that is associated with an assumed-size +! array, the result has the value −1 if DIM is present and equal to the +! rank of ARRAY, and a negative value that is equal to +! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] ) +! if DIM is not present; +! +! (2) for an assumed-rank object that is associated with a scalar, the +! result has the value 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is the polymorphic version of size.f90. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + type(t) :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + call test0 (x) + call test0 (x1(1)) + +contains + + subroutine testit (a, r, sizes) + use m + class(t) :: a(..) + integer :: r + integer :: sizes(r) + + integer :: totalsize, thissize + totalsize = 1 + + if (r .ne. rank(a)) stop 101 + + do i = 1, r + thissize = size (a, i) + print *, 'got size ', thissize, ' expected ', sizes(i) + if (thissize .ne. sizes(i)) stop 102 + totalsize = totalsize * thissize + end do + + if (size(a) .ne. totalsize) stop 103 + end subroutine + + subroutine test0 (a) + use m + class(t) :: a(..) + + if (size (a) .ne. 1) stop 103 + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + integer :: sizes(1) + sizes(1) = -1 + call testit (a, 1, sizes) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + integer :: sizes(3) + sizes(1) = u1 - l1 + 1 + sizes(2) = u2 - l2 + 1 + sizes(3) = -1 + + call testit (a, 3, sizes) + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/c-interop/ubound-bindc.f90 b/gcc/testsuite/gfortran.dg/c-interop/ubound-bindc.f90 new file mode 100644 index 0000000..e771836 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/ubound-bindc.f90 @@ -0,0 +1,129 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.3 UBOUND +! +! The description of the intrinsic function UBOUND in ISO/IEC +! 1539-1:2010 is changed for an assumed-rank object that is associated +! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY), +! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with +! KIND omitted from LBOUND if it was omitted from UBOUND. +! +! NOTE 6.2 +! If LBOUND or UBOUND is invoked for an assumed-rank object that is +! associated with a scalar and DIM is absent, the result is a zero-sized +! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object +! that is associated with a scalar if DIM is present because the rank of +! a scalar is zero and DIM must be ≥ 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call testit2(x1, shape(x1)) + call test1 (y1) + call testit2(y1, shape(y1)) + p1 => x1 + call testit2(p1, shape(p1)) + call testit2p(p1, lbound(p1), shape(p1)) + call test1 (p1) + p1(77:) => x1 + call testit2p(p1, [77], shape(p1)) + allocate (a1(5)) + call testit2(a1, shape(a1)) + call testit2a(a1, lbound(a1), shape(a1)) + call test1 (a1) + deallocate(a1) + allocate (a1(-38:5)) + call test1 (a1) + call testit2(a1, shape(a1)) + call testit2a(a1, [-38], shape(a1)) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test some scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a) bind(c) + integer :: a(..) + integer :: r + r = rank(a) + if (any (lbound (a) .ne. 1)) stop 101 + if (ubound (a, r) .ne. -1) stop 102 + end subroutine + + subroutine testit2(a, shape) bind(c) + integer :: a(..) + integer :: shape(:) + if (rank(a) /= size(shape)) stop 111 + if (any (lbound(a) /= 1)) stop 112 + if (any (ubound(a) /= shape)) stop 113 + end subroutine + + subroutine testit2a(a,lbound2, shape2) bind(c) + integer, allocatable :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 121 + if (any (lbound(a) /= lbound2)) stop 122 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123 + if (any (shape(a) /= shape2)) stop 124 + if (sum (shape(a)) /= size(a)) stop 125 + end subroutine + + subroutine testit2p(a, lbound2, shape2) bind(c) + integer, pointer :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 131 + if (any (lbound(a) /= lbound2)) stop 132 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133 + if (any (shape(a) /= shape2)) stop 134 + if (sum (shape(a)) /= size(a)) stop 135 + end subroutine + + subroutine test0 (a) bind(c) + integer :: a(..) + if (rank (a) .ne. 0) stop 141 + if (size (lbound (a)) .ne. 0) stop 142 + if (size (ubound (a)) .ne. 0) stop 143 + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program diff --git a/gcc/testsuite/gfortran.dg/c-interop/ubound-poly.f90 b/gcc/testsuite/gfortran.dg/c-interop/ubound-poly.f90 new file mode 100644 index 0000000..333a253 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c-interop/ubound-poly.f90 @@ -0,0 +1,145 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.3 UBOUND +! +! The description of the intrinsic function UBOUND in ISO/IEC +! 1539-1:2010 is changed for an assumed-rank object that is associated +! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY), +! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with +! KIND omitted from LBOUND if it was omitted from UBOUND. +! +! NOTE 6.2 +! If LBOUND or UBOUND is invoked for an assumed-rank object that is +! associated with a scalar and DIM is absent, the result is a zero-sized +! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object +! that is associated with a scalar if DIM is present because the rank of +! a scalar is zero and DIM must be ≥ 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is like ubound.f90, but using polymorphic arrays instead of integer +! arrays. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + type(t) :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call testit2(x1, shape(x1)) + call test1 (y1) + call testit2(y1, shape(y1)) + p1 => x1 + call testit2(p1, shape(p1)) + call testit2p(p1, lbound(p1), shape(p1)) + call test1 (p1) + p1(77:) => x1 + call testit2p(p1, [77], shape(p1)) + allocate (a1(5)) + call testit2(a1, shape(a1)) + call testit2a(a1, lbound(a1), shape(a1)) + call test1 (a1) + deallocate(a1) + allocate (a1(-38:5)) + call test1 (a1) + call testit2(a1, shape(a1)) + call testit2a(a1, [-38], shape(a1)) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test some scalars. + call test0 (x) + call test0 (x1(1)) + +contains + + subroutine testit (a) + use m + class(t) :: a(..) + integer :: r + r = rank(a) + if (any (lbound (a) .ne. 1)) stop 101 + if (ubound (a, r) .ne. -1) stop 102 + end subroutine + + subroutine testit2(a, shape) + use m + class(t) :: a(..) + integer :: shape(:) + if (rank(a) /= size(shape)) stop 111 + if (any (lbound(a) /= 1)) stop 112 + if (any (ubound(a) /= shape)) stop 113 + end subroutine + + subroutine testit2a(a,lbound2, shape2) + use m + class(t), allocatable :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 121 + if (any (lbound(a) /= lbound2)) stop 122 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123 + if (any (shape(a) /= shape2)) stop 124 + if (sum (shape(a)) /= size(a)) stop 125 + end subroutine + + subroutine testit2p(a, lbound2, shape2) + use m + class(t), pointer :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 131 + if (any (lbound(a) /= lbound2)) stop 132 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133 + if (any (shape(a) /= shape2)) stop 134 + if (sum (shape(a)) /= size(a)) stop 135 + end subroutine + + subroutine test0 (a) + use m + class(t) :: a(..) + if (rank (a) .ne. 0) stop 141 + if (size (lbound (a)) .ne. 0) stop 142 + if (size (ubound (a)) .ne. 0) stop 143 + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program