/* Array translation routines
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "gimple.h"
-#include "ggc.h"
#include "toplev.h"
-#include "real.h"
#include "flags.h"
#include "gfortran.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
/* Initialize the descriptor. */
type =
- gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
+ gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
of array constructor C. */
static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
+ gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_init (val);
dynamic = false;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor * c,
+ tree desc, gfc_constructor_base base,
tree * poffset, tree * offsetvar,
bool dynamic)
{
stmtblock_t body;
gfc_se se;
mpz_t size;
+ gfc_constructor *c;
tree shadow_loopvar = NULL_TREE;
gfc_saved_var saved_loopvar;
mpz_init (size);
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
- p = p->next;
+ p = gfc_constructor_next (p);
n++;
}
if (n < 4)
else
{
/* Collect multiple scalar constants into a constructor. */
- tree list;
+ VEC(constructor_elt,gc) *v = NULL;
tree init;
tree bound;
tree tmptype;
HOST_WIDE_INT idx = 0;
p = c;
- list = NULL_TREE;
/* Count the number of consecutive scalar constants. */
while (p && !(p->iterator
|| p->expr->expr_type != EXPR_CONSTANT))
(gfc_get_pchar_type (p->expr->ts.kind),
se.expr);
- list = tree_cons (build_int_cst (gfc_array_index_type,
- idx++), se.expr, list);
+ CONSTRUCTOR_APPEND_ELT (v,
+ build_int_cst (gfc_array_index_type,
+ idx++),
+ se.expr);
c = p;
- p = p->next;
+ p = gfc_constructor_next (p);
}
bound = build_int_cst (NULL_TREE, n - 1);
gfc_index_zero_node, bound);
tmptype = build_array_type (type, tmptype);
- init = build_constructor_from_list (tmptype, nreverse (list));
+ init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
/* Create a static variable to hold the data. */
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
+ gfc_constructor *c;
bool is_const;
-
+
is_const = TRUE;
- if (c == NULL)
+ if (gfc_constructor_first (base) == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
/* Loop over all constructor elements to find out is_const, but in len we
want to store the length of the first, not the last, element. We can
of course exit the loop as soon as is_const is found to be false. */
- for (; c && is_const; c = c->next)
+ for (c = gfc_constructor_first (base);
+ c && is_const; c = gfc_constructor_next (c))
{
switch (c->expr->expr_type)
{
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor * c)
+gfc_constant_array_constructor_p (gfc_constructor_base base)
{
unsigned HOST_WIDE_INT nelem = 0;
+ gfc_constructor *c = gfc_constructor_first (base);
while (c)
{
if (c->iterator
|| c->expr->rank > 0
|| c->expr->expr_type != EXPR_CONSTANT)
return 0;
- c = c->next;
+ c = gfc_constructor_next (c);
nelem++;
}
return nelem;
tree
gfc_build_constant_array_constructor (gfc_expr * expr, tree type)
{
- tree tmptype, list, init, tmp;
+ tree tmptype, init, tmp;
HOST_WIDE_INT nelem;
gfc_constructor *c;
gfc_array_spec as;
gfc_se se;
int i;
+ VEC(constructor_elt,gc) *v = NULL;
/* First traverse the constructor list, converting the constants
to tree to build an initializer. */
nelem = 0;
- list = NULL_TREE;
- c = expr->value.constructor;
+ c = gfc_constructor_first (expr->value.constructor);
while (c)
{
gfc_init_se (&se, NULL);
else if (POINTER_TYPE_P (type))
se.expr = gfc_build_addr_expr (gfc_get_pchar_type (c->expr->ts.kind),
se.expr);
- list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
- se.expr, list);
- c = c->next;
+ CONSTRUCTOR_APPEND_ELT (v, build_int_cst (gfc_array_index_type, nelem),
+ se.expr);
+ c = gfc_constructor_next (c);
nelem++;
}
as.type = AS_EXPLICIT;
if (!expr->shape)
{
- as.lower[0] = gfc_int_expr (0);
- as.upper[0] = gfc_int_expr (nelem - 1);
+ as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, nelem - 1);
}
else
for (i = 0; i < expr->rank; i++)
{
int tmp = (int) mpz_get_si (expr->shape[i]);
- as.lower[i] = gfc_int_expr (0);
- as.upper[i] = gfc_int_expr (tmp - 1);
+ as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, tmp - 1);
}
tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
- init = build_constructor_from_list (tmptype, nreverse (list));
+ init = build_constructor (tmptype, v);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
- gfc_constructor *c;
+ gfc_constructor_base c;
tree offset;
tree offsetvar;
tree desc;
break;
case GFC_SS_REFERENCE:
- /* Scalar reference. Evaluate this now. */
+ /* Scalar argument to elemental procedure. Evaluate this
+ now. */
gfc_init_se (&se, NULL);
- gfc_conv_expr_reference (&se, ss->expr);
+ gfc_conv_expr (&se, ss->expr);
gfc_add_block_to_block (&loop->pre, &se.pre);
gfc_add_block_to_block (&loop->post, &se.post);
&& se->loop->ss->loop_chain->expr->symtree)
name = se->loop->ss->loop_chain->expr->symtree->name;
- if (!name && se->loop && se->loop->ss && se->loop->ss->loop_chain
- && se->loop->ss->loop_chain->expr->symtree)
- name = se->loop->ss->loop_chain->expr->symtree->name;
-
if (!name && se->loop && se->loop->ss && se->loop->ss->expr)
{
if (se->loop->ss->expr->expr_type == EXPR_FUNCTION
name = "unnamed constant";
}
+ if (TREE_CODE (descriptor) == VAR_DECL)
+ name = IDENTIFIER_POINTER (DECL_NAME (descriptor));
+
/* If upper bound is present, include both bounds in the error message. */
if (check_upper)
{
index = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ ar->as->type != AS_ASSUMED_SIZE
+ || dim < ar->dimen - 1);
break;
case DIMEN_VECTOR:
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 = gfc_trans_array_bound_check (se, info->descriptor,
index, dim, &ar->where,
- (ar->as->type != AS_ASSUMED_SIZE
- && !ar->as->cp_was_assumed) || dim < ar->dimen - 1);
+ ar->as->type != AS_ASSUMED_SIZE
+ || dim < ar->dimen - 1);
break;
case DIMEN_RANGE:
gfc_se indexse;
gfc_se tmpse;
+ if (ar->dimen == 0)
+ return;
+
/* Handle scalarized references separately. */
if (ar->type != AR_ELEMENT)
{
/* Upper bound, but not for the last dimension of assumed-size
arrays. */
- if (n < ar->dimen - 1
- || (ar->as->type != AS_ASSUMED_SIZE && !ar->as->cp_was_assumed))
+ if (n < ar->dimen - 1 || ar->as->type != AS_ASSUMED_SIZE)
{
tmp = gfc_conv_array_ubound (se->expr, n);
if (sym->attr.temporary)
continue;
if (dim == info->ref->u.ar.dimen - 1
- && (info->ref->u.ar.as->type == AS_ASSUMED_SIZE
- || info->ref->u.ar.as->cp_was_assumed))
+ && info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
check_upper = false;
else
check_upper = true;
if (size[n])
{
tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]);
- asprintf (&msg, "%s, size mismatch for dimension %d "
- "of array '%s' (%%ld/%%ld)", gfc_msg_bounds,
+ asprintf (&msg, "Array bound mismatch for dimension %d "
+ "of array '%s' (%%ld/%%ld)",
info->dim[n]+1, ss->expr->symtree->name);
+
gfc_trans_runtime_check (true, false, tmp3, &inner,
&ss->expr->where, msg,
fold_convert (long_integer_type_node, tmp),
fold_convert (long_integer_type_node, size[n]));
+
gfc_free (msg);
}
else
tree tmp;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
- gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
if (ss->type == GFC_SS_CONSTRUCTOR)
{
+ gfc_constructor_base base;
/* An unknown size constructor will always be rank one.
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
can be determined at compile time. Prefer not to otherwise,
since the general case involves realloc, and it's better to
avoid that overhead if possible. */
- c = ss->expr->value.constructor;
- dynamic[n] = gfc_get_array_constructor_size (&i, c);
+ base = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, base);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
/*GCC ARRAYS*/
static tree
-gfc_array_init_size (tree descriptor, int rank, tree * poffset,
+gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper,
stmtblock_t * pblock)
{
stride = gfc_evaluate_now (stride, pblock);
}
+ for (n = rank; n < rank + corank; n++)
+ {
+ ubound = upper[n];
+
+ /* Set lower bound. */
+ gfc_init_se (&se, NULL);
+ if (lower == NULL || lower[n] == NULL)
+ {
+ gcc_assert (n == rank + corank - 1);
+ se.expr = gfc_index_one_node;
+ }
+ else
+ {
+ if (ubound || n == rank + corank - 1)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
+ }
+ gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
+ se.expr);
+
+ if (n < rank + corank - 1)
+ {
+ gfc_init_se (&se, NULL);
+ 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_rank_cst[n], se.expr);
+ }
+ }
+
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable_array;
+ bool allocatable_array, coarray;
ref = expr->ref;
/* Find the last reference in the chain. */
while (ref && ref->next != NULL)
{
- gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
+ gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT
+ || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
prev_ref = ref;
ref = ref->next;
}
return false;
if (!prev_ref)
- allocatable_array = expr->symtree->n.sym->attr.allocatable;
+ {
+ allocatable_array = expr->symtree->n.sym->attr.allocatable;
+ coarray = expr->symtree->n.sym->attr.codimension;
+ }
else
- allocatable_array = prev_ref->u.c.component->attr.allocatable;
+ {
+ allocatable_array = prev_ref->u.c.component->attr.allocatable;
+ coarray = prev_ref->u.c.component->attr.codimension;
+ }
+
+ /* 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;
+ }
/* Figure out the size of the array. */
switch (ref->u.ar.type)
{
case AR_ELEMENT:
- lower = NULL;
- upper = ref->u.ar.start;
+ if (!coarray)
+ {
+ lower = NULL;
+ upper = ref->u.ar.start;
+ break;
+ }
+ /* Fall through. */
+
+ case AR_SECTION:
+ lower = ref->u.ar.start;
+ upper = ref->u.ar.end;
break;
case AR_FULL:
upper = ref->u.ar.as->upper;
break;
- case AR_SECTION:
- lower = ref->u.ar.start;
- upper = ref->u.ar.end;
- break;
-
default:
gcc_unreachable ();
break;
}
- size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
- lower, upper, &se->pre);
+ size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
+ ref->u.ar.as->corank, &offset, lower, upper,
+ &se->pre);
/* Allocate memory to store the data. */
pointer = gfc_conv_descriptor_data_get (se->expr);
{
gfc_constructor *c;
tree tmp;
- mpz_t maxval;
gfc_se se;
HOST_WIDE_INT hi;
unsigned HOST_WIDE_INT lo;
- tree index, range;
+ tree index;
VEC(constructor_elt,gc) *v = NULL;
switch (expr->expr_type)
case EXPR_ARRAY:
/* Create a vector of all the elements. */
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (c->iterator)
{
gfc_option.flag_max_array_constructor);
return NULL_TREE;
}
- if (mpz_cmp_si (c->n.offset, 0) != 0)
- index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->offset, 0) != 0)
+ index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
- mpz_init (maxval);
- if (mpz_cmp_si (c->repeat, 0) != 0)
- {
- tree tmp1, tmp2;
-
- mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->n.offset, maxval);
- mpz_sub_ui (maxval, maxval, 1);
- tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- if (mpz_cmp_si (c->n.offset, 0) != 0)
- {
- mpz_add_ui (maxval, c->n.offset, 1);
- tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- }
- else
- tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
-
- range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
- }
- else
- range = NULL;
- mpz_clear (maxval);
gfc_init_se (&se, NULL);
switch (c->expr->expr_type)
{
case EXPR_CONSTANT:
gfc_conv_constant (&se, c->expr);
- 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);
- }
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
case EXPR_STRUCTURE:
for one reason or another, assuming that if they are
standard defying the frontend will catch them. */
gfc_conv_expr (&se, c->expr);
- 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);
- }
+ CONSTRUCTOR_APPEND_ELT (v, index, se.expr);
break;
}
}
{
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
+ tree temp;
- tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- ubound, lbound);
- stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ temp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ ubound, lbound);
+ temp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, temp);
+
+ stride2 = fold_build2 (MINUS_EXPR, gfc_array_index_type,
dubound, dlbound);
- tmp = fold_build2 (NE_EXPR, gfc_array_index_type, tmp, stride2);
- asprintf (&msg, "%s for dimension %d of array '%s'",
- gfc_msg_bounds, n+1, sym->name);
- gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg);
+ stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, stride2);
+
+ tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2);
+ asprintf (&msg, "Dimension %d of array '%s' has extent "
+ "%%ld instead of %%ld", n+1, sym->name);
+
+ gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg,
+ fold_convert (long_integer_type_node, temp),
+ fold_convert (long_integer_type_node, stride2));
+
gfc_free (msg);
}
}
lse.string_length = rse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
- expr->expr_type == EXPR_VARIABLE);
+ expr->expr_type == EXPR_VARIABLE, true);
gfc_add_expr_to_block (&block, tmp);
/* Finish the copying loops. */
gfc_trans_scalarizing_loops (&loop, &block);
desc = loop.temp_ss->data.info.descriptor;
-
- gcc_assert (is_gimple_lvalue (desc));
}
else if (expr->expr_type == EXPR_FUNCTION)
{
{
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
- parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
+ parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
/* TODO: Optimize passing g77 arrays. */
void
-gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
+gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
const gfc_symbol *fsym, const char *proc_name,
tree *size)
{
bool full_array_var;
bool this_array_result;
bool contiguous;
+ bool no_pack;
+ bool array_constructor;
+ bool good_allocatable;
+ bool ultimate_ptr_comp;
+ bool ultimate_alloc_comp;
gfc_symbol *sym;
stmtblock_t block;
gfc_ref *ref;
+ ultimate_ptr_comp = false;
+ ultimate_alloc_comp = false;
for (ref = expr->ref; ref; ref = ref->next)
- if (ref->next == NULL)
- break;
+ {
+ if (ref->next == NULL)
+ break;
+
+ if (ref->type == REF_COMPONENT)
+ {
+ ultimate_ptr_comp = ref->u.c.component->attr.pointer;
+ ultimate_alloc_comp = ref->u.c.component->attr.allocatable;
+ }
+ }
full_array_var = false;
contiguous = false;
- if (expr->expr_type == EXPR_VARIABLE && ref)
+ if (expr->expr_type == EXPR_VARIABLE && ref && !ultimate_ptr_comp)
full_array_var = gfc_full_array_ref_p (ref, &contiguous);
sym = full_array_var ? expr->symtree->n.sym : NULL;
if (sym->ts.type == BT_CHARACTER)
se->string_length = sym->ts.u.cl->backend_decl;
- if (sym->ts.type == BT_DERIVED && !sym->as)
+ if (sym->ts.type == BT_DERIVED)
{
gfc_conv_expr_descriptor (se, expr, ss);
se->expr = gfc_conv_array_data (se->expr);
return;
}
- if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE
- && !sym->attr.allocatable)
+ if (!sym->attr.pointer
+ && sym->as
+ && sym->as->type != AS_ASSUMED_SHAPE
+ && !sym->attr.allocatable)
{
/* Some variables are declared directly, others are declared as
pointers and allocated on the heap. */
}
}
- if (contiguous && g77 && !this_array_result
- && !expr->symtree->n.sym->attr.dummy)
+ /* A convenient reduction in scope. */
+ contiguous = g77 && !this_array_result && contiguous;
+
+ /* There is no need to pack and unpack the array, if it is contiguous
+ and not deferred or assumed shape. */
+ no_pack = ((sym && sym->as
+ && !sym->attr.pointer
+ && sym->as->type != AS_DEFERRED
+ && sym->as->type != AS_ASSUMED_SHAPE)
+ ||
+ (ref && ref->u.ar.as
+ && ref->u.ar.as->type != AS_DEFERRED
+ && ref->u.ar.as->type != AS_ASSUMED_SHAPE));
+
+ no_pack = contiguous && no_pack;
+
+ /* Array constructors are always contiguous and do not need packing. */
+ array_constructor = g77 && !this_array_result && expr->expr_type == EXPR_ARRAY;
+
+ /* Same is true of contiguous sections from allocatable variables. */
+ good_allocatable = contiguous
+ && expr->symtree
+ && expr->symtree->n.sym->attr.allocatable;
+
+ /* Or ultimate allocatable components. */
+ ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
+
+ if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
{
gfc_conv_expr_descriptor (se, expr, ss);
if (expr->ts.type == BT_CHARACTER)
{
desc = se->expr;
/* Repack the array. */
-
if (gfc_option.warn_array_temp)
{
if (fsym)
/* Get the descriptor type. */
type = TREE_TYPE (sym->backend_decl);
-
+
if (sym_has_alloc_comp && !(sym->attr.pointer || sym->attr.allocatable))
{
- if (!sym->attr.save)
+ if (!sym->attr.save
+ && !(TREE_STATIC (sym->backend_decl) && sym->attr.is_main_program))
{
- rank = sym->as ? sym->as->rank : 0;
- tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
- gfc_add_expr_to_block (&fnblock, tmp);
- if (sym->value)
+ if (sym->value == NULL
+ || !gfc_has_default_initializer (sym->ts.u.derived))
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank);
+ gfc_add_expr_to_block (&fnblock, tmp);
+ }
+ else
{
- tmp = gfc_init_default_dt (sym, NULL);
+ tmp = gfc_init_default_dt (sym, NULL, false);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
continue;
ar = &ref->u.ar;
+
+ if (ar->as->rank == 0)
+ {
+ /* Scalar coarray. */
+ continue;
+ }
+
switch (ar->type)
{
case AR_ELEMENT:
OSDN Git Service
