for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
{
loop->order[n] = n;
- loop->reverse[n] = GFC_CANNOT_REVERSE;
+ loop->reverse[n] = GFC_INHIBIT_REVERSE;
}
loop->ss = gfc_ss_terminator;
gfc_se tmpse;
if (ar->dimen == 0)
- return;
+ {
+ gcc_assert (ar->codimen);
+
+ 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. */
+ se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
+ se->expr);
+ }
+
+ return;
+ }
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
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;
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
{
tree tmp;
tree pointer;
- tree offset;
+ tree offset = 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;
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)
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &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))
{
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);
+ if (allocatable)
+ tmp = gfc_allocate_allocatable_with_status (&elseblock,
+ pointer, size, pstat, expr);
else
- tmp = gfc_allocate_with_status (&elseblock, size, pstat);
+ tmp = gfc_allocate_with_status (&elseblock, size, pstat, false);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
tmp);
gfc_add_expr_to_block (&elseblock, tmp);
- 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);
+ if (dimension)
+ gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
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;
}
+/* Generate code to evaluate non-constant coarray cobounds. */
+
+void
+gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
+ const gfc_symbol *sym)
+{
+ int dim;
+ tree ubound;
+ tree lbound;
+ gfc_se se;
+ gfc_array_spec *as;
+
+ as = sym->as;
+
+ for (dim = as->rank; dim < as->rank + as->corank; dim++)
+ {
+ /* Evaluate non-constant array bound expressions. */
+ lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
+ if (as->lower[dim] && !INTEGER_CST_P (lbound))
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_modify (pblock, lbound, se.expr);
+ }
+ ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
+ if (as->upper[dim] && !INTEGER_CST_P (ubound))
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ gfc_add_modify (pblock, ubound, se.expr);
+ }
+ }
+}
+
+
/* Generate code to evaluate non-constant array bounds. Sets *poffset and
returns the size (in elements) of the array. */
size = stride;
}
- for (dim = as->rank; dim < as->rank + as->corank; dim++)
- {
- /* Evaluate non-constant array bound expressions. */
- lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
- if (as->lower[dim] && !INTEGER_CST_P (lbound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, lbound, se.expr);
- }
- ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
- if (as->upper[dim] && !INTEGER_CST_P (ubound))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- gfc_add_modify (pblock, ubound, se.expr);
- }
- }
+
+ gfc_trans_array_cobounds (type, pblock, sym);
gfc_trans_vla_type_sizes (sym, pblock);
*poffset = offset;
}
}
+ gfc_trans_array_cobounds (type, &init, sym);
+
/* Set the offset. */
if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset);
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. */
switch (purpose)
{
case DEALLOCATE_ALLOC_COMP:
+ 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)
{
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);
}
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);
ar = &ref->u.ar;
- if (ar->as->rank == 0)
+ if (ar->as->rank == 0 && ref->next != NULL)
{
/* Scalar coarray. */
continue;
OSDN Git Service
