From patchwork Fri Jul 1 19:07:16 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 55644 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 070B5385EC45 for ; Fri, 1 Jul 2022 19:07:53 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp04.smtpout.orange.fr [80.12.242.126]) by sourceware.org (Postfix) with ESMTPS id 1D39538582AF for ; Fri, 1 Jul 2022 19:07:27 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 1D39538582AF Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=orange.fr Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=orange.fr Received: from [192.168.1.17] ([86.215.161.154]) by smtp.orange.fr with ESMTPA id 7Lz3o0SByIaWO7LzAovg7c; Fri, 01 Jul 2022 21:07:25 +0200 X-ME-Helo: [192.168.1.17] X-ME-Auth: MDU4MTIxYWM4YWI0ZGE4ZTUwZWZmNTExZmI2ZWZlMThkM2ZhYiE5OWRkOGM= X-ME-Date: Fri, 01 Jul 2022 21:07:25 +0200 X-ME-IP: 86.215.161.154 Message-ID: Date: Fri, 1 Jul 2022 21:07:16 +0200 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:91.0) Gecko/20100101 Thunderbird/91.10.0 From: Mikael Morin Subject: [RFC] fortran: restore array indexing for all descriptor arrays [PR102043] To: gfortran , gcc-patches Content-Language: en-US X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, FREEMAIL_FROM, GIT_PATCH_0, JMQ_SPF_NEUTRAL, KAM_DMARC_STATUS, KAM_SHORT, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H2, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hello, this is a followup to a patch (see the thread at [1]) committed for the gcc-12 release to use pointer arithmetic to index descriptor arrays. This patch restores the previous behavior (array indexing for all non-polymorphic arrays), and for that changes the array element that descriptors’ data pointers point to, to meet the middle-end expectations, that is array indexing never use negative indexes. So descriptors’ data pointers are made to point to the first element in memory order instead of the first element in descriptor indexing order (they can be different with negative strides). This is not a formal request for review yet, I would like to have a confirmation that some benefits make this patch worth pursuing further (and breaking the ABI). Especially, Richi reported in the thread [1] a regression with Spec 2017; if he (or someone else with access to spec) would be kind enough to try again with this patch, it would be appreciated. There are also a number of loop versioning tests which I have xfailed for now, without a better idea of what’s going on. With a couple more testsuite adjustments (included in the patch), these changes pass the fortran regression testsuite. I attach a patch with generated library code and one without. No ChangeLog for now, a gross outline of the changes follows. Feel free to comment, do we need this? Thanks for your time. gcc/fortran/ - revert [1] - change the way data pointer and offset are constructed in new descriptors - adjust data pointer when passing to a CFI descriptor and back - reconstruct data pointer and offset when reconstructing a descriptor from CFI descriptor gcc/testsuite/gfortran.dg/ - adjust original tree dump patterns - xfail loop versioning tests libgfortran/ - rebuild a pointer to the first element from the descriptor at the beginning of library functions - adjust io array walking code. [1] https://gcc.gnu.org/pipermail/fortran/2022-April/057763.html diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 05134952db4..dc638b5f0c9 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -172,7 +172,7 @@ static tree gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx) { tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM); - tmp = gfc_build_array_ref (tmp, idx, NULL_TREE, true); + tmp = gfc_build_array_ref (tmp, idx, NULL); tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx); gcc_assert (field != NULL_TREE); return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), @@ -424,7 +424,7 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) tmp = gfc_get_descriptor_dimension (desc); - return gfc_build_array_ref (tmp, dim, NULL_TREE, true); + return gfc_build_array_ref (tmp, dim, NULL); } @@ -3138,12 +3138,18 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_VECTOR: - /* Get the vector's descriptor and store it in SS. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_descriptor (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - info->descriptor = se.expr; + { + /* Get the vector's descriptor and store it in SS. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + gfc_add_block_to_block (&outer_loop->post, &se.post); + info->descriptor = se.expr; + tree offset = gfc_conv_array_offset (info->descriptor); + info->offset = gfc_evaluate_now (offset, &outer_loop->pre); + tree lbound = gfc_conv_array_lbound (info->descriptor, 0); + info->start[0] = gfc_evaluate_now (lbound, &outer_loop->pre); + } break; case GFC_SS_INTRINSIC: @@ -3509,32 +3515,44 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i, break; case DIMEN_VECTOR: - gcc_assert (info && se->loop); - gcc_assert (info->subscript[dim] - && info->subscript[dim]->info->type == GFC_SS_VECTOR); - desc = info->subscript[dim]->info->data.array.descriptor; - - /* Get a zero-based index into the vector. */ - index = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - se->loop->loopvar[i], se->loop->from[i]); + { + gcc_assert (info && se->loop); + gcc_assert (info->subscript[dim] + && info->subscript[dim]->info->type == GFC_SS_VECTOR); + gfc_array_info *vector_info = &info->subscript[dim]->info->data.array; + desc = vector_info->descriptor; + tree offset = vector_info->offset; + + /* Get a zero-based index into the vector. */ + index = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + se->loop->loopvar[i], se->loop->from[i]); - /* Multiply the index by the stride. */ - index = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - index, gfc_conv_array_stride (desc, 0)); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + index, vector_info->start[0]); - /* Read the vector to get an index into info->descriptor. */ - data = build_fold_indirect_ref_loc (input_location, - gfc_conv_array_data (desc)); - index = gfc_build_array_ref (data, index, NULL); - index = gfc_evaluate_now (index, &se->pre); - index = fold_convert (gfc_array_index_type, index); + /* Multiply the index by the stride. */ + index = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + index, gfc_conv_array_stride (desc, 0)); - /* Do any bounds checking on the final info->descriptor index. */ - index = trans_array_bound_check (se, ss, index, dim, &ar->where, - ar->as->type != AS_ASSUMED_SIZE - || dim < ar->dimen - 1); + index = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, + index, offset); + + /* Read the vector to get an index into info->descriptor. */ + data = build_fold_indirect_ref_loc (input_location, + gfc_conv_array_data (desc)); + index = gfc_build_array_ref (data, index, NULL); + index = gfc_evaluate_now (index, &se->pre); + index = fold_convert (gfc_array_index_type, index); + + /* Do any bounds checking on the final info->descriptor index. */ + index = trans_array_bound_check (se, ss, index, dim, &ar->where, + ar->as->type != AS_ASSUMED_SIZE + || dim < ar->dimen - 1); + } break; case DIMEN_RANGE: @@ -3708,8 +3726,7 @@ non_negative_strides_array_p (tree expr) /* Build a scalarized reference to an array. */ static void -gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, - bool tmp_array = false) +gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar) { gfc_array_info *info; tree decl = NULL_TREE; @@ -3759,10 +3776,7 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar, decl = info->descriptor; } - bool non_negative_stride = tmp_array - || non_negative_strides_array_p (info->descriptor); - se->expr = gfc_build_array_ref (base, index, decl, - non_negative_stride); + se->expr = gfc_build_array_ref (base, index, decl); } @@ -3772,7 +3786,7 @@ void gfc_conv_tmp_array_ref (gfc_se * se) { se->string_length = se->ss->info->string_length; - gfc_conv_scalarized_array_ref (se, NULL, true); + gfc_conv_scalarized_array_ref (se, NULL); gfc_advance_se_ss_chain (se); } @@ -3824,9 +3838,7 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr) tmp = gfc_conv_array_data (desc); tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_build_array_ref (tmp, offset, decl, - non_negative_strides_array_p (desc), - vptr); + tmp = gfc_build_array_ref (tmp, offset, decl, vptr); return tmp; } @@ -6909,7 +6921,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); - offset = gfc_index_zero_node; + offset = gfc_conv_descriptor_offset_get (dumdesc); + offset = gfc_evaluate_now (offset, &init); size = gfc_index_one_node; /* Evaluate the bounds of the array. */ @@ -6919,13 +6932,12 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, { /* Get the bounds of the actual parameter. */ dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]); - dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); } else { dubound = NULL_TREE; - dlbound = NULL_TREE; } + dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); lbound = GFC_TYPE_ARRAY_LBOUND (type, n); if (!INTEGER_CST_P (lbound)) @@ -6991,9 +7003,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, gfc_array_index_type, tmp, lbound); gfc_add_modify (&init, ubound, tmp); } - /* The offset of this dimension. offset = offset - lbound * stride. */ + /* The offset of this dimension. offset = offset - (lbound - dlbound) * stride. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + lbound, dlbound); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, - lbound, stride); + tmp, stride); offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, offset, tmp); @@ -7819,6 +7833,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) tree to; tree base; tree offset; + stmtblock_t loop_pre; + + gfc_init_block (&loop_pre); ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen; @@ -7836,13 +7853,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) generate unnecessary code to calculate stride. */ gcc_assert (ar->stride[n + ndim] == NULL); - gfc_conv_section_startstride (&loop.pre, ss, n + ndim); + gfc_conv_section_startstride (&loop_pre, ss, n + ndim); loop.from[n + loop.dimen] = info->start[n + ndim]; loop.to[n + loop.dimen] = info->end[n + ndim]; } gcc_assert (n == codim - 1); - evaluate_bound (&loop.pre, info->start, ar->start, + evaluate_bound (&loop_pre, info->start, ar->start, info->descriptor, n + ndim, true, ar->as->type == AS_DEFERRED); loop.from[n + loop.dimen] = info->start[n + ndim]; @@ -7932,7 +7949,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the span field. */ tmp = gfc_get_array_span (desc, expr); if (tmp) - gfc_conv_descriptor_span_set (&loop.pre, parm, tmp); + gfc_conv_descriptor_span_set (&loop_pre, parm, tmp); /* The following can be somewhat confusing. We have two descriptors, a new one and the original array. @@ -7958,16 +7975,23 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) } else dtype = gfc_get_dtype (parmtype); - gfc_add_modify (&loop.pre, tmp, dtype); + gfc_add_modify (&loop_pre, tmp, dtype); /* The 1st element in the section. */ - base = gfc_index_zero_node; + if (ndim == 0) + base = gfc_index_zero_node; + else + base = gfc_conv_array_offset (desc); /* The offset from the 1st element in the section. */ offset = gfc_index_zero_node; for (n = 0; n < ndim; n++) { + tree end = NULL_TREE; + tree start_offset = NULL_TREE; + tree base_offset = NULL_TREE; + stride = gfc_conv_array_stride (desc, n); /* Work out the 1st element in the section. */ @@ -7977,22 +8001,50 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gcc_assert (info->subscript[n] && info->subscript[n]->info->type == GFC_SS_SCALAR); start = info->subscript[n]->info->data.scalar.value; + + start_offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + start, stride); + base_offset = start_offset; } else { /* Evaluate and remember the start of the section. */ start = info->start[n]; - stride = gfc_evaluate_now (stride, &loop.pre); + end = info->end[n]; + stride = gfc_evaluate_now (stride, &loop_pre); + + start_offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + start, stride); + + if (end == NULL_TREE) + base_offset = start_offset; + else + { + tree end_offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + end, stride); + /* If the array is zero size, the upper bound is never reached, + so just use the lower bound. */ + tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + end, start); + tree final_stride = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + stride, info->stride[n]); + tree nonnegative_stride = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + final_stride, gfc_index_zero_node); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, gfc_array_index_type, + tmp, final_stride); + tree extent = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tree nonpositive_extent = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + extent, gfc_index_zero_node); + tree use_start_offset = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, boolean_type_node, + nonnegative_stride, nonpositive_extent); + base_offset = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, use_start_offset, + start_offset, end_offset); + } } - tmp = gfc_conv_array_lbound (desc, n); - tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), - start, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, stride); - base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), - base, tmp); - + base = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (base), + base, base_offset); if (info->ref && info->ref->u.ar.dimen_type[n] == DIMEN_ELEMENT) { @@ -8016,12 +8068,14 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) /* Set the new lower bound. */ from = loop.from[dim]; to = loop.to[dim]; + if (to == NULL_TREE) + to = gfc_index_zero_node; - gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_conv_descriptor_lbound_set (&loop_pre, parm, gfc_rank_cst[dim], from); /* Set the new upper bound. */ - gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_conv_descriptor_ubound_set (&loop_pre, parm, gfc_rank_cst[dim], to); /* Multiply the stride by the section stride to get the @@ -8035,8 +8089,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) offset = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (offset), offset, tmp); + tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start_offset), + start_offset, base_offset); + offset = fold_build2_loc (input_location, PLUS_EXPR, + TREE_TYPE (offset), offset, tmp); + /* Store the new stride. */ - gfc_conv_descriptor_stride_set (&loop.pre, parm, + gfc_conv_descriptor_stride_set (&loop_pre, parm, gfc_rank_cst[dim], stride); } @@ -8044,22 +8103,39 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) { from = loop.from[n]; to = loop.to[n]; - gfc_conv_descriptor_lbound_set (&loop.pre, parm, + gfc_conv_descriptor_lbound_set (&loop_pre, parm, gfc_rank_cst[n], from); if (n < loop.dimen + codim - 1) - gfc_conv_descriptor_ubound_set (&loop.pre, parm, + gfc_conv_descriptor_ubound_set (&loop_pre, parm, gfc_rank_cst[n], to); } if (se->data_not_needed) - gfc_conv_descriptor_data_set (&loop.pre, parm, + gfc_conv_descriptor_data_set (&loop_pre, parm, gfc_index_zero_node); else /* Point the data pointer at the 1st element in the section. */ - gfc_get_dataptr_offset (&loop.pre, parm, desc, base, + gfc_get_dataptr_offset (&loop_pre, parm, desc, base, subref_array_target, expr); - gfc_conv_descriptor_offset_set (&loop.pre, parm, offset); + gfc_conv_descriptor_offset_set (&loop_pre, parm, offset); + + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym->attr.dummy + && expr->symtree->n.sym->attr.optional) + { + stmtblock_t absent_block; + gfc_init_block (&absent_block); + gfc_conv_descriptor_data_set (&absent_block, parm, gfc_index_zero_node); + + tree present = gfc_conv_expr_present (expr->symtree->n.sym); + tree cond = fold_build3_loc (input_location, COND_EXPR, void_type_node, + present, gfc_finish_block (&loop_pre), + gfc_finish_block (&absent_block)); + gfc_add_expr_to_block (&loop.pre, cond); + } + else + gfc_add_expr_to_block (&loop.pre, gfc_finish_block (&loop_pre)); desc = parm; } diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 6493cc2f6b1..eeed5e9137c 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -6657,6 +6657,8 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, gfc_init_block (&block); tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc); tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE; + tree offset = NULL_TREE, data_offset = NULL_TREE; + tree old_gfc_data = NULL_TREE, do_copyin = NULL_TREE; bool do_copy_inout = false; /* When allocatable + intent out, free the cfi descriptor. */ @@ -6951,6 +6953,9 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, else rank = build_int_cst (signed_char_type_node, sym->as->rank); + old_gfc_data = gfc_create_var (pvoid_type_node, "old_gfc_data"); + gfc_add_modify (&block, old_gfc_data, null_pointer_node); + /* With bind(C), the standard requires that both Fortran callers and callees handle noncontiguous arrays passed to an dummy with 'contiguous' attribute and with character(len=*) + assumed-size/explicit-size arrays. @@ -6972,7 +6977,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, /* Is copy-in/out needed? */ /* do_copyin = rank != 0 && !assumed-size */ - tree cond_var = gfc_create_var (boolean_type_node, "do_copyin"); + tree cond_var = do_copyin = gfc_create_var (boolean_type_node, "do_copyin"); tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, rank, build_zero_cst (TREE_TYPE (rank))); /* dim[rank-1].extent != -1 -> assumed size*/ @@ -7131,6 +7136,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, We use gfc instead of cfi on the RHS as this might be a constant. */ tmp = fold_convert (gfc_array_index_type, gfc_conv_descriptor_elem_len (gfc_desc)); + + data_offset = gfc_create_var (size_type_node, "data_offset"); + gfc_add_modify (&block2, data_offset, build_int_cst (size_type_node, 0)); + if (!do_copy_inout) { /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len) @@ -7147,7 +7156,8 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp); /* Calculate offset + set lbound, ubound and stride. */ - gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node); + offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block2, offset, gfc_index_zero_node); if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable) for (int i = 0; i < sym->as->rank; ++i) { @@ -7207,7 +7217,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, } else { - /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */ + /* gfc->dim[i].stride = cfi->dim[i].sm / cfi->elem_len */ tmp = gfc_get_cfi_dim_sm (cfi, idx); tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, gfc_array_index_type, tmp, @@ -7220,13 +7230,63 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, gfc_conv_descriptor_stride_get (gfc_desc, idx), gfc_conv_descriptor_lbound_get (gfc_desc, idx)); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_offset_get (gfc_desc), tmp); - gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp); + offset, tmp); + gfc_add_modify (&loop_body, offset, tmp); + + if (!do_copy_inout) + { + /* data_offset += cfi->dim[i].sm < 0 ? (cfi->dim[i].extent - 1) * cfi->dim[i].sm : 0 */ + tree extent = gfc_get_cfi_dim_extent (cfi, idx); + tmp = fold_convert_loc (input_location, size_type_node, extent); + tmp = fold_build2_loc (input_location, MINUS_EXPR, size_type_node, + tmp, build_int_cst (size_type_node, 1)); + tree sm = gfc_get_cfi_dim_sm (cfi, idx); + tmp2 = fold_convert (size_type_node, sm); + + tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + tmp, tmp2); + + tree sm_negative = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + sm, build_int_cst (TREE_TYPE (sm), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, size_type_node, + sm_negative, tmp, build_int_cst (size_type_node, 0)); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, size_type_node, + data_offset, tmp); + + gfc_add_modify (&loop_body, data_offset, tmp); + } /* Generate loop. */ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), gfc_finish_block (&loop_body)); + + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) + { + tree gfc_data = gfc_conv_descriptor_data_get (gfc_desc); + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, + TREE_TYPE (gfc_data), gfc_data, + data_offset); + + /* gfc->data = gfc->data p+ data_offset. */ + gfc_conv_descriptor_data_set (&block2, gfc_desc, tmp); + + tmp = gfc_conv_descriptor_data_get (gfc_desc); + gfc_add_modify (&block2, old_gfc_data, fold_convert (pvoid_type_node, tmp)); + + /* gfc->offset -= data_offset / cfi->elem_len. */ + tree dat_off = fold_convert (gfc_array_index_type, data_offset); + tree elem_len = fold_convert (gfc_array_index_type, gfc_get_cfi_desc_elem_len (cfi)); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, dat_off, elem_len); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); + gfc_add_modify (&block2, offset, tmp); + } + + gfc_conv_descriptor_offset_set (&block2, gfc_desc, offset); + if (sym->attr.allocatable || sym->attr.pointer) { tmp = gfc_get_cfi_desc_base_addr (cfi), @@ -7239,6 +7299,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, else gfc_add_block_to_block (&block, &block2); + done: /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ if (sym->attr.optional) @@ -7359,10 +7420,7 @@ done: gfc_add_expr_to_block (&block2, call); /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */ - tree tmp2 = gfc_get_cfi_desc_base_addr (cfi); - tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - tmp2, fold_convert (TREE_TYPE (tmp2), data)); - tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2), + tmp = build3_v (COND_EXPR, do_copyin, gfc_finish_block (&block2), build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); goto done_finally; @@ -7391,6 +7449,9 @@ done: gfc_init_block (&block2); + data_offset = gfc_create_var (size_type_node, "data_offset"); + gfc_add_modify (&block2, data_offset, build_zero_cst (size_type_node)); + /* Loop: for (i = 0; i < rank; ++i). */ idx = gfc_create_var (TREE_TYPE (rank), "idx"); @@ -7412,11 +7473,42 @@ done: gfc_conv_descriptor_span_get (gfc_desc)); gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); + { + /* data_offset -= cfi->dim[i].sm < 0 ? (cfi->dim[i].extent - 1) * cfi->dim[i].sm : 0. */ + tree extent = gfc_get_cfi_dim_extent (cfi, idx); + tmp = fold_build2_loc (input_location, MINUS_EXPR, size_type_node, + fold_convert (size_type_node, extent), + build_one_cst (size_type_node)); + tree sm = fold_convert_loc (input_location, size_type_node, gfc_get_cfi_dim_sm (cfi, idx)); + tree dat_off = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + tmp, sm); + + tree negative_sm = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fold_convert (gfc_array_index_type, sm), + gfc_index_zero_node); + tree off = fold_build3_loc (input_location, COND_EXPR, size_type_node, + negative_sm, dat_off, build_zero_cst (size_type_node)); + + tmp = fold_build2_loc (input_location, MINUS_EXPR, size_type_node, + data_offset, off); + + gfc_add_modify (&loop_body, data_offset, tmp); + } + /* Generate loop. */ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), gfc_finish_block (&loop_body)); - /* if (gfc->data != NULL) { block2 }. */ + + { + /* Update pointer + array data data on exit. */ + tree cfi_base_addr = gfc_get_cfi_desc_base_addr (cfi); + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, TREE_TYPE (cfi_base_addr), + cfi_base_addr, data_offset); + gfc_add_modify (&block2, cfi_base_addr, tmp); + } + + /* if (cfi->base_addr != NULL) { block2 }. */ tmp = gfc_get_cfi_desc_base_addr (cfi), tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, null_pointer_node); diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 850007fd2e1..6c8fa16e723 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -2612,7 +2612,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, /* For BIND(C), a BT_CHARACTER is not an ARRAY_TYPE. */ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE) { - tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); + tmp = gfc_build_array_ref (tmp, start.expr, NULL); se->expr = gfc_build_addr_expr (type, tmp); } } @@ -5675,9 +5675,10 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) } else { - tmp = gfc_get_cfi_desc_base_addr (cfi); - tmp2 = gfc_conv_descriptor_data_get (gfc); - gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); + tree cfi_base_addr = gfc_get_cfi_desc_base_addr (cfi); + tree gfc_data = gfc_conv_descriptor_data_get (gfc); + gfc_add_modify (&block, cfi_base_addr, + fold_convert (TREE_TYPE (cfi_base_addr), gfc_data)); } /* Set elem_len if known - must be before the next if block. @@ -5803,6 +5804,14 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) if (e->rank != 0) { + tree cfi_base_addr = gfc_get_cfi_desc_base_addr (cfi); + tree gfc_data = gfc_conv_descriptor_data_get (gfc); + + tree data_idx = gfc_create_var (gfc_array_index_type, "data_idx"); + tree offset = gfc_conv_descriptor_offset_get (gfc); + + gfc_add_modify (&block, data_idx, offset); + /* Loop: for (i = 0; i < rank; ++i). */ tree idx = gfc_create_var (TREE_TYPE (rank), "idx"); /* Loop body. */ @@ -5828,11 +5837,29 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) gfc_conv_descriptor_span_get (gfc)); gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); + /* data_idx += gfc->dim[i].lbound * gfc->dim[i].stride. */ + tree lbound = gfc_conv_descriptor_lbound_get (gfc, idx); + tree stride = gfc_conv_descriptor_stride_get (gfc, idx); + + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, + lbound, stride); + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, + data_idx, tmp); + gfc_add_modify (&loop_body, data_idx, tmp); + /* Generate loop. */ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), gfc_finish_block (&loop_body)); + tree tmp = build_fold_indirect_ref_loc (input_location, gfc_data); + tree first_element = gfc_build_array_ref (tmp, data_idx, gfc); + tree addr_first_elem = gfc_build_addr_expr (NULL_TREE, first_element); + + tree addr = fold_convert (TREE_TYPE (cfi_base_addr), addr_first_elem); + + gfc_add_modify (&block2, cfi_base_addr, addr); + if (e->expr_type == EXPR_VARIABLE && e->ref && e->ref->u.ar.type == AR_FULL @@ -5888,6 +5915,11 @@ done: tmp = gfc_get_cfi_desc_base_addr (cfi); gfc_conv_descriptor_data_set (&block, gfc, tmp); + /* If at least one stride is negative gfc->data != cfi->base_addr, + and data_offset contains the offset between the two pointers in that case. */ + tree data_offset = gfc_create_var (size_type_node, "data_offset"); + gfc_add_modify (&block2, data_offset, build_int_cst (size_type_node, 0)); + if (fsym->attr.allocatable) { /* gfc->span = cfi->elem_len. */ @@ -5911,7 +5943,8 @@ done: gfc_conv_descriptor_span_set (&block2, gfc, tmp); /* Calculate offset + set lbound, ubound and stride. */ - gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node); + tree offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block2, offset, gfc_index_zero_node); /* Loop: for (i = 0; i < rank; ++i). */ tree idx = gfc_create_var (TREE_TYPE (rank), "idx"); /* Loop body. */ @@ -5929,7 +5962,7 @@ done: gfc_get_cfi_dim_extent (cfi, idx), tmp); gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp); - /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */ + /* gfc->dim[i].stride = cfi->dim[i].sm / cfi->elem_len */ tmp = gfc_get_cfi_dim_sm (cfi, idx); tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, gfc_array_index_type, tmp, @@ -5937,17 +5970,55 @@ done: gfc_get_cfi_desc_elem_len (cfi))); gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp); - /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */ + /* offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, gfc_conv_descriptor_stride_get (gfc, idx), gfc_conv_descriptor_lbound_get (gfc, idx)); tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_offset_get (gfc), tmp); - gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp); + offset, tmp); + gfc_add_modify (&loop_body, offset, tmp); + + /* data_offset += cfi->dim[i].sm < 0 ? (cfi->dim[i].extent - 1) * cfi->dim[i].sm : 0 */ + tree extent = gfc_get_cfi_dim_extent (cfi, idx); + tmp = fold_convert_loc (input_location, size_type_node, extent); + tmp = fold_build2_loc (input_location, MINUS_EXPR, size_type_node, + tmp, build_int_cst (size_type_node, 1)); + tree sm = gfc_get_cfi_dim_sm (cfi, idx); + tmp2 = fold_convert (size_type_node, sm); + + tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, + tmp, tmp2); + + tree sm_negative = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + sm, build_int_cst (TREE_TYPE (sm), 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, size_type_node, + sm_negative, tmp, build_int_cst (size_type_node, 0)); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, size_type_node, + data_offset, tmp); + + gfc_add_modify (&loop_body, data_offset, tmp); + /* Generate loop. */ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0), rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), gfc_finish_block (&loop_body)); + + tree dat_off = fold_convert (gfc_array_index_type, data_offset); + tree elem_len = fold_convert (gfc_array_index_type, gfc_get_cfi_desc_elem_len (cfi)); + tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, + gfc_array_index_type, dat_off, elem_len); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, offset, tmp); + gfc_add_modify (&block2, offset, tmp); + + gfc_conv_descriptor_offset_set (&block2, gfc, offset); + + tree cfi_base_addr = gfc_get_cfi_desc_base_addr (cfi); + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, + TREE_TYPE (cfi_base_addr), cfi_base_addr, + data_offset); + gfc_conv_descriptor_data_set (&block2, gfc, tmp); } if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length) diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index fd6d294147e..4d0737a4756 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1679,16 +1679,11 @@ class_has_len_component (gfc_symbol *sym) static void -copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) +copy_descriptor (stmtblock_t *block, tree dst, tree src) { - int n; - tree dim; tree tmp; tree tmp2; tree size; - tree offset; - - offset = gfc_index_zero_node; /* Use memcpy to copy the descriptor. The size is the minimum of the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */ @@ -1702,21 +1697,6 @@ copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) gfc_build_addr_expr (NULL_TREE, src), fold_convert (size_type_node, size)); gfc_add_expr_to_block (block, tmp); - - /* Set the offset correctly. */ - for (n = 0; n < rank; n++) - { - dim = gfc_rank_cst[n]; - tmp = gfc_conv_descriptor_lbound_get (src, dim); - tmp2 = gfc_conv_descriptor_stride_get (src, dim); - tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), - tmp, tmp2); - offset = fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE (offset), offset, tmp); - offset = gfc_evaluate_now (offset, block); - } - - gfc_conv_descriptor_offset_set (block, dst, offset); } @@ -1730,9 +1710,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) bool class_target; bool unlimited; tree desc; - tree offset; - tree dim; - int n; tree charlen; bool need_len_assign; bool whole_array = true; @@ -1848,7 +1825,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) attributes so the selector descriptor must be copied in and copied out. */ if (rank > 0) - copy_descriptor (&se.pre, desc, se.expr, rank); + copy_descriptor (&se.pre, desc, se.expr); else { tmp = gfc_conv_descriptor_data_get (se.expr); @@ -1877,7 +1854,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) || CLASS_DATA (sym)->attr.pointer))) { if (rank > 0) - copy_descriptor (&se.post, se.expr, desc, rank); + copy_descriptor (&se.post, se.expr, desc); else gfc_conv_descriptor_data_set (&se.post, se.expr, desc); @@ -2050,18 +2027,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Set the offset. */ desc = gfc_class_data_get (se.expr); - offset = gfc_index_zero_node; - for (n = 0; n < e->rank; n++) - { - dim = gfc_rank_cst[n]; - tmp = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_stride_get (desc, dim), - gfc_conv_descriptor_lbound_get (desc, dim)); - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp); - } if (need_len_assign) { if (e->symtree @@ -2089,7 +2054,6 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) /* Length assignment done, prevent adding it again below. */ need_len_assign = false; } - gfc_conv_descriptor_offset_set (&se.pre, desc, offset); } else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 912a206f2ed..6eba520e818 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -439,21 +439,15 @@ gfc_build_spanned_array_ref (tree base, tree offset, tree span) tmp = gfc_build_addr_expr (pvoid_type_node, base); tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); tmp = fold_convert (build_pointer_type (type), tmp); - if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) - || !TYPE_STRING_FLAG (type)) - tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = build_fold_indirect_ref_loc (input_location, tmp); return tmp; } -/* Build an ARRAY_REF with its natural type. - NON_NEGATIVE_OFFSET indicates if it’s true that OFFSET can’t be negative, - and thus that an ARRAY_REF can safely be generated. If it’s false, we - have to play it safe and use pointer arithmetic. */ +/* Build an ARRAY_REF with its natural type. */ tree -gfc_build_array_ref (tree base, tree offset, tree decl, - bool non_negative_offset, tree vptr) +gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) { tree type = TREE_TYPE (base); tree span = NULL_TREE; @@ -499,40 +493,10 @@ gfc_build_array_ref (tree base, tree offset, tree decl, pointer arithmetic. */ if (span != NULL_TREE) return gfc_build_spanned_array_ref (base, offset, span); - /* Else use a straightforward array reference if possible. */ - else if (non_negative_offset) + /* Otherwise use a straightforward array reference. */ + else return build4_loc (input_location, ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE); - /* Otherwise use pointer arithmetic. */ - else - { - gcc_assert (TREE_CODE (TREE_TYPE (base)) == ARRAY_TYPE); - tree min = NULL_TREE; - if (TYPE_DOMAIN (TREE_TYPE (base)) - && !integer_zerop (TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base))))) - min = TYPE_MIN_VALUE (TYPE_DOMAIN (TREE_TYPE (base))); - - tree zero_based_index - = min ? fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - fold_convert (gfc_array_index_type, offset), - fold_convert (gfc_array_index_type, min)) - : fold_convert (gfc_array_index_type, offset); - - tree elt_size = fold_convert (gfc_array_index_type, - TYPE_SIZE_UNIT (type)); - - tree offset_bytes = fold_build2_loc (input_location, MULT_EXPR, - gfc_array_index_type, - zero_based_index, elt_size); - - tree base_addr = gfc_build_addr_expr (pvoid_type_node, base); - - tree ptr = fold_build_pointer_plus_loc (input_location, base_addr, - offset_bytes); - return build1_loc (input_location, INDIRECT_REF, type, - fold_convert (build_pointer_type (type), ptr)); - } } diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 03d5288aad2..02b5b1b99ac 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -619,9 +619,7 @@ tree gfc_get_extern_function_decl (gfc_symbol *, tree gfc_build_addr_expr (tree, tree); /* Build an ARRAY_REF. */ -tree gfc_build_array_ref (tree, tree, tree, - bool non_negative_offset = false, - tree vptr = NULL_TREE); +tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE); /* Build an array ref using pointer arithmetic. */ tree gfc_build_spanned_array_ref (tree base, tree offset, tree span); diff --git a/gcc/testsuite/gfortran.dg/array_reference_3.f90 b/gcc/testsuite/gfortran.dg/array_reference_3.f90 index 85fa3317d98..d28cf932d62 100644 --- a/gcc/testsuite/gfortran.dg/array_reference_3.f90 +++ b/gcc/testsuite/gfortran.dg/array_reference_3.f90 @@ -35,7 +35,7 @@ contains call cases(x) if (any(x /= (/ 0, 10, 0 /))) stop 10 ! Assumed shape array are referenced with pointer arithmetic. - ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_x.\\d+ \\+ \\(sizetype\\) \\(\\(stride.\\d+ \\* 2 \\+ offset.\\d+\\) \\* 4\\)\\) = 10;" 1 "original" } } + ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_x.\\d+\\)\\\[stride.\\d+ \\* 2 \\+ offset.\\d+\\\] = 10;" 1 "original" } } end subroutine check_assumed_shape_elem subroutine casss(assumed_shape_y) integer :: assumed_shape_y(:) @@ -46,7 +46,7 @@ contains call casss(y) if (any(y /= 11)) stop 11 ! Assumed shape array are referenced with pointer arithmetic. - ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_y.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 11;" 1 "original" } } + ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_y.\\d+\\)\\\[S.\\d+ \\* D.\\d+ \\+ D.\\d+\\\] = 11;" 1 "original" } } end subroutine check_assumed_shape_scalarized subroutine check_descriptor_dim integer, allocatable :: descriptor(:) @@ -152,7 +152,7 @@ contains call cares(x) if (any(x /= (/ 0, 0, 22, 0, 0, 0 /))) stop 22 ! Assumed rank arrays are referenced with pointer arithmetic. - ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) __tmp_INTEGER_4_rank_1\\.data \\+ \\(sizetype\\) \\(\\(__tmp_INTEGER_4_rank_1\\.offset \\+ __tmp_INTEGER_4_rank_1\\.dim\\\[0\\\]\\.stride \\* 3\\) \\* 4\\)\\) = 22;" 1 "original" } } + ! { dg-final { scan-tree-dump-times "\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __tmp_INTEGER_4_rank_1\\.data\\)\\\[__tmp_INTEGER_4_rank_1\\.offset \\+ __tmp_INTEGER_4_rank_1\\.dim\\\[0\\\]\\.stride \\* 3\\\] = 22;" 1 "original" } } end subroutine check_assumed_rank_elem subroutine carss(assumed_rank_y) integer :: assumed_rank_y(..) @@ -166,7 +166,7 @@ contains call carss(y) if (any(y /= 23)) stop 23 ! Assumed rank arrays are referenced with pointer arithmetic. - ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) D.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 23;" 1 "original" } } + ! { dg-final { scan-tree-dump-times "\\(\\*D.\\d+\\)\\\[S.\\d+ \\* D.\\d+ \\+ D.\\d+\\\] = 23;" 1 "original" } } end subroutine check_assumed_rank_scalarized subroutine casces(assumed_shape_cont_x) integer, dimension(:), contiguous :: assumed_shape_cont_x diff --git a/gcc/testsuite/gfortran.dg/assign_10.f90 b/gcc/testsuite/gfortran.dg/assign_10.f90 index c207f9e5e2b..b16fcb25f0c 100644 --- a/gcc/testsuite/gfortran.dg/assign_10.f90 +++ b/gcc/testsuite/gfortran.dg/assign_10.f90 @@ -19,9 +19,9 @@ if (any(p8 .ne. q8)) STOP 2 end ! Whichever is the default length for array indices will yield -! parm 18 times, because a temporary is not necessary. The other -! cases will all yield a temporary, so that atmp appears 18 times. +! parm 22 times, because a temporary is not necessary. The other +! cases will all yield a temporary, so that atmp appears 22 times. ! Note that it is the kind conversion that generates the temp. ! -! { dg-final { scan-tree-dump-times "parm" 20 "original" } } -! { dg-final { scan-tree-dump-times "atmp" 20 "original" } } +! { dg-final { scan-tree-dump-times "parm" 22 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 22 "original" } } diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 8dd7e8fb088..7d6ae269113 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -40,7 +40,7 @@ end ! { dg-final { scan-tree-dump "cfi...attribute = 2;" "original" } } ! { dg-final { scan-tree-dump "cfi...base_addr = parm.0.data;" "original" } } ! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } } -! { dg-final { scan-tree-dump "idx.2 = 0;" "original" } } +! { dg-final { scan-tree-dump "idx.. = 0;" "original" } } ! { dg-final { scan-tree-dump "if \\(idx.. <= 1\\) goto L..;" "original" } } ! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].lower_bound = 0;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 index 7b1149aaa45..09ffe78ed34 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 @@ -15,9 +15,9 @@ subroutine sub(xxx, yyy) ptr4 = c_loc (yyy(5:)) end ! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+;" 1 "original" } } -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(D.\[0-9\]+ \\* 16\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[\[^\\\]\]+\\\];" 2 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[\[^\\\]\]+ \\* 5\[^\\\]\]+\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[\[^\\\]\]+\\\];" 2 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[\[^\\\]\]+ \\* 5\[^\\\]\]+\\\];" 1 "original" } } ! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_10.f90 b/gcc/testsuite/gfortran.dg/finalize_10.f90 index c0e4170fd66..96b96e7f385 100644 --- a/gcc/testsuite/gfortran.dg/finalize_10.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_10.f90 @@ -31,7 +31,7 @@ end subroutine foo ! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } } ! FINALIZE TYPE: -! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) aa.\[0-9\]+;" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[\[^\\\]\]+\\\];" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&parm.\[0-9\]+, 0, 0\\);" 1 "original" } } ! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } } ! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&desc.\[0-9\]+, 0, 0\\);" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 index 58f4ce84a2c..cbd6ae92e33 100644 --- a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-2.f90 @@ -10,6 +10,7 @@ type(t), allocatable :: b(:) !$acc update host(b(::2)) ! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 } ! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 } +! { dg-warning {'b\.offset' is used uninitialized} {} { target *-*-* } .-3 } !$acc update host(b(1)%A(::3,::4)) end diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_1.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_1.f90 index e80f8920d00..bb755cc07b0 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_1.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_1.f90 @@ -23,6 +23,6 @@ subroutine f3(x, limit, step) end do end subroutine f3 -! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" } } -! { dg-final { scan-tree-dump-times {want to version containing loop} 3 "lversion" } } -! { dg-final { scan-tree-dump-times {versioned this loop} 3 "lversion" } } +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 3 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {versioned this loop} 3 "lversion" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_10.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_10.f90 index 3d921d6c993..2eb9cf1d753 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_10.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_10.f90 @@ -26,6 +26,6 @@ subroutine f4(x, i) end do end subroutine f4 -! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" } } -! { dg-final { scan-tree-dump-times {want to version} 4 "lversion" } } -! { dg-final { scan-tree-dump-times {versioned} 4 "lversion" } } +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {want to version} 4 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {versioned} 4 "lversion" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_2.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_2.f90 index 522ef912947..c703ebbdf43 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_2.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_2.f90 @@ -34,6 +34,6 @@ subroutine f3(x, n, step) end do end subroutine f3 -! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" } } +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 1 "lversion" { xfail *-*-* } } } ! { dg-final { scan-tree-dump-not {want to version} "lversion" } } ! { dg-final { scan-tree-dump-not {versioned} "lversion" } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_4.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_4.f90 index 2fc4d12c9d1..9b960cefb08 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_4.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_4.f90 @@ -89,7 +89,7 @@ subroutine f9(x, n, limit, step) end do end subroutine f9 -! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 3 "lversion" } } -! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" } } -! { dg-final { scan-tree-dump-times {hoisting check} 9 "lversion" } } -! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" } } +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 3 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {hoisting check} 9 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_6.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_6.f90 index ffd85798ea2..a13453220d9 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_6.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_6.f90 @@ -89,5 +89,5 @@ subroutine f9(x, limit, step) end do end subroutine f9 -! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" { xfail { ! lp64 } } } } -! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" { xfail { ! lp64 } } } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 9 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {versioned this loop} 9 "lversion" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_8.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_8.f90 index 193479935f4..6a6297cf324 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_8.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_8.f90 @@ -9,5 +9,5 @@ function f(x, index, n) f = sum(x(index(:))) end function f -! { dg-final { scan-tree-dump-times {want to version containing loop} 1 "lversion" } } -! { dg-final { scan-tree-dump-times {versioned this loop} 1 "lversion" } } +! { dg-final { scan-tree-dump-times {want to version containing loop} 1 "lversion" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times {versioned this loop} 1 "lversion" { xfail *-*-* } } } diff --git a/gcc/testsuite/gfortran.dg/loop_versioning_9.f90 b/gcc/testsuite/gfortran.dg/loop_versioning_9.f90 index 7a0fd55eaca..518eb21fe87 100644 --- a/gcc/testsuite/gfortran.dg/loop_versioning_9.f90 +++ b/gcc/testsuite/gfortran.dg/loop_versioning_9.f90 @@ -26,6 +26,6 @@ subroutine f4(x, i) end do end subroutine f4 -! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" } } +! { dg-final { scan-tree-dump-times {likely to be the innermost dimension} 4 "lversion" { xfail *-*-* } } } ! { dg-final { scan-tree-dump-not {want to version} "lversion" } } ! { dg-final { scan-tree-dump-not {versioned} "lversion" } } diff --git a/libgfortran/intrinsics/cshift0.c b/libgfortran/intrinsics/cshift0.c index 2fe4d04e5af..d788955e246 100644 --- a/libgfortran/intrinsics/cshift0.c +++ b/libgfortran/intrinsics/cshift0.c @@ -324,8 +324,17 @@ cshift0 (gfc_array_char * ret, const gfc_array_char * array, dim = GFC_DESCRIPTOR_RANK (array); rstride0 = rstride[0]; sstride0 = sstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; + + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + arstart * GFC_DESCRIPTOR_SIZE(array); shift = len == 0 ? 0 : shift % (ptrdiff_t)len; if (shift < 0) diff --git a/libgfortran/intrinsics/eoshift0.c b/libgfortran/intrinsics/eoshift0.c index 6114dce8417..ee699bb1b99 100644 --- a/libgfortran/intrinsics/eoshift0.c +++ b/libgfortran/intrinsics/eoshift0.c @@ -204,8 +204,16 @@ eoshift0 (gfc_array_char * ret, const gfc_array_char * array, rstride0 = rstride[0]; sstride0 = sstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart * GFC_DESCRIPTOR_SIZE(array); while (rptr) { diff --git a/libgfortran/intrinsics/eoshift2.c b/libgfortran/intrinsics/eoshift2.c index fd75b1dc387..9e1784d8d24 100644 --- a/libgfortran/intrinsics/eoshift2.c +++ b/libgfortran/intrinsics/eoshift2.c @@ -145,8 +145,16 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, rstride0 = rstride[0]; sstride0 = sstride[0]; bstride0 = bstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart * GFC_DESCRIPTOR_SIZE(array); if ((shift >= 0 ? shift : -shift ) > len) { @@ -162,7 +170,12 @@ eoshift2 (gfc_array_char *ret, const gfc_array_char *array, } if (bound) - bptr = bound->base_addr; + { + index_type bstart = GFC_DESCRIPTOR_OFFSET(bound); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(bound); i++) + bstart += GFC_DESCRIPTOR_LBOUND(bound,i) * GFC_DESCRIPTOR_STRIDE(bound,i); + bptr = bound->base_addr + bstart * GFC_DESCRIPTOR_SIZE(bound); + } else bptr = NULL; diff --git a/libgfortran/intrinsics/reshape_generic.c b/libgfortran/intrinsics/reshape_generic.c index d3d5483c60a..c11fda17e00 100644 --- a/libgfortran/intrinsics/reshape_generic.c +++ b/libgfortran/intrinsics/reshape_generic.c @@ -75,9 +75,14 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, shape_empty = 0; + index_type shstart = GFC_DESCRIPTOR_OFFSET(shape); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(shape); i++) + shstart += GFC_DESCRIPTOR_LBOUND(shape,i) * GFC_DESCRIPTOR_STRIDE(shape,i); + const index_type * const shbase = shape->base_addr + shstart; + for (n = 0; n < rdim; n++) { - shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + shape_data[n] = shbase[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; if (shape_data[n] <= 0) { shape_data[n] = 0; @@ -117,6 +122,9 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; pempty = 0; + + index_type pstart = GFC_DESCRIPTOR_OFFSET(pad); + for (n = 0; n < pdim; n++) { pcount[n] = 0; @@ -132,8 +140,10 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, psize *= pextent[n]; else psize = 0; + + pstart += GFC_DESCRIPTOR_LBOUND(pad,n) * GFC_DESCRIPTOR_STRIDE(pad,n); } - pptr = pad->base_addr; + pptr = pad->base_addr + pstart; } else { @@ -143,6 +153,15 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, pptr = NULL; } + const index_type *obase = NULL; + if (order) + { + index_type ostart = GFC_DESCRIPTOR_OFFSET(order); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(order); i++) + ostart += GFC_DESCRIPTOR_LBOUND(order,i) * GFC_DESCRIPTOR_STRIDE(order,i); + obase = order->base_addr + ostart; + } + if (unlikely (compile_options.bounds_check)) { index_type ret_extent, source_extent; @@ -187,7 +206,7 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, for (n = 0; n < rdim; n++) { - v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + v = obase[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; if (v < 0 || v >= rdim) runtime_error("Value %ld out of range in ORDER argument" @@ -206,7 +225,7 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, for (n = 0; n < rdim; n++) { if (order) - dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + dim = obase[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; else dim = n; @@ -258,8 +277,18 @@ reshape_internal (parray *ret, parray *source, shape_type *shape, pad ? pad->base_addr : NULL, psize); return; } - rptr = ret->base_addr; - src = sptr = source->base_addr; + + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart; + + index_type sstart = GFC_DESCRIPTOR_OFFSET(source); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(source); i++) + sstart += GFC_DESCRIPTOR_LBOUND(source,i) * GFC_DESCRIPTOR_STRIDE(source,i); + src = sptr = source->base_addr + sstart; + rstride0 = rstride[0] * size; sstride0 = sstride[0] * size; diff --git a/libgfortran/intrinsics/spread_generic.c b/libgfortran/intrinsics/spread_generic.c index d65912268b9..68a776bf720 100644 --- a/libgfortran/intrinsics/spread_generic.c +++ b/libgfortran/intrinsics/spread_generic.c @@ -179,8 +179,16 @@ spread_internal (gfc_array_char *ret, const gfc_array_char *source, } sstride0 = sstride[0]; rstride0 = rstride[0]; - rptr = ret->base_addr; - sptr = source->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type srcstart = GFC_DESCRIPTOR_OFFSET(source); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(source); i++) + srcstart += GFC_DESCRIPTOR_LBOUND(source,i) * GFC_DESCRIPTOR_STRIDE(source,i); + sptr = source->base_addr + srcstart * GFC_DESCRIPTOR_SIZE(source); while (sptr) { @@ -255,9 +263,14 @@ spread_internal_scalar (gfc_array_char *ret, const char *source, runtime_error ("dim too large in spread()"); } + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + char * const retbase = ret->base_addr + retstart * GFC_DESCRIPTOR_SIZE(ret); + for (n = 0; n < ncopies; n++) { - dest = (char*)(ret->base_addr + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0)); + dest = (char*)(retbase + n * GFC_DESCRIPTOR_STRIDE_BYTES(ret,0)); memcpy (dest , source, size); } } diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 96d51415392..06ff9993873 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -1079,6 +1079,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) + sizeof (descriptor_dimension)); GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL; GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0); + GFC_DESCRIPTOR_OFFSET(tail->u.udf.vlist) = 0; if (t == FMT_STRING) { @@ -1111,6 +1112,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) gfc_full_array_i4 *vp = tail->u.udf.vlist; GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4)); GFC_DIMENSION_SET(vp->dim[0],1, i, 1); + GFC_DESCRIPTOR_OFFSET(vp) = -1; memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4)); break; } diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 5a5634cfa23..48da5d3d066 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -2201,6 +2201,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, GFC_DESCRIPTOR_DATA(&vlist) = NULL; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + GFC_DESCRIPTOR_OFFSET(&vlist) = 0; /* Set iostat, intent(out). */ noiostat = 0; @@ -3000,6 +3001,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, GFC_DESCRIPTOR_DATA(&vlist) = NULL; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + GFC_DESCRIPTOR_OFFSET(&vlist) = 0; list_obj.vptr = nl->vtable; list_obj.len = 0; diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index f543dfd79dc..460cf43368d 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -2669,6 +2669,10 @@ transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind, tsize = 1; data = GFC_DESCRIPTOR_DATA (desc); + data += GFC_DESCRIPTOR_OFFSET (desc) * GFC_DESCRIPTOR_SIZE(desc); + + for (n = 0; n < rank; n++) + data += stride[n] * GFC_DESCRIPTOR_LBOUND (desc, n); /* When reading, we need to check endfile conditions so we do not miss an END=label. Make this separate so we do not have an extra test @@ -3584,7 +3588,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, empty = 0; index = 1; - *start_record = 0; + *start_record = GFC_DESCRIPTOR_OFFSET(desc); for (i=0; iinternal_unit_desc); for (i = 0; i < dtp->u.p.current_unit->rank; i++) { @@ -3640,7 +3643,7 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) else carry = 0; } - index = index + (ls[i].idx - ls[i].start) * ls[i].step; + index = index + ls[i].idx * ls[i].step; } *finished = carry; diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index 4d32e361a21..2dfa097cb00 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -492,11 +492,11 @@ set_internal_unit (st_parameter_dt *dtp, gfc_unit *iunit, int kind) /* Set initial values for unit parameters. */ if (kind == 4) - iunit->s = open_internal4 (iunit->internal_unit - start_record, - iunit->internal_unit_len, -start_record); + iunit->s = open_internal4 (iunit->internal_unit, + iunit->internal_unit_len, start_record); else - iunit->s = open_internal (iunit->internal_unit - start_record, - iunit->internal_unit_len, -start_record); + iunit->s = open_internal (iunit->internal_unit, + iunit->internal_unit_len, start_record); iunit->bytes_left = iunit->recl; iunit->last_record=0; diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 616c1aab166..525ba0ec02d 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -1077,7 +1077,7 @@ open_internal (char *base, size_t length, gfc_offset offset) s = xcalloc (1, sizeof (unix_stream)); s->buffer = base; - s->buffer_offset = offset; + s->logical_offset = offset; s->active = s->file_length = length; @@ -1097,7 +1097,7 @@ open_internal4 (char *base, size_t length, gfc_offset offset) s = xcalloc (1, sizeof (unix_stream)); s->buffer = base; - s->buffer_offset = offset; + s->logical_offset = offset; s->active = s->file_length = length * sizeof (gfc_char4_t); diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 5e025a108b3..c9f8491865b 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1963,6 +1963,7 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, GFC_DESCRIPTOR_DATA(&vlist) = NULL; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + GFC_DESCRIPTOR_OFFSET(&vlist) = 0; /* Set iostat, intent(out). */ noiostat = 0; @@ -2288,6 +2289,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset, formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); + GFC_DESCRIPTOR_OFFSET(&vlist) = 0; /* Set iostat, intent(out). */ noiostat = 0; diff --git a/libgfortran/m4/cshift0.m4 b/libgfortran/m4/cshift0.m4 index 776f8fad476..d294a282edf 100644 --- a/libgfortran/m4/cshift0.m4 +++ b/libgfortran/m4/cshift0.m4 @@ -162,8 +162,16 @@ cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift, rstride0 = rstride[0]; sstride0 = sstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart; + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart; /* Avoid the costly modulo for trivially in-bound shifts. */ if (shift < 0 || shift >= len) diff --git a/libgfortran/m4/cshift1.m4 b/libgfortran/m4/cshift1.m4 index 134a2609989..360e408dbb3 100644 --- a/libgfortran/m4/cshift1.m4 +++ b/libgfortran/m4/cshift1.m4 @@ -245,9 +245,21 @@ cshift1 (gfc_array_char * const restrict ret, rstride0 = rstride[0]; sstride0 = sstride[0]; hstride0 = hstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; - hptr = h->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart * GFC_DESCRIPTOR_SIZE(array); + + index_type hstart = GFC_DESCRIPTOR_OFFSET(h); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(h); i++) + hstart += GFC_DESCRIPTOR_LBOUND(h,i) * GFC_DESCRIPTOR_STRIDE(h,i); + hptr = h->base_addr + hstart; while (rptr) { diff --git a/libgfortran/m4/cshift1a.m4 b/libgfortran/m4/cshift1a.m4 index 2093812b612..576c0e47146 100644 --- a/libgfortran/m4/cshift1a.m4 +++ b/libgfortran/m4/cshift1a.m4 @@ -116,9 +116,21 @@ cshift1'rtype_qual`_'atype_code` ('atype` * const restrict ret, rstride0 = rstride[0]; sstride0 = sstride[0]; hstride0 = hstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; - hptr = h->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart; + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart; + + index_type hstart = GFC_DESCRIPTOR_OFFSET(h); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(h); i++) + hstart += GFC_DESCRIPTOR_LBOUND(h,i) * GFC_DESCRIPTOR_STRIDE(h,i); + hptr = h->base_addr + hstart; while (rptr) { diff --git a/libgfortran/m4/eoshift1.m4 b/libgfortran/m4/eoshift1.m4 index d662dcc515e..f1a9bf469eb 100644 --- a/libgfortran/m4/eoshift1.m4 +++ b/libgfortran/m4/eoshift1.m4 @@ -156,9 +156,21 @@ eoshift1 (gfc_array_char * const restrict ret, rstride0 = rstride[0]; sstride0 = sstride[0]; hstride0 = hstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; - hptr = h->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart * GFC_DESCRIPTOR_SIZE(array); + + index_type hstart = GFC_DESCRIPTOR_OFFSET(h); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(h); i++) + hstart += GFC_DESCRIPTOR_LBOUND(h,i) * GFC_DESCRIPTOR_STRIDE(h,i); + hptr = h->base_addr + hstart; while (rptr) { diff --git a/libgfortran/m4/eoshift3.m4 b/libgfortran/m4/eoshift3.m4 index 9b18a04cdfe..94fe2e588ef 100644 --- a/libgfortran/m4/eoshift3.m4 +++ b/libgfortran/m4/eoshift3.m4 @@ -167,11 +167,29 @@ eoshift3 (gfc_array_char * const restrict ret, sstride0 = sstride[0]; hstride0 = hstride[0]; bstride0 = bstride[0]; - rptr = ret->base_addr; - sptr = array->base_addr; - hptr = h->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart * GFC_DESCRIPTOR_SIZE(ret); + + index_type sstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + sstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + sstart * GFC_DESCRIPTOR_SIZE(array); + + index_type hstart = GFC_DESCRIPTOR_OFFSET(h); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(h); i++) + hstart += GFC_DESCRIPTOR_LBOUND(h,i) * GFC_DESCRIPTOR_STRIDE(h,i); + hptr = h->base_addr + hstart; + if (bound) - bptr = bound->base_addr; + { + index_type bstart = GFC_DESCRIPTOR_OFFSET(bound); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(bound); i++) + bstart += GFC_DESCRIPTOR_LBOUND(bound,i) * GFC_DESCRIPTOR_STRIDE(bound,i); + bptr = bound->base_addr + bstart * GFC_DESCRIPTOR_SIZE(bound); + } else bptr = NULL; diff --git a/libgfortran/m4/ifindloc0.m4 b/libgfortran/m4/ifindloc0.m4 index 360dbb17fec..73403576d32 100644 --- a/libgfortran/m4/ifindloc0.m4 +++ b/libgfortran/m4/ifindloc0.m4 @@ -58,7 +58,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); - dest = retarray->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; /* Set the return value. */ for (n = 0; n < rank; n++) @@ -77,9 +81,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see for (n = 0; n < rank; n++) count[n] = 0; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + if (back) { - base = array->base_addr + (sz - 1) * 'base_mult`'`; + base = base + (sz - 1) * 'base_mult`'`; while (1) { @@ -117,7 +126,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } else { - base = array->base_addr; while (1) { do @@ -194,7 +202,10 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see mask_kind = GFC_DESCRIPTOR_SIZE (mask); - mbase = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 @@ -226,9 +237,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see for (n = 0; n < rank; n++) count[n] = 0; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + if (back) { - base = array->base_addr + (sz - 1) * 'base_mult`'`; + base = base + (sz - 1) * 'base_mult`'`; mbase = mbase + (sz - 1) * mask_kind; while (1) { @@ -269,7 +285,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } else { - base = array->base_addr; while (1) { do @@ -342,7 +357,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); - dest = retarray->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + for (n = 0; nbase_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + continue_loop = 1; - base = array->base_addr; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + while (continue_loop) { const 'atype_name`'` * restrict src; @@ -302,10 +310,18 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see return; } - dest = retarray->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + continue_loop = 1; - base = array->base_addr; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + while (continue_loop) { const 'atype_name`'` * restrict src; @@ -464,7 +480,12 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see if (extent[n] <= 0) return; } - dest = retarray->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + continue_loop = 1; while (continue_loop) diff --git a/libgfortran/m4/ifindloc2.m4 b/libgfortran/m4/ifindloc2.m4 index 00fe59c8124..8dc07f845bb 100644 --- a/libgfortran/m4/ifindloc2.m4 +++ b/libgfortran/m4/ifindloc2.m4 @@ -37,10 +37,15 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see if (extent <= 0) return 0; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart; + sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`; if (back) { - src = array->base_addr + (extent - 1) * sstride; + src = src + (extent - 1) * sstride; for (i = extent; i >= 0; i--) { if ('comparison`'`) @@ -50,7 +55,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } else { - src = array->base_addr; for (i = 1; i <= extent; i++) { if ('comparison`'`) @@ -76,7 +80,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see return 0; mask_kind = GFC_DESCRIPTOR_SIZE (mask); - mbase = mask->base_addr; + + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 @@ -90,9 +98,14 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`; mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0); + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart; + if (back) { - src = array->base_addr + (extent - 1) * sstride; + src = src + (extent - 1) * sstride; mbase += (extent - 1) * mstride; for (i = extent; i >= 0; i--) { @@ -104,7 +117,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see } else { - src = array->base_addr; for (i = 1; i <= extent; i++) { if (*mbase && ('comparison`'`)) diff --git a/libgfortran/m4/ifunction-s.m4 b/libgfortran/m4/ifunction-s.m4 index 16615aa290f..8048f13fc28 100644 --- a/libgfortran/m4/ifunction-s.m4 +++ b/libgfortran/m4/ifunction-s.m4 @@ -137,8 +137,15 @@ void return; } - base = array->base_addr; - dest = retarray->base_addr; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; continue_loop = 1; while (continue_loop) @@ -247,7 +254,10 @@ m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, if (len <= 0) return; - mbase = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; mask_kind = GFC_DESCRIPTOR_SIZE (mask); @@ -335,8 +345,15 @@ m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, return; } - dest = retarray->base_addr; - base = array->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; while (base) { @@ -506,7 +523,10 @@ s'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); } - dest = retarray->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; while(1) { diff --git a/libgfortran/m4/ifunction-s2.m4 b/libgfortran/m4/ifunction-s2.m4 index 4d31c208e05..0be970832c8 100644 --- a/libgfortran/m4/ifunction-s2.m4 +++ b/libgfortran/m4/ifunction-s2.m4 @@ -139,8 +139,15 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, return; } - base = array->base_addr; - dest = retarray->base_addr; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; continue_loop = 1; while (continue_loop) @@ -247,7 +254,10 @@ void if (len <= 0) return; - mbase = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; mask_kind = GFC_DESCRIPTOR_SIZE (mask); @@ -336,8 +346,15 @@ void return; } - dest = retarray->base_addr; - base = array->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; while (base) { @@ -507,7 +524,10 @@ void dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; } - dest = retarray->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; while(1) { diff --git a/libgfortran/m4/ifunction.m4 b/libgfortran/m4/ifunction.m4 index c64217ec5db..2b6554621a3 100644 --- a/libgfortran/m4/ifunction.m4 +++ b/libgfortran/m4/ifunction.m4 @@ -124,8 +124,15 @@ name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, return; } - base = array->base_addr; - dest = retarray->base_addr; + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; continue_loop = 1; while (continue_loop) @@ -235,7 +242,10 @@ m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, if (len <= 0) return; - mbase = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; mask_kind = GFC_DESCRIPTOR_SIZE (mask); @@ -323,8 +333,15 @@ m'name`'rtype_qual`_'atype_code` ('rtype` * const restrict retarray, return; } - dest = retarray->base_addr; - base = array->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + base = array->base_addr + arstart; while (base) { @@ -494,7 +511,10 @@ void dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); } - dest = retarray->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + retstart += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); + dest = retarray->base_addr + retstart; while(1) { diff --git a/libgfortran/m4/ifunction_logical.m4 b/libgfortran/m4/ifunction_logical.m4 index 0568387e343..d1495fc1630 100644 --- a/libgfortran/m4/ifunction_logical.m4 +++ b/libgfortran/m4/ifunction_logical.m4 @@ -132,7 +132,9 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, return; } - base = array->base_addr; + base = array->base_addr + GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + base += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 @@ -146,7 +148,9 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, else internal_error (NULL, "Funny sized logical array in u_name intrinsic"); - dest = retarray->base_addr; + dest = retarray->base_addr + GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + dest += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); continue_loop = 1; while (continue_loop) diff --git a/libgfortran/m4/in_pack.m4 b/libgfortran/m4/in_pack.m4 index dbbc9a261ed..5965b8ec3b1 100644 --- a/libgfortran/m4/in_pack.m4 +++ b/libgfortran/m4/in_pack.m4 @@ -79,6 +79,12 @@ internal_pack_'rtype_ccode` ('rtype` * source) destptr = xmallocarray (ssize, sizeof ('rtype_name`)); dest = destptr; src = source->base_addr; + + index_type start_index = GFC_DESCRIPTOR_OFFSET(source); + for (index_type n = 0; n < dim; n++) + start_index += GFC_DESCRIPTOR_LBOUND(source,n) * stride[n]; + src += start_index; + stride0 = stride[0]; diff --git a/libgfortran/m4/in_unpack.m4 b/libgfortran/m4/in_unpack.m4 index c46fb1760cd..15c78ff5c2f 100644 --- a/libgfortran/m4/in_unpack.m4 +++ b/libgfortran/m4/in_unpack.m4 @@ -39,6 +39,7 @@ internal_unpack_'rtype_ccode` ('rtype` * d, const 'rtype_name` * src) index_type extent[GFC_MAX_DIMENSIONS]; index_type stride[GFC_MAX_DIMENSIONS]; index_type stride0; + index_type n; index_type dim; index_type dsize; 'rtype_name` * restrict dest; @@ -63,6 +64,11 @@ internal_unpack_'rtype_ccode` ('rtype` * d, const 'rtype_name` * src) dsize = 0; } + index_type start_index = GFC_DESCRIPTOR_OFFSET(d); + for (int i = 0; i < dim; i++) + start_index += GFC_DESCRIPTOR_LBOUND(d,i) * stride[i]; + dest += start_index; + if (dsize != 0) { memcpy (dest, src, dsize * sizeof ('rtype_name`)); diff --git a/libgfortran/m4/matmul_internal.m4 b/libgfortran/m4/matmul_internal.m4 index 0e96207a0fc..299bbdd7966 100644 --- a/libgfortran/m4/matmul_internal.m4 +++ b/libgfortran/m4/matmul_internal.m4 @@ -150,9 +150,17 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl ycount = GFC_DESCRIPTOR_EXTENT(b,1); } - abase = a->base_addr; - bbase = b->base_addr; - dest = retarray->base_addr; + abase = a->base_addr + GFC_DESCRIPTOR_OFFSET(a); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(a); i++) + abase += GFC_DESCRIPTOR_LBOUND(a,i) * GFC_DESCRIPTOR_STRIDE(a,i); + + bbase = b->base_addr + GFC_DESCRIPTOR_OFFSET(b); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(b); i++) + bbase += GFC_DESCRIPTOR_LBOUND(b,i) * GFC_DESCRIPTOR_STRIDE(b,i); + + dest = retarray->base_addr + GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + dest += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); /* Now that everything is set up, we perform the multiplication itself. */ @@ -222,7 +230,7 @@ sinclude(`matmul_asm_'rtype_code`.m4')dnl a = abase; b = bbase; - c = retarray->base_addr; + c = dest; /* Parameter adjustments */ c_dim1 = rystride; diff --git a/libgfortran/m4/matmull.m4 b/libgfortran/m4/matmull.m4 index fc42a8d8134..7d0b38f8852 100644 --- a/libgfortran/m4/matmull.m4 +++ b/libgfortran/m4/matmull.m4 @@ -133,7 +133,10 @@ matmul_'rtype_code` ('rtype` * const restrict retarray, } } - abase = a->base_addr; + abase = a->base_addr + GFC_DESCRIPTOR_OFFSET(a); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(a); i++) + abase += GFC_DESCRIPTOR_LBOUND(a,i) * GFC_DESCRIPTOR_STRIDE(a,i); + a_kind = GFC_DESCRIPTOR_SIZE (a); if (a_kind == 1 || a_kind == 2 || a_kind == 4 || a_kind == 8 @@ -145,7 +148,10 @@ matmul_'rtype_code` ('rtype` * const restrict retarray, else internal_error (NULL, "Funny sized logical array"); - bbase = b->base_addr; + bbase = b->base_addr + GFC_DESCRIPTOR_OFFSET(b); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(b); i++) + bbase += GFC_DESCRIPTOR_LBOUND(b,i) * GFC_DESCRIPTOR_STRIDE(b,i); + b_kind = GFC_DESCRIPTOR_SIZE (b); if (b_kind == 1 || b_kind == 2 || b_kind == 4 || b_kind == 8 @@ -157,7 +163,9 @@ matmul_'rtype_code` ('rtype` * const restrict retarray, else internal_error (NULL, "Funny sized logical array"); - dest = retarray->base_addr; + dest = retarray->base_addr + GFC_DESCRIPTOR_OFFSET(retarray); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(retarray); i++) + dest += GFC_DESCRIPTOR_LBOUND(retarray,i) * GFC_DESCRIPTOR_STRIDE(retarray,i); ' sinclude(`matmul_asm_'rtype_code`.m4')dnl ` diff --git a/libgfortran/m4/maxloc2s.m4 b/libgfortran/m4/maxloc2s.m4 index ca33cc06c5e..41b8d95408b 100644 --- a/libgfortran/m4/maxloc2s.m4 +++ b/libgfortran/m4/maxloc2s.m4 @@ -61,7 +61,12 @@ export_proto('name`'rtype_qual`_'atype_code`); sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; ret = 1; - src = array->base_addr; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart; + maxval = NULL; for (i=1; i<=extent; i++) { @@ -103,7 +108,11 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; mask_kind = GFC_DESCRIPTOR_SIZE (mask); - mbase = mask->base_addr; + + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 @@ -128,7 +137,11 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, return 0; ret = j + 1; - src = array->base_addr + j * sstride; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart + j * sstride; maxval = src; for (i=j+1; i<=extent; i++) diff --git a/libgfortran/m4/minloc2s.m4 b/libgfortran/m4/minloc2s.m4 index db8507b52bd..49d0b14e537 100644 --- a/libgfortran/m4/minloc2s.m4 +++ b/libgfortran/m4/minloc2s.m4 @@ -62,7 +62,12 @@ export_proto('name`'rtype_qual`_'atype_code`); sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; ret = 1; - src = array->base_addr; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart; + minval = NULL; for (i=1; i<=extent; i++) { @@ -104,7 +109,11 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len; mask_kind = GFC_DESCRIPTOR_SIZE (mask); - mbase = mask->base_addr; + + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mbase = mask->base_addr + mstart; if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 #ifdef HAVE_GFC_LOGICAL_16 @@ -129,7 +138,11 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, return 0; ret = j + 1; - src = array->base_addr + j * sstride; + + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + src = array->base_addr + arstart + j * sstride; maxval = src; for (i=j+1; i<=extent; i++) diff --git a/libgfortran/m4/pack.m4 b/libgfortran/m4/pack.m4 index 4ca217bfdf3..b981823f363 100644 --- a/libgfortran/m4/pack.m4 +++ b/libgfortran/m4/pack.m4 @@ -97,7 +97,10 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, dim = GFC_DESCRIPTOR_RANK (array); - mptr = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mptr = mask->base_addr + mstart; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 and using shifting to address size and endian issues. */ @@ -135,7 +138,12 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, if (zero_sized) sptr = NULL; else - sptr = array->base_addr; + { + index_type arstart = GFC_DESCRIPTOR_OFFSET(array); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(array); i++) + arstart += GFC_DESCRIPTOR_LBOUND(array,i) * GFC_DESCRIPTOR_STRIDE(array,i); + sptr = array->base_addr + arstart; + } if (ret->base_addr == NULL || unlikely (compile_options.bounds_check)) { @@ -190,7 +198,11 @@ pack_'rtype_code` ('rtype` *ret, const 'rtype` *array, rstride0 = 1; sstride0 = sstride[0]; mstride0 = mstride[0]; - rptr = ret->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart; while (sptr && mptr) { diff --git a/libgfortran/m4/reshape.m4 b/libgfortran/m4/reshape.m4 index 07805907161..47ba41e78f7 100644 --- a/libgfortran/m4/reshape.m4 +++ b/libgfortran/m4/reshape.m4 @@ -89,9 +89,14 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, shape_empty = 0; + index_type shstart = GFC_DESCRIPTOR_OFFSET(shape); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(shape); i++) + shstart += GFC_DESCRIPTOR_LBOUND(shape,i) * GFC_DESCRIPTOR_STRIDE(shape,i); + const index_type * const shbase = shape->base_addr + shstart; + for (index_type n = 0; n < rdim; n++) { - shape_data[n] = shape->base_addr[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; + shape_data[n] = shbase[n * GFC_DESCRIPTOR_STRIDE(shape,0)]; if (shape_data[n] <= 0) { shape_data[n] = 0; @@ -131,6 +136,7 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, pdim = GFC_DESCRIPTOR_RANK (pad); psize = 1; pempty = 0; + index_type pstart = GFC_DESCRIPTOR_OFFSET(pad); for (index_type n = 0; n < pdim; n++) { pcount[n] = 0; @@ -146,8 +152,10 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, psize *= pextent[n]; else psize = 0; + + pstart += GFC_DESCRIPTOR_LBOUND(pad,n) * GFC_DESCRIPTOR_STRIDE(pad,n); } - pptr = pad->base_addr; + pptr = pad->base_addr + pstart; } else { @@ -157,6 +165,15 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, pptr = NULL; } + const index_type * obase = NULL; + if (order) + { + index_type ostart = GFC_DESCRIPTOR_OFFSET(order); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(order); i++) + ostart += GFC_DESCRIPTOR_LBOUND(order,i) * GFC_DESCRIPTOR_STRIDE(order,i); + obase = order->base_addr + ostart; + } + if (unlikely (compile_options.bounds_check)) { index_type ret_extent, source_extent; @@ -197,7 +214,7 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, for (index_type n = 0; n < rdim; n++) { - v = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + v = obase[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; if (v < 0 || v >= rdim) runtime_error("Value %ld out of range in ORDER argument" @@ -217,7 +234,7 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, { index_type dim; if (order) - dim = order->base_addr[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; + dim = obase[n * GFC_DESCRIPTOR_STRIDE(order,0)] - 1; else dim = n; @@ -272,8 +289,17 @@ reshape_'rtype_ccode` ('rtype` * const restrict ret, ssize, pad ? (char *)pad->base_addr : NULL, psize); return; } - rptr = ret->base_addr; - src = sptr = source->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart; + + index_type sstart = GFC_DESCRIPTOR_OFFSET(source); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(source); i++) + sstart += GFC_DESCRIPTOR_LBOUND(source,i) * GFC_DESCRIPTOR_STRIDE(source,i); + src = sptr = source->base_addr + sstart; + rstride0 = rstride[0]; sstride0 = sstride[0]; diff --git a/libgfortran/m4/shape.m4 b/libgfortran/m4/shape.m4 index d5640a1a727..dd9de607a23 100644 --- a/libgfortran/m4/shape.m4 +++ b/libgfortran/m4/shape.m4 @@ -54,10 +54,15 @@ shape_'rtype_kind` ('rtype` * const restrict ret, if (GFC_DESCRIPTOR_EXTENT(ret,0) < 1) return; + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + 'rtype_name` * const retbase = ret->base_addr + retstart; + for (index_type n = 0; n < rank; n++) { extent = GFC_DESCRIPTOR_EXTENT(array,n); - ret->base_addr[n * stride] = extent > 0 ? extent : 0 ; + retbase[n * stride] = extent > 0 ? extent : 0 ; } } diff --git a/libgfortran/m4/spread.m4 b/libgfortran/m4/spread.m4 index 54a75acaefc..72e2b7daefa 100644 --- a/libgfortran/m4/spread.m4 +++ b/libgfortran/m4/spread.m4 @@ -181,8 +181,16 @@ spread_'rtype_code` ('rtype` *ret, const 'rtype` *source, } sstride0 = sstride[0]; rstride0 = rstride[0]; - rptr = ret->base_addr; - sptr = source->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart; + + index_type srcstart = GFC_DESCRIPTOR_OFFSET(source); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(source); i++) + srcstart += GFC_DESCRIPTOR_LBOUND(source,i) * GFC_DESCRIPTOR_STRIDE(source,i); + sptr = source->base_addr + srcstart; while (sptr) { @@ -253,7 +261,11 @@ spread_scalar_'rtype_code` ('rtype` *ret, const 'rtype_name` *source, runtime_error ("dim too large in spread()"); } - dest = ret->base_addr; + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + dest = ret->base_addr + retstart; + stride = GFC_DESCRIPTOR_STRIDE(ret,0); for (index_type n = 0; n < ncopies; n++) diff --git a/libgfortran/m4/unpack.m4 b/libgfortran/m4/unpack.m4 index 050eeb5e40f..928591a9289 100644 --- a/libgfortran/m4/unpack.m4 +++ b/libgfortran/m4/unpack.m4 @@ -60,7 +60,10 @@ unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector, empty = 0; - mptr = mask->base_addr; + index_type maskstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + maskstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mptr = mask->base_addr + maskstart; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 and using shifting to address size and endian issues. */ @@ -128,8 +131,16 @@ unpack0_'rtype_code` ('rtype` *ret, const 'rtype` *vector, vstride0 = 1; rstride0 = rstride[0]; mstride0 = mstride[0]; - rptr = ret->base_addr; - vptr = vector->base_addr; + + index_type retstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + retstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + retstart; + + index_type vecstart = GFC_DESCRIPTOR_OFFSET(vector); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(vector); i++) + vecstart += GFC_DESCRIPTOR_LBOUND(vector,i) * GFC_DESCRIPTOR_STRIDE(vector,i); + vptr = vector->base_addr + vecstart; while (rptr) { @@ -206,7 +217,10 @@ unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector, empty = 0; - mptr = mask->base_addr; + index_type mstart = GFC_DESCRIPTOR_OFFSET(mask); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(mask); i++) + mstart += GFC_DESCRIPTOR_LBOUND(mask,i) * GFC_DESCRIPTOR_STRIDE(mask,i); + mptr = mask->base_addr + mstart; /* Use the same loop for all logical types, by using GFC_LOGICAL_1 and using shifting to address size and endian issues. */ @@ -279,9 +293,21 @@ unpack1_'rtype_code` ('rtype` *ret, const 'rtype` *vector, rstride0 = rstride[0]; fstride0 = fstride[0]; mstride0 = mstride[0]; - rptr = ret->base_addr; - fptr = field->base_addr; - vptr = vector->base_addr; + + index_type rstart = GFC_DESCRIPTOR_OFFSET(ret); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(ret); i++) + rstart += GFC_DESCRIPTOR_LBOUND(ret,i) * GFC_DESCRIPTOR_STRIDE(ret,i); + rptr = ret->base_addr + rstart; + + index_type fstart = GFC_DESCRIPTOR_OFFSET(field); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(field); i++) + fstart += GFC_DESCRIPTOR_LBOUND(field,i) * GFC_DESCRIPTOR_STRIDE(field,i); + fptr = field->base_addr + fstart; + + index_type vecstart = GFC_DESCRIPTOR_OFFSET(vector); + for (int i = 0; i < GFC_DESCRIPTOR_RANK(vector); i++) + vecstart += GFC_DESCRIPTOR_LBOUND(vector,i) * GFC_DESCRIPTOR_STRIDE(vector,i); + vptr = vector->base_addr + vecstart; while (rptr) { diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c index 37c07aad3e2..c4e81b046db 100644 --- a/libgfortran/runtime/in_pack_generic.c +++ b/libgfortran/runtime/in_pack_generic.c @@ -187,6 +187,12 @@ internal_pack (gfc_array_char * source) destptr = xmallocarray (ssize, size); dest = (char *)destptr; src = source->base_addr; + + index_type start_index = GFC_DESCRIPTOR_OFFSET(source); + for (index_type n = 0; n < dim; n++) + start_index += GFC_DESCRIPTOR_LBOUND(source,n) * stride[n]; + src += start_index * size; + stride0 = stride[0] * size; while (src) diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c index 1bed7e1b1ab..73079fdd6a0 100644 --- a/libgfortran/runtime/in_unpack_generic.c +++ b/libgfortran/runtime/in_unpack_generic.c @@ -36,6 +36,7 @@ internal_unpack (gfc_array_char * d, const void * s) index_type extent[GFC_MAX_DIMENSIONS]; index_type stride[GFC_MAX_DIMENSIONS]; index_type stride0; + index_type n; index_type dim; index_type dsize; char *dest; @@ -188,6 +189,12 @@ internal_unpack (gfc_array_char * d, const void * s) size = GFC_DESCRIPTOR_SIZE (d); dim = GFC_DESCRIPTOR_RANK (d); + + index_type start_index = GFC_DESCRIPTOR_OFFSET(d); + for (int i = 0; i < dim; i++) + start_index += GFC_DESCRIPTOR_LBOUND(d,i) * stride[i]; + dest += start_index * size; + dsize = 1; for (index_type n = 0; n < dim; n++) { @@ -201,6 +208,7 @@ internal_unpack (gfc_array_char * d, const void * s) dsize *= extent[n]; else dsize = 0; + } src = s;