/* 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 "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;
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)
list = tree_cons (build_int_cst (gfc_array_index_type,
idx++), se.expr, list);
c = p;
- p = p->next;
+ p = gfc_constructor_next (p);
}
bound = build_int_cst (NULL_TREE, n - 1);
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;
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);
se.expr);
list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
se.expr, list);
- c = c->next;
+ 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);
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;
&& 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 (descriptor->base.code != COMPONENT_REF)
+ 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;
/* 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;
}
if (ref == NULL || ref->type != REF_ARRAY)
return false;
+ /* Return if this is a scalar coarray. */
+ if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
+ {
+ gcc_assert (expr->symtree->n.sym->attr.codimension);
+ return false;
+ }
+ else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
+ {
+ gcc_assert (prev_ref->u.c.component->attr.codimension);
+ return false;
+ }
+
if (!prev_ref)
allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
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);
tree tmp1, tmp2;
mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->n.offset, maxval);
+ mpz_add (maxval, c->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)
+ if (mpz_cmp_si (c->offset, 0) != 0)
{
- mpz_add_ui (maxval, c->n.offset, 1);
+ 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->n.offset, gfc_index_integer_kind);
+ tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
{
/* 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. */
}
+/* Check for default initializer; sym->value is not enough as it is also
+ set for EXPR_NULL of allocatables. */
+
+static bool
+has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+
+ gcc_assert (der->attr.flavor == FL_DERIVED);
+ for (c = der->components; c; c = c->next)
+ if ((c->ts.type != BT_DERIVED && c->initializer)
+ || (c->ts.type == BT_DERIVED
+ && (!c->attr.pointer && has_default_initializer (c->ts.u.derived))))
+ break;
+
+ return c != NULL;
+}
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
/* 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 || !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
