#define OFFSET_FIELD 1
#define DTYPE_FIELD 2
#define DIMENSION_FIELD 3
+#define CAF_TOKEN_FIELD 4
#define STRIDE_SUBFIELD 0
#define LBOUND_SUBFIELD 1
return tmp;
}
+
+tree
+gfc_conv_descriptor_token (tree desc)
+{
+ tree type;
+ tree field;
+
+ type = TREE_TYPE (desc);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
+ gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
+ field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
+ gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
+
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+
static tree
gfc_conv_descriptor_stride (tree desc, tree dim)
{
#undef OFFSET_FIELD
#undef DTYPE_FIELD
#undef DIMENSION_FIELD
+#undef CAF_TOKEN_FIELD
#undef STRIDE_SUBFIELD
#undef LBOUND_SUBFIELD
#undef UBOUND_SUBFIELD
}
+/* Creates and initializes an array type gfc_ss struct. */
+
+gfc_ss *
+gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type)
+{
+ gfc_ss *ss;
+ gfc_ss_info *info;
+ int i;
+
+ ss = gfc_get_ss ();
+ ss->next = next;
+ ss->type = type;
+ ss->expr = expr;
+ info = &ss->data.info;
+ info->dimen = dimen;
+ for (i = 0; i < info->dimen; i++)
+ info->dim[i] = i;
+
+ return ss;
+}
+
+
+/* Creates and initializes a temporary type gfc_ss struct. */
+
+gfc_ss *
+gfc_get_temp_ss (tree type, tree string_length, int dimen)
+{
+ gfc_ss *ss;
+
+ ss = gfc_get_ss ();
+ ss->next = gfc_ss_terminator;
+ ss->type = GFC_SS_TEMP;
+ ss->string_length = string_length;
+ ss->data.temp.dimen = dimen;
+ ss->data.temp.type = type;
+
+ return ss;
+}
+
+
+/* Creates and initializes a scalar type gfc_ss struct. */
+
+gfc_ss *
+gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr)
+{
+ gfc_ss *ss;
+
+ ss = gfc_get_ss ();
+ ss->next = next;
+ ss->type = GFC_SS_SCALAR;
+ ss->expr = expr;
+
+ return ss;
+}
+
+
/* Free all the SS associated with a loop. */
void
tree tmp;
if (as && as->type == AS_EXPLICIT)
- for (n = 0; n < se->loop->dimen + se->loop->codimen; n++)
+ for (n = 0; n < se->loop->dimen; n++)
{
dim = se->ss->data.info.dim[n];
gcc_assert (dim < as->rank);
gfc_add_block_to_block (&se->post, &tmpse.post);
lower = fold_convert (gfc_array_index_type, tmpse.expr);
- if (se->loop->codimen == 0
- || n < se->loop->dimen + se->loop->codimen - 1)
- {
- /* ...and the upper bound. */
- gfc_init_se (&tmpse, NULL);
- gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
- gfc_add_block_to_block (&se->pre, &tmpse.pre);
- gfc_add_block_to_block (&se->post, &tmpse.post);
- upper = fold_convert (gfc_array_index_type, tmpse.expr);
-
- /* Set the upper bound of the loop to UPPER - LOWER. */
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, upper, lower);
- tmp = gfc_evaluate_now (tmp, &se->pre);
- se->loop->to[n] = tmp;
- }
+ /* ...and the upper bound. */
+ gfc_init_se (&tmpse, NULL);
+ gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]);
+ gfc_add_block_to_block (&se->pre, &tmpse.pre);
+ gfc_add_block_to_block (&se->post, &tmpse.post);
+ upper = fold_convert (gfc_array_index_type, tmpse.expr);
+
+ /* Set the upper bound of the loop to UPPER - LOWER. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, upper, lower);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->loop->to[n] = tmp;
}
}
}
size, tmp);
size = gfc_evaluate_now (size, pre);
}
- for (n = info->dimen; n < info->dimen + info->codimen; n++)
- {
- gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n],
- gfc_index_zero_node);
- if (n < info->dimen + info->codimen - 1)
- gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]);
- }
/* Get the size of the array. */
size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type));
bound = build_int_cst (size_type_node, n * size);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MEMCPY], 3,
- tmp, init, bound);
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3, tmp, init, bound);
gfc_add_expr_to_block (&body, tmp);
*poffset = fold_build2_loc (input_location, PLUS_EXPR,
info->data = gfc_build_addr_expr (NULL_TREE, tmp);
info->offset = gfc_index_zero_node;
- for (i = 0; i < info->dimen + info->codimen; i++)
+ for (i = 0; i < info->dimen; i++)
{
info->delta[i] = gfc_index_zero_node;
info->start[i] = gfc_index_zero_node;
info->end[i] = gfc_index_zero_node;
info->stride[i] = gfc_index_one_node;
- info->dim[i] = i;
}
if (info->dimen > loop->temp_dim)
first_len = true;
}
- ss->data.info.dimen = loop->dimen;
+ gcc_assert (ss->data.info.dimen == loop->dimen);
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
int n;
int dim;
- for (n = 0; n < loop->dimen + loop->codimen; n++)
+ for (n = 0; n < loop->dimen; n++)
{
dim = info->dim[n];
if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR
/* Temporary array or derived type component. */
gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]];
+
+ /* Pointer functions can have stride[0] different from unity.
+ Use the stride returned by the function call and stored in
+ the descriptor for the temporary. */
+ if (se->ss && se->ss->type == GFC_SS_FUNCTION
+ && se->ss->expr
+ && se->ss->expr->symtree
+ && se->ss->expr->symtree->n.sym->result
+ && se->ss->expr->symtree->n.sym->result->attr.pointer)
+ stride = gfc_conv_descriptor_stride_get (info->descriptor,
+ gfc_rank_cst[dim]);
+
if (!integer_zerop (info->delta[dim]))
index = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, index, info->delta[dim]);
gfc_advance_se_ss_chain (se);
}
+/* Add T to the offset pair *OFFSET, *CST_OFFSET. */
+
+static void
+add_to_offset (tree *cst_offset, tree *offset, tree t)
+{
+ if (TREE_CODE (t) == INTEGER_CST)
+ *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t);
+ else
+ {
+ if (!integer_zerop (*offset))
+ *offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, *offset, t);
+ else
+ *offset = t;
+ }
+}
/* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component
locus * where)
{
int n;
- tree index;
+ tree offset, cst_offset;
tree tmp;
tree stride;
gfc_se indexse;
if (ar->dimen == 0)
{
gcc_assert (ar->codimen);
- if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
- && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
- se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
- /* Use the actual tree type and not the wrapped coarray. */
- se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), se->expr);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
+ se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
+ else
+ {
+ if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
+ && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
+ se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+
+ /* Use the actual tree type and not the wrapped coarray. */
+ if (!se->want_pointer)
+ se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
+ se->expr);
+ }
+
return;
}
return;
}
- index = gfc_index_zero_node;
+ cst_offset = offset = gfc_index_zero_node;
+ add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr));
- /* Calculate the offsets from all the dimensions. */
- for (n = 0; n < ar->dimen; n++)
+ /* Calculate the offsets from all the dimensions. Make sure to associate
+ the final offset so that we form a chain of loop invariant summands. */
+ for (n = ar->dimen - 1; n >= 0; n--)
{
/* Calculate the index for this dimension. */
gfc_init_se (&indexse, se);
indexse.expr, stride);
/* And add it to the total. */
- index = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, index, tmp);
+ add_to_offset (&cst_offset, &offset, tmp);
}
- tmp = gfc_conv_array_offset (se->expr);
- if (!integer_zerop (tmp))
- index = fold_build2_loc (input_location, PLUS_EXPR,
- gfc_array_index_type, index, tmp);
+ if (!integer_zerop (cst_offset))
+ offset = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, cst_offset);
/* Access the calculated element. */
tmp = gfc_conv_array_data (se->expr);
tmp = build_fold_indirect_ref (tmp);
- se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl);
+ se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl);
}
gcc_assert (!loop->array_parameter);
- for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--)
+ for (dim = loop->dimen - 1; dim >= 0; dim--)
{
n = loop->order[dim];
pblock = body;
/* Generate the loops. */
- for (dim = 0; dim < loop->dimen + loop->codimen; dim++)
+ for (dim = 0; dim < loop->dimen; dim++)
{
n = loop->order[dim];
gfc_trans_scalarized_loop_end (loop, n, pblock);
}
+/* Precalculate (either lower or upper) bound of an array section.
+ BLOCK: Block in which the (pre)calculation code will go.
+ BOUNDS[DIM]: Where the bound value will be stored once evaluated.
+ VALUES[DIM]: Specified bound (NULL <=> unspecified).
+ DESC: Array descriptor from which the bound will be picked if unspecified
+ (either lower or upper bound according to LBOUND). */
+
+static void
+evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values,
+ tree desc, int dim, bool lbound)
+{
+ gfc_se se;
+ gfc_expr * input_val = values[dim];
+ tree *output = &bounds[dim];
+
+
+ if (input_val)
+ {
+ /* Specified section bound. */
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, input_val, gfc_array_index_type);
+ gfc_add_block_to_block (block, &se.pre);
+ *output = se.expr;
+ }
+ else
+ {
+ /* No specific bound specified so use the bound of the array. */
+ *output = lbound ? gfc_conv_array_lbound (desc, dim) :
+ gfc_conv_array_ubound (desc, dim);
+ }
+ *output = gfc_evaluate_now (*output, block);
+}
+
+
/* Calculate the lower bound of an array section. */
static void
-gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim,
- bool coarray, bool coarray_last)
+gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim)
{
- gfc_expr *start;
- gfc_expr *end;
gfc_expr *stride = NULL;
tree desc;
gfc_se se;
gfc_ss_info *info;
+ gfc_array_ref *ar;
gcc_assert (ss->type == GFC_SS_SECTION);
info = &ss->data.info;
+ ar = &info->ref->u.ar;
- if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ if (ar->dimen_type[dim] == DIMEN_VECTOR)
{
/* We use a zero-based index to access the vector. */
info->start[dim] = gfc_index_zero_node;
info->end[dim] = NULL;
- if (!coarray)
- info->stride[dim] = gfc_index_one_node;
+ info->stride[dim] = gfc_index_one_node;
return;
}
- gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE);
+ gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE
+ || ar->dimen_type[dim] == DIMEN_THIS_IMAGE);
desc = info->descriptor;
- start = info->ref->u.ar.start[dim];
- end = info->ref->u.ar.end[dim];
- if (!coarray)
- stride = info->ref->u.ar.stride[dim];
+ stride = ar->stride[dim];
/* Calculate the start of the range. For vector subscripts this will
be the range of the vector. */
- if (start)
- {
- /* Specified section start. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, start, gfc_array_index_type);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- info->start[dim] = se.expr;
- }
- else
- {
- /* No lower bound specified so use the bound of the array. */
- info->start[dim] = gfc_conv_array_lbound (desc, dim);
- }
- info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre);
+ evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true);
/* Similarly calculate the end. Although this is not used in the
scalarizer, it is needed when checking bounds and where the end
is an expression with side-effects. */
- if (!coarray_last)
- {
- if (end)
- {
- /* Specified section start. */
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, end, gfc_array_index_type);
- gfc_add_block_to_block (&loop->pre, &se.pre);
- info->end[dim] = se.expr;
- }
- else
- {
- /* No upper bound specified so use the bound of the array. */
- info->end[dim] = gfc_conv_array_ubound (desc, dim);
- }
- info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre);
- }
+ evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false);
/* Calculate the stride. */
- if (!coarray && stride == NULL)
+ if (stride == NULL)
info->stride[dim] = gfc_index_one_node;
- else if (!coarray)
+ else
{
gfc_init_se (&se, NULL);
gfc_conv_expr_type (&se, stride, gfc_array_index_type);
loop->dimen = 0;
/* Determine the rank of the loop. */
- for (ss = loop->ss;
- ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain)
+ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
switch (ss->type)
{
case GFC_SS_FUNCTION:
case GFC_SS_COMPONENT:
loop->dimen = ss->data.info.dimen;
- loop->codimen = ss->data.info.codimen;
- break;
+ goto done;
/* As usual, lbound and ubound are exceptions!. */
case GFC_SS_INTRINSIC:
{
case GFC_ISYM_LBOUND:
case GFC_ISYM_UBOUND:
- loop->dimen = ss->data.info.dimen;
- loop->codimen = 0;
- break;
-
case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UCOBOUND:
case GFC_ISYM_THIS_IMAGE:
loop->dimen = ss->data.info.dimen;
- loop->codimen = ss->data.info.codimen;
- break;
+ goto done;
default:
break;
/* We should have determined the rank of the expression by now. If
not, that's bad news. */
- gcc_assert (loop->dimen + loop->codimen != 0);
+ gcc_unreachable ();
+done:
/* Loop over all the SS in the chain. */
for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain)
{
gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter);
for (n = 0; n < ss->data.info.dimen; n++)
- gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n],
- false, false);
- for (n = ss->data.info.dimen;
- n < ss->data.info.dimen + ss->data.info.codimen; n++)
- gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true,
- n == ss->data.info.dimen
- + ss->data.info.codimen -1);
-
+ gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]);
break;
case GFC_SS_INTRINSIC:
if (GFC_ARRAY_TYPE_P (base_type)
|| GFC_DESCRIPTOR_TYPE_P (base_type))
base_type = gfc_get_element_type (base_type);
- loop->temp_ss = gfc_get_ss ();
- loop->temp_ss->type = GFC_SS_TEMP;
- loop->temp_ss->data.temp.type = base_type;
- loop->temp_ss->string_length = dest->string_length;
- loop->temp_ss->data.temp.dimen = loop->dimen;
- loop->temp_ss->data.temp.codimen = loop->codimen;
- loop->temp_ss->next = gfc_ss_terminator;
+ loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length,
+ loop->dimen);
gfc_add_ss_to_loop (loop, loop->temp_ss);
}
else
mpz_t i;
mpz_init (i);
- for (n = 0; n < loop->dimen + loop->codimen; n++)
+ for (n = 0; n < loop->dimen; n++)
{
loopspec[n] = NULL;
dynamic[n] = false;
/* Set the extents of this range. */
cshape = loopspec[n]->shape;
- if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim])
+ if (cshape && INTEGER_CST_P (info->start[dim])
&& INTEGER_CST_P (info->stride[dim]))
{
loop->from[n] = info->start[dim];
size = 1 - lbound;
a.ubound[n] = specified_upper_bound;
a.stride[n] = stride;
- size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+ size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
stride = stride * size;
}
+ for (n = rank; n < rank+corank; n++)
+ (Set lcobound/ucobound as above.)
element_size = sizeof (array element);
+ if (!rank)
+ return element_size
stride = (size_t) stride;
overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
stride = stride * element_size;
static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
- gfc_expr ** lower, gfc_expr ** upper,
- stmtblock_t * pblock, tree * overflow)
+ gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
+ stmtblock_t * descriptor_block, tree * overflow)
{
tree type;
tree tmp;
/* Set the dtype. */
tmp = gfc_conv_descriptor_dtype (descriptor);
- gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
+ gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
or_expr = boolean_false_node;
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
- se.expr);
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
conv_lbound = se.expr;
/* Work out the offset for this component. */
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (pblock, descriptor,
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
conv_ubound = se.expr;
/* Store the stride. */
- gfc_conv_descriptor_stride_set (pblock, descriptor,
+ gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
gfc_rank_cst[n], stride);
/* Calculate size and check whether extent is negative. */
ubound = lower[n];
}
}
- gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
- se.expr);
+ gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
+ gfc_rank_cst[n], se.expr);
if (n < rank + corank - 1)
{
gcc_assert (ubound);
gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
gfc_add_block_to_block (pblock, &se.pre);
- gfc_conv_descriptor_ubound_set (pblock, descriptor,
+ gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
gfc_rank_cst[n], se.expr);
}
}
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
/* Convert to size_t. */
element_size = fold_convert (size_type_node, tmp);
+
+ if (rank == 0)
+ return element_size;
+
stride = fold_convert (size_type_node, stride);
/* First check for overflow. Since an array of type character can
/*GCC ARRAYS*/
bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+ tree errlen)
{
tree tmp;
tree pointer;
- tree offset;
+ tree offset = NULL_TREE;
+ tree token = NULL_TREE;
tree size;
tree msg;
- tree error;
+ tree error = NULL_TREE;
tree overflow; /* Boolean storing whether size calculation overflows. */
- tree var_overflow;
+ tree var_overflow = NULL_TREE;
tree cond;
+ tree set_descriptor;
+ stmtblock_t set_descriptor_block;
stmtblock_t elseblock;
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable_array, coarray;
+ bool allocatable, coarray, dimension;
ref = expr->ref;
if (!prev_ref)
{
- allocatable_array = expr->symtree->n.sym->attr.allocatable;
+ allocatable = expr->symtree->n.sym->attr.allocatable;
coarray = expr->symtree->n.sym->attr.codimension;
+ dimension = expr->symtree->n.sym->attr.dimension;
}
else
{
- allocatable_array = prev_ref->u.c.component->attr.allocatable;
+ allocatable = prev_ref->u.c.component->attr.allocatable;
coarray = prev_ref->u.c.component->attr.codimension;
+ dimension = prev_ref->u.c.component->attr.dimension;
}
- /* Return if this is a scalar coarray. */
- if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
- || (prev_ref && !prev_ref->u.c.component->attr.dimension))
- {
- gcc_assert (coarray);
- return false;
- }
+ if (!dimension)
+ gcc_assert (coarray);
/* Figure out the size of the array. */
switch (ref->u.ar.type)
}
overflow = integer_zero_node;
+
+ gfc_init_block (&set_descriptor_block);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
- &se->pre, &overflow);
+ &se->pre, &set_descriptor_block, &overflow);
+
+ if (dimension)
+ {
- var_overflow = gfc_create_var (integer_type_node, "overflow");
- gfc_add_modify (&se->pre, var_overflow, overflow);
+ var_overflow = gfc_create_var (integer_type_node, "overflow");
+ gfc_add_modify (&se->pre, var_overflow, overflow);
- /* Generate the block of code handling overflow. */
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
+ /* Generate the block of code handling overflow. */
+ msg = gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
("Integer overflow when calculating the amount of "
"memory to allocate"));
- error = build_call_expr_loc (input_location,
- gfor_fndecl_runtime_error, 1, msg);
+ error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
+ 1, msg);
+ }
- if (pstat != NULL_TREE && !integer_zerop (pstat))
+ if (status != NULL_TREE)
{
- /* Set the status variable if it's present. */
+ tree status_type = TREE_TYPE (status);
stmtblock_t set_status_block;
- tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
gfc_start_block (&set_status_block);
- gfc_add_modify (&set_status_block,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, pstat),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- pstat, build_int_cst (TREE_TYPE (pstat), 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ gfc_add_modify (&set_status_block, status,
+ build_int_cst (status_type, LIBERROR_ALLOCATION));
+ error = gfc_finish_block (&set_status_block);
}
gfc_start_block (&elseblock);
-
+
/* Allocate memory to store the data. */
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- /* The allocate_array variants take the old pointer as first argument. */
- if (allocatable_array)
- tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr);
- else
- tmp = gfc_allocate_with_status (&elseblock, size, pstat);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
- tmp);
+ if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ token = gfc_build_addr_expr (NULL_TREE,
+ gfc_conv_descriptor_token (se->expr));
- gfc_add_expr_to_block (&elseblock, tmp);
+ /* The allocatable variant takes the old pointer as first argument. */
+ if (allocatable)
+ gfc_allocate_allocatable (&elseblock, pointer, size, token,
+ status, errmsg, errlen, expr);
+ else
+ gfc_allocate_using_malloc (&elseblock, pointer, size, status);
- cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
- var_overflow, integer_zero_node));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- error, gfc_finish_block (&elseblock));
+ if (dimension)
+ {
+ cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, var_overflow, integer_zero_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ error, gfc_finish_block (&elseblock));
+ }
+ else
+ tmp = gfc_finish_block (&elseblock);
gfc_add_expr_to_block (&se->pre, tmp);
- gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
+ /* Update the array descriptors. */
+ if (dimension)
+ gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
+
+ set_descriptor = gfc_finish_block (&set_descriptor_block);
+ if (status != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, status,
+ build_int_cst (TREE_TYPE (status), 0));
+ gfc_add_expr_to_block (&se->pre,
+ fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ gfc_likely (cond), set_descriptor,
+ build_empty_stmt (input_location)));
+ }
+ else
+ gfc_add_expr_to_block (&se->pre, set_descriptor);
if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
&& expr->ts.u.derived->attr.alloc_comp)
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
- tree index;
+ tree index, range;
VEC(constructor_elt,gc) *v = NULL;
switch (expr->expr_type)
else
index = NULL_TREE;
+ if (mpz_cmp_si (c->repeat, 1) > 0)
+ {
+ tree tmp1, tmp2;
+ mpz_t maxval;
+
+ mpz_init (maxval);
+ mpz_add (maxval, c->offset, c->repeat);
+ mpz_sub_ui (maxval, maxval, 1);
+ tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->offset, 0) != 0)
+ {
+ mpz_add_ui (maxval, c->offset, 1);
+ tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
+ }
+ else
+ tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
+
+ range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2);
+ mpz_clear (maxval);
+ }
+ else
+ range = NULL;
+
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
case EXPR_STRUCTURE:
gfc_conv_structure (&se, c->expr, 1);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
-
default:
/* Catch those occasional beasts that do not simplify
for one reason or another, assuming that if they are
standard defying the frontend will catch them. */
gfc_conv_expr (&se, c->expr);
- CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
}
+
+ if (range == NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ else
+ {
+ if (index != NULL_TREE)
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
+ CONSTRUCTOR_APPEND_ELT (v, range, se.expr);
+ }
}
break;
gcc_assert (GFC_ARRAY_TYPE_P (type));
onstack = TREE_CODE (type) != POINTER_TYPE;
- gfc_start_block (&init);
+ gfc_init_block (&init);
/* Evaluate character string length. */
if (sym->ts.type == BT_CHARACTER
if (need_tmp)
{
- /* Tell the scalarizer to make a temporary. */
- loop.temp_ss = gfc_get_ss ();
- loop.temp_ss->type = GFC_SS_TEMP;
- loop.temp_ss->next = gfc_ss_terminator;
-
- if (expr->ts.type == BT_CHARACTER
- && !expr->ts.u.cl->backend_decl)
+ if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl)
get_array_charlen (expr, se);
- loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
-
- if (expr->ts.type == BT_CHARACTER)
- loop.temp_ss->string_length = expr->ts.u.cl->backend_decl;
- else
- loop.temp_ss->string_length = NULL;
+ /* Tell the scalarizer to make a temporary. */
+ loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts),
+ ((expr->ts.type == BT_CHARACTER)
+ ? expr->ts.u.cl->backend_decl
+ : NULL),
+ loop.dimen);
se->string_length = loop.temp_ss->string_length;
- loop.temp_ss->data.temp.dimen = loop.dimen;
- loop.temp_ss->data.temp.codimen = loop.codimen;
+ gcc_assert (loop.temp_ss->data.temp.dimen == loop.dimen);
gfc_add_ss_to_loop (&loop, loop.temp_ss);
}
lse.string_length = rse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
- expr->expr_type == EXPR_VARIABLE, true);
+ expr->expr_type == EXPR_VARIABLE
+ || expr->expr_type == EXPR_ARRAY, true);
gfc_add_expr_to_block (&block, tmp);
/* Finish the copying loops. */
tree to;
tree base;
+ ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
+
+ if (se->want_coarray)
+ {
+ gfc_array_ref *ar = &info->ref->u.ar;
+
+ codim = gfc_get_corank (expr);
+ for (n = ss->data.info.dimen; n < ss->data.info.dimen + codim - 1;
+ n++)
+ {
+ /* Make sure we are not lost somehow. */
+ gcc_assert (ar->dimen_type[n] == DIMEN_THIS_IMAGE);
+
+ /* Make sure the call to gfc_conv_section_startstride won't
+ generate unnecessary code to calculate stride. */
+ gcc_assert (ar->stride[n] == NULL);
+
+ gfc_conv_section_startstride (&loop, ss, n);
+ loop.from[n] = info->start[n];
+ loop.to[n] = info->end[n];
+ }
+
+ gcc_assert (n == ss->data.info.dimen + codim - 1);
+ evaluate_bound (&loop.pre, info->start, ar->start,
+ info->descriptor, n, true);
+ loop.from[n] = info->start[n];
+ }
+ else
+ codim = 0;
+
/* Set the string_length for a character array. */
if (expr->ts.type == BT_CHARACTER)
se->string_length = gfc_get_expr_charlen (expr);
{
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
- loop.codimen, loop.from,
- loop.to, 0,
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim,
+ loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
}
else
base = NULL_TREE;
- ndim = info->ref ? info->ref->u.ar.dimen : info->dimen;
- codim = info->codimen;
for (n = 0; n < ndim; n++)
{
stride = gfc_conv_array_stride (desc, n);
for (n = ndim; n < ndim + codim; n++)
{
- /* look for the corresponding scalarizer dimension: dim. */
- for (dim = 0; dim < ndim + codim; dim++)
- if (info->dim[dim] == n)
- break;
-
- /* loop exited early: the DIM being looked for has been found. */
- gcc_assert (dim < ndim + codim);
-
- from = loop.from[dim];
- to = loop.to[dim];
+ from = loop.from[n];
+ to = loop.to[n];
gfc_conv_descriptor_lbound_set (&loop.pre, parm,
- gfc_rank_cst[dim], from);
+ gfc_rank_cst[n], from);
if (n < ndim + codim - 1)
gfc_conv_descriptor_ubound_set (&loop.pre, parm,
- gfc_rank_cst[dim], to);
- dim++;
+ gfc_rank_cst[n], to);
}
if (se->data_not_needed)
gfc_add_expr_to_block (&block, tmp);
}
- tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3,
dest, src, size);
}
/* We know the temporary and the value will be the same length,
so can use memcpy. */
- tmp = built_in_decls[BUILT_IN_MEMCPY];
+ tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location,
tmp, 3, gfc_conv_descriptor_data_get (dest),
gfc_conv_descriptor_data_get (src), size);
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
- if (c->attr.allocatable && c->attr.dimension)
+ if (cmp_has_alloc_comps && !c->attr.pointer)
+ {
+ /* Do not deallocate the components of ultimate pointer
+ components. */
+ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
+ decl, cdecl, NULL_TREE);
+ rank = c->as ? c->as->rank : 0;
+ tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
+ rank, purpose);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+
+ if (c->attr.allocatable
+ && (c->attr.dimension || c->attr.codimension))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- if (cmp_has_alloc_comps && !c->attr.pointer)
- {
- /* Do not deallocate the components of ultimate pointer
- components. */
- tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- c->as->rank, purpose);
- gfc_add_expr_to_block (&fnblock, tmp);
- }
tmp = gfc_trans_dealloc_allocated (comp);
gfc_add_expr_to_block (&fnblock, tmp);
}
case NULLIFY_ALLOC_COMP:
if (c->attr.pointer)
continue;
- else if (c->attr.allocatable && c->attr.dimension)
+ else if (c->attr.allocatable
+ && (c->attr.dimension|| c->attr.codimension))
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
in the array reference - (*desc.data)[<element>]. */
gfc_init_block (&realloc_block);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_REALLOC], 2,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
fold_convert (pvoid_type_node, array1),
size2);
gfc_conv_descriptor_data_set (&realloc_block,
/* Malloc expression. */
gfc_init_block (&alloc_block);
tmp = build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- size2);
+ builtin_decl_explicit (BUILT_IN_MALLOC),
+ 1, size2);
gfc_conv_descriptor_data_set (&alloc_block,
desc, tmp);
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_expr_to_block (&cleanup, tmp);
}
- if (sym->attr.allocatable && sym->attr.dimension
+ if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
&& !sym->attr.save && !sym->attr.result)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);
{
if (ref->type == REF_SUBSTRING)
{
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ref->u.ss.start;
- newss->next = ss;
- ss = newss;
-
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ref->u.ss.end;
- newss->next = ss;
- ss = newss;
+ ss = gfc_get_scalar_ss (ss, ref->u.ss.start);
+ ss = gfc_get_scalar_ss (ss, ref->u.ss.end);
}
/* We're only interested in array sections from now on. */
ar = &ref->u.ar;
- if (ar->as->rank == 0 && ref->next != NULL)
- {
- /* Scalar coarray. */
- continue;
- }
-
switch (ar->type)
{
case AR_ELEMENT:
- for (n = 0; n < ar->dimen + ar->codimen; n++)
- {
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
- newss->expr = ar->start[n];
- newss->next = ss;
- ss = newss;
- }
+ for (n = ar->dimen + ar->codimen - 1; n >= 0; n--)
+ ss = gfc_get_scalar_ss (ss, ar->start[n]);
break;
case AR_FULL:
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SECTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = ar->as->rank;
- newss->data.info.codimen = 0;
+ newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
newss->data.info.ref = ref;
/* Make sure array is the same as array(:,:), this way
we don't need to special case all the time. */
ar->dimen = ar->as->rank;
- ar->codimen = 0;
for (n = 0; n < ar->dimen; n++)
{
- newss->data.info.dim[n] = n;
ar->dimen_type[n] = DIMEN_RANGE;
gcc_assert (ar->start[n] == NULL);
gcc_assert (ar->end[n] == NULL);
gcc_assert (ar->stride[n] == NULL);
}
- for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++)
- {
- newss->data.info.dim[n] = n;
- ar->dimen_type[n] = DIMEN_RANGE;
-
- gcc_assert (ar->start[n] == NULL);
- gcc_assert (ar->end[n] == NULL);
- }
ss = newss;
break;
case AR_SECTION:
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SECTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = 0;
- newss->data.info.codimen = 0;
+ newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION);
newss->data.info.ref = ref;
- /* We add SS chains for all the subscripts in the section. */
- for (n = 0; n < ar->dimen + ar->codimen; n++)
+ /* We add SS chains for all the subscripts in the section. */
+ for (n = 0; n < ar->dimen; n++)
{
gfc_ss *indexss;
switch (ar->dimen_type[n])
{
- case DIMEN_THIS_IMAGE:
- continue;
case DIMEN_ELEMENT:
/* Add SS for elemental (scalar) subscripts. */
gcc_assert (ar->start[n]);
- indexss = gfc_get_ss ();
- indexss->type = GFC_SS_SCALAR;
- indexss->expr = ar->start[n];
- indexss->next = gfc_ss_terminator;
+ indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]);
indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
break;
case DIMEN_RANGE:
/* We don't add anything for sections, just remember this
dimension for later. */
- newss->data.info.dim[newss->data.info.dimen
- + newss->data.info.codimen] = n;
- if (n < ar->dimen)
- newss->data.info.dimen++;
+ newss->data.info.dim[newss->data.info.dimen] = n;
+ newss->data.info.dimen++;
break;
case DIMEN_VECTOR:
/* Create a GFC_SS_VECTOR index in which we can store
the vector's descriptor. */
- indexss = gfc_get_ss ();
- indexss->type = GFC_SS_VECTOR;
- indexss->expr = ar->start[n];
- indexss->next = gfc_ss_terminator;
+ indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n],
+ 1, GFC_SS_VECTOR);
indexss->loop_chain = gfc_ss_terminator;
newss->data.info.subscript[n] = indexss;
- newss->data.info.dim[newss->data.info.dimen
- + newss->data.info.codimen] = n;
- if (n < ar->dimen)
- newss->data.info.dimen++;
+ newss->data.info.dim[newss->data.info.dimen] = n;
+ newss->data.info.dimen++;
break;
default:
{
gfc_ss *head;
gfc_ss *head2;
- gfc_ss *newss;
head = gfc_walk_subexpr (ss, expr->value.op.op1);
if (expr->value.op.op2 == NULL)
/* One of the operands needs scalarization, the other is scalar.
Create a gfc_ss for the scalar expression. */
- newss = gfc_get_ss ();
- newss->type = GFC_SS_SCALAR;
if (head == ss)
{
/* First operand is scalar. We build the chain in reverse order, so
head = head->next;
/* Check we haven't somehow broken the chain. */
gcc_assert (head);
- newss->next = ss;
- head->next = newss;
- newss->expr = expr->value.op.op1;
+ head->next = gfc_get_scalar_ss (ss, expr->value.op.op1);
}
else /* head2 == head */
{
gcc_assert (head2 == head);
/* Second operand is scalar. */
- newss->next = head2;
- head2 = newss;
- newss->expr = expr->value.op.op2;
+ head2 = gfc_get_scalar_ss (head2, expr->value.op.op2);
}
return head2;
if (newss == head)
{
/* Scalar argument. */
- newss = gfc_get_ss ();
+ gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE);
+ newss = gfc_get_scalar_ss (head, arg->expr);
newss->type = type;
- newss->expr = arg->expr;
- newss->next = head;
}
else
scalar = 0;
static gfc_ss *
gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
gfc_intrinsic_sym *isym;
gfc_symbol *sym;
gfc_component *comp = NULL;
- int n;
isym = expr->value.function.isym;
gfc_is_proc_ptr_comp (expr, &comp);
if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension)
|| (comp && comp->attr.dimension))
- {
- newss = gfc_get_ss ();
- newss->type = GFC_SS_FUNCTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
- for (n = 0; n < newss->data.info.dimen; n++)
- newss->data.info.dim[n] = n;
- return newss;
- }
+ return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
/* Walk the parameters of an elemental function. For now we always pass
by reference. */
static gfc_ss *
gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
- int n;
-
- newss = gfc_get_ss ();
- newss->type = GFC_SS_CONSTRUCTOR;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
- for (n = 0; n < expr->rank; n++)
- newss->data.info.dim[n] = n;
-
- return newss;
+ return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR);
}
OSDN Git Service
