@@ -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;
}
@@ -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);
@@ -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)
@@ -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)
@@ -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));
- }
}
@@ -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);
@@ -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
@@ -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" } }
@@ -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" } }
@@ -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" } }
@@ -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" } }
@@ -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
@@ -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 *-*-* } } }
@@ -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 *-*-* } } }
@@ -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" } }
@@ -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 *-*-* } } }
@@ -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 *-*-* } } }
@@ -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 *-*-* } } }
@@ -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" } }
@@ -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)
@@ -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)
{
@@ -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;
@@ -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;
@@ -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);
}
}
@@ -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;
}
@@ -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;
@@ -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; i<rank; i++)
{
@@ -3604,9 +3608,8 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
{
index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
* GFC_DESCRIPTOR_STRIDE(desc,i);
- *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
- * GFC_DESCRIPTOR_STRIDE(desc,i);
}
+ *start_record += GFC_DESCRIPTOR_LBOUND(desc,i) * GFC_DESCRIPTOR_STRIDE(desc,i);
}
if (empty)
@@ -3625,7 +3628,7 @@ next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
gfc_offset index;
carry = 1;
- index = 0;
+ index = GFC_DESCRIPTOR_OFFSET(dtp->internal_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;
@@ -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;
@@ -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);
@@ -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;
@@ -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)
@@ -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)
{
@@ -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)
{
@@ -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)
{
@@ -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;
@@ -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; n<rank; n++)
dest[n * dstride] = 0 ;
}
@@ -124,10 +124,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;
@@ -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)
@@ -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`'`))
@@ -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)
{
@@ -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)
{
@@ -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)
{
@@ -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)
@@ -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];
@@ -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`));
@@ -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;
@@ -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
`
@@ -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++)
@@ -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++)
@@ -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)
{
@@ -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];
@@ -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 ;
}
}
@@ -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++)
@@ -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)
{
@@ -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)
@@ -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;