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;