/* Array things
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "match.h"
-/* This parameter is the size of the largest array constructor that we
- will expand to an array constructor without iterators.
- Constructors larger than this will remain in the iterator form. */
-
-#define GFC_MAX_AC_EXPAND 65535
-
-
/**************** Array reference matching subroutines *****************/
/* Copy an array reference structure. */
if (as == NULL)
return;
- for (i = 0; i < as->rank; i++)
+ for (i = 0; i < as->rank + as->corank; i++)
{
gfc_free_expr (as->lower[i]);
gfc_free_expr (as->upper[i]);
/* Take an array bound, resolves the expression, that make up the
shape and check associated constraints. */
-static try
+static gfc_try
resolve_array_bound (gfc_expr *e, int check_constant)
{
if (e == NULL)
/* Takes an array specification, resolves the expressions that make up
the shape and make sure everything is integral. */
-try
+gfc_try
gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
{
gfc_expr *e;
if (as == NULL)
return SUCCESS;
- for (i = 0; i < as->rank; i++)
+ for (i = 0; i < as->rank + as->corank; i++)
{
e = as->lower[i];
if (resolve_array_bound (e, check_constant) == FAILURE)
gfc_expr **upper, **lower;
match m;
- lower = &as->lower[as->rank - 1];
- upper = &as->upper[as->rank - 1];
+ lower = &as->lower[as->rank + as->corank - 1];
+ upper = &as->upper[as->rank + as->corank - 1];
if (gfc_match_char ('*') == MATCH_YES)
{
gfc_error ("Expected expression in array specification at %C");
if (m != MATCH_YES)
return AS_UNKNOWN;
+ if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
+ return AS_UNKNOWN;
if (gfc_match_char (':') == MATCH_NO)
{
return AS_UNKNOWN;
if (m == MATCH_NO)
return AS_ASSUMED_SHAPE;
+ if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
+ return AS_UNKNOWN;
return AS_EXPLICIT;
}
/* Matches an array specification, incidentally figuring out what sort
- it is. */
+ it is. Match either a normal array specification, or a coarray spec
+ or both. Optionally allow [:] for coarrays. */
match
-gfc_match_array_spec (gfc_array_spec **asp)
+gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
{
array_type current_type;
gfc_array_spec *as;
int i;
-
- if (gfc_match_char ('(') != MATCH_YES)
- {
- *asp = NULL;
- return MATCH_NO;
- }
-
+
as = gfc_get_array_spec ();
+ as->corank = 0;
+ as->rank = 0;
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
{
as->upper[i] = NULL;
}
- as->rank = 1;
+ if (!match_dim)
+ goto coarray;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ if (!match_codim)
+ goto done;
+ goto coarray;
+ }
for (;;)
{
+ as->rank++;
current_type = match_array_element_spec (as);
if (as->rank == 1)
goto cleanup;
}
- if (as->rank >= GFC_MAX_DIMENSIONS)
+ if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("Array specification at %C has more than %d dimensions",
GFC_MAX_DIMENSIONS);
goto cleanup;
}
- if (as->rank >= 7
+ if (as->corank + as->rank >= 7
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
"specification at %C with more than 7 dimensions")
== FAILURE)
goto cleanup;
+ }
- as->rank++;
+ if (!match_codim)
+ goto done;
+
+coarray:
+ if (gfc_match_char ('[') != MATCH_YES)
+ goto done;
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
+ == FAILURE)
+ goto cleanup;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ goto cleanup;
+ }
+
+ for (;;)
+ {
+ as->corank++;
+ current_type = match_array_element_spec (as);
+
+ if (current_type == AS_UNKNOWN)
+ goto cleanup;
+
+ if (as->corank == 1)
+ as->cotype = current_type;
+ else
+ switch (as->cotype)
+ { /* See how current spec meshes with the existing. */
+ case AS_UNKNOWN:
+ goto cleanup;
+
+ case AS_EXPLICIT:
+ if (current_type == AS_ASSUMED_SIZE)
+ {
+ as->cotype = AS_ASSUMED_SIZE;
+ break;
+ }
+
+ if (current_type == AS_EXPLICIT)
+ break;
+
+ gfc_error ("Bad array specification for an explicitly "
+ "shaped array at %C");
+
+ goto cleanup;
+
+ case AS_ASSUMED_SHAPE:
+ if ((current_type == AS_ASSUMED_SHAPE)
+ || (current_type == AS_DEFERRED))
+ break;
+
+ gfc_error ("Bad array specification for assumed shape "
+ "array at %C");
+ goto cleanup;
+
+ case AS_DEFERRED:
+ if (current_type == AS_DEFERRED)
+ break;
+
+ if (current_type == AS_ASSUMED_SHAPE)
+ {
+ as->cotype = AS_ASSUMED_SHAPE;
+ break;
+ }
+
+ gfc_error ("Bad specification for deferred shape array at %C");
+ goto cleanup;
+
+ case AS_ASSUMED_SIZE:
+ gfc_error ("Bad specification for assumed size array at %C");
+ goto cleanup;
+ }
+
+ if (gfc_match_char (']') == MATCH_YES)
+ break;
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ gfc_error ("Expected another dimension in array declaration at %C");
+ goto cleanup;
+ }
+
+ if (as->corank >= GFC_MAX_DIMENSIONS)
+ {
+ gfc_error ("Array specification at %C has more than %d "
+ "dimensions", GFC_MAX_DIMENSIONS);
+ goto cleanup;
+ }
+ }
+
+ if (current_type == AS_EXPLICIT)
+ {
+ gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
+ goto cleanup;
+ }
+
+ if (as->cotype == AS_ASSUMED_SIZE)
+ as->cotype = AS_EXPLICIT;
+
+ if (as->rank == 0)
+ as->type = as->cotype;
+
+done:
+ if (as->rank == 0 && as->corank == 0)
+ {
+ *asp = NULL;
+ gfc_free_array_spec (as);
+ return MATCH_NO;
}
/* If a lower bounds of an assumed shape array is blank, put in one. */
if (as->type == AS_ASSUMED_SHAPE)
{
- for (i = 0; i < as->rank; i++)
+ for (i = 0; i < as->rank + as->corank; i++)
{
if (as->lower[i] == NULL)
as->lower[i] = gfc_int_expr (1);
}
}
+
*asp = as;
+
return MATCH_YES;
cleanup:
have that array specification. The error locus is needed in case
something goes wrong. On failure, the caller must free the spec. */
-try
+gfc_try
gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
{
+ int i;
+
if (as == NULL)
return SUCCESS;
- if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
+ if (as->rank
+ && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
return FAILURE;
- sym->as = as;
+ if (as->corank
+ && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
+ return FAILURE;
+
+ if (sym->as == NULL)
+ {
+ sym->as = as;
+ return SUCCESS;
+ }
+
+ if (as->corank)
+ {
+ /* The "sym" has no corank (checked via gfc_add_codimension). Thus
+ the codimension is simply added. */
+ gcc_assert (as->rank == 0 && sym->as->corank == 0);
+
+ sym->as->cotype = as->cotype;
+ sym->as->corank = as->corank;
+ for (i = 0; i < as->corank; i++)
+ {
+ sym->as->lower[sym->as->rank + i] = as->lower[i];
+ sym->as->upper[sym->as->rank + i] = as->upper[i];
+ }
+ }
+ else
+ {
+ /* The "sym" has no rank (checked via gfc_add_dimension). Thus
+ the dimension is added - but first the codimensions (if existing
+ need to be shifted to make space for the dimension. */
+ gcc_assert (as->corank == 0 && sym->as->rank == 0);
+
+ sym->as->rank = as->rank;
+ sym->as->type = as->type;
+ sym->as->cray_pointee = as->cray_pointee;
+ sym->as->cp_was_assumed = as->cp_was_assumed;
+
+ for (i = 0; i < sym->as->corank; i++)
+ {
+ sym->as->lower[as->rank + i] = sym->as->lower[i];
+ sym->as->upper[as->rank + i] = sym->as->upper[i];
+ }
+ for (i = 0; i < as->rank; i++)
+ {
+ sym->as->lower[i] = as->lower[i];
+ sym->as->upper[i] = as->upper[i];
+ }
+ }
+ gfc_free (as);
return SUCCESS;
}
*dest = *src;
- for (i = 0; i < dest->rank; i++)
+ for (i = 0; i < dest->rank + dest->corank; i++)
{
dest->lower[i] = gfc_copy_expr (dest->lower[i]);
dest->upper[i] = gfc_copy_expr (dest->upper[i]);
if (as1->rank != as2->rank)
return 0;
+ if (as1->corank != as2->corank)
+ return 0;
+
if (as1->rank == 0)
return 1;
return 0;
if (as1->type == AS_EXPLICIT)
- for (i = 0; i < as1->rank; i++)
+ for (i = 0; i < as1->rank + as1->corank; i++)
{
if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
return 0;
c->expr = new_expr;
- if (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind)
+ if (new_expr
+ && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
}
seen_ts = false;
/* Try to match an optional "type-spec ::" */
- if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
+ if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
{
seen_ts = (gfc_match (" ::") == MATCH_YES);
else
expr->ts.type = BT_UNKNOWN;
- if (expr->ts.cl)
- expr->ts.cl->length_from_typespec = seen_ts;
+ if (expr->ts.u.cl)
+ expr->ts.u.cl->length_from_typespec = seen_ts;
expr->where = where;
expr->rank = 1;
/* Recursive work function for gfc_check_constructor_type(). */
-static try
+static gfc_try
check_constructor_type (gfc_constructor *c, bool convert)
{
gfc_expr *e;
/* Check that all elements of an array constructor are the same type.
On FAILURE, an error has been generated. */
-try
+gfc_try
gfc_check_constructor_type (gfc_expr *e)
{
- try t;
+ gfc_try t;
if (e->ts.type != BT_UNKNOWN)
{
static cons_stack *base;
-static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
+static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
/* Check an EXPR_VARIABLE expression in a constructor to make sure
that that variable is an iteration variables. */
-try
+gfc_try
gfc_check_iter_variable (gfc_expr *expr)
{
gfc_symbol *sym;
to calling the check function for each expression in the
constructor, giving variables with the names of iterators a pass. */
-static try
-check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
+static gfc_try
+check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
- try t;
+ gfc_try t;
for (; c; c = c->next)
{
expression -- specification, restricted, or initialization as
determined by the check_function. */
-try
-gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
+gfc_try
+gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
{
cons_stack *base_save;
- try t;
+ gfc_try t;
base_save = base;
base = NULL;
gfc_component *component;
mpz_t *repeat;
- try (*expand_work_function) (gfc_expr *);
+ gfc_try (*expand_work_function) (gfc_expr *);
}
expand_info;
static expand_info current_expand;
-static try expand_constructor (gfc_constructor *);
+static gfc_try expand_constructor (gfc_constructor *);
/* Work function that counts the number of elements present in a
constructor. */
-static try
+static gfc_try
count_elements (gfc_expr *e)
{
mpz_t result;
/* Work function that extracts a particular element from an array
constructor, freeing the rest. */
-static try
+static gfc_try
extract_element (gfc_expr *e)
{
-
if (e->rank != 0)
{ /* Something unextractable */
gfc_free_expr (e);
gfc_free_expr (e);
current_expand.extract_count++;
+
return SUCCESS;
}
/* Work function that constructs a new constructor out of the old one,
stringing new elements together. */
-static try
+static gfc_try
expand (gfc_expr *e)
{
if (current_expand.new_head == NULL)
/* Expand an expression with that is inside of a constructor,
recursing into other constructors if present. */
-static try
+static gfc_try
expand_expr (gfc_expr *e)
{
if (e->expr_type == EXPR_ARRAY)
}
-static try
+static gfc_try
expand_iterator (gfc_constructor *c)
{
gfc_expr *start, *end, *step;
iterator_stack frame;
mpz_t trip;
- try t;
+ gfc_try t;
end = step = NULL;
expressions. The work function needs to either save or free the
passed expression. */
-static try
+static gfc_try
expand_constructor (gfc_constructor *c)
{
gfc_expr *e;
/* Top level subroutine for expanding constructors. We only expand
constructor if they are small enough. */
-try
+gfc_try
gfc_expand_constructor (gfc_expr *e)
{
expand_info expand_save;
gfc_expr *f;
- try rc;
+ gfc_try rc;
- f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
+ f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
if (f != NULL)
{
gfc_free_expr (f);
constant, after removal of any iteration variables. We return
FAILURE if not so. */
-static try
-constant_element (gfc_expr *e)
+static gfc_try
+is_constant_element (gfc_expr *e)
{
int rv;
gfc_constant_ac (gfc_expr *e)
{
expand_info expand_save;
- try rc;
+ gfc_try rc;
+ gfc_constructor * con;
+
+ rc = SUCCESS;
- iter_stack = NULL;
- expand_save = current_expand;
- current_expand.expand_work_function = constant_element;
+ if (e->value.constructor
+ && e->value.constructor->expr->expr_type == EXPR_ARRAY)
+ {
+ /* Expand the constructor. */
+ iter_stack = NULL;
+ expand_save = current_expand;
+ current_expand.expand_work_function = is_constant_element;
- rc = expand_constructor (e->value.constructor);
+ rc = expand_constructor (e->value.constructor);
+
+ current_expand = expand_save;
+ }
+ else
+ {
+ /* No need to expand this further. */
+ for (con = e->value.constructor; con; con = con->next)
+ {
+ if (con->expr->expr_type == EXPR_CONSTANT)
+ continue;
+ else
+ {
+ if (!gfc_is_constant_expr (con->expr))
+ rc = FAILURE;
+ }
+ }
+ }
- current_expand = expand_save;
if (rc == FAILURE)
return 0;
/* Recursive array list resolution function. All of the elements must
be of the same type. */
-static try
+static gfc_try
resolve_array_list (gfc_constructor *p)
{
- try t;
+ gfc_try t;
t = SUCCESS;
all elements are of compile-time known length, emit an error as this is
invalid. */
-try
+gfc_try
gfc_resolve_character_array_constructor (gfc_expr *expr)
{
gfc_constructor *p;
gcc_assert (expr->expr_type == EXPR_ARRAY);
gcc_assert (expr->ts.type == BT_CHARACTER);
- if (expr->ts.cl == NULL)
+ if (expr->ts.u.cl == NULL)
{
for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->ts.cl != NULL)
+ if (p->expr->ts.u.cl != NULL)
{
/* Ensure that if there is a char_len around that it is
used; otherwise the middle-end confuses them! */
- expr->ts.cl = p->expr->ts.cl;
+ expr->ts.u.cl = p->expr->ts.u.cl;
goto got_charlen;
}
- expr->ts.cl = gfc_get_charlen ();
- expr->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = expr->ts.cl;
+ expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
}
got_charlen:
found_length = -1;
- if (expr->ts.cl->length == NULL)
+ if (expr->ts.u.cl->length == NULL)
{
/* Check that all constant string elements have the same length until
we reach the end or find a variable-length one. */
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
current_length = (int) j;
}
- else if (p->expr->ts.cl && p->expr->ts.cl->length
- && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
+ else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
+ && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
long j;
- j = mpz_get_si (p->expr->ts.cl->length->value.integer);
+ j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
current_length = (int) j;
}
else
gcc_assert (found_length != -1);
/* Update the character length of the array constructor. */
- expr->ts.cl->length = gfc_int_expr (found_length);
+ expr->ts.u.cl->length = gfc_int_expr (found_length);
}
else
{
/* We've got a character length specified. It should be an integer,
otherwise an error is signalled elsewhere. */
- gcc_assert (expr->ts.cl->length);
+ gcc_assert (expr->ts.u.cl->length);
/* If we've got a constant character length, pad according to this.
gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
max_length only if they pass. */
- gfc_extract_int (expr->ts.cl->length, &found_length);
+ gfc_extract_int (expr->ts.u.cl->length, &found_length);
/* Now pad/truncate the elements accordingly to the specified character
length. This is ok inside this conditional, as in the case above
int current_length = -1;
bool has_ts;
- if (p->expr->ts.cl && p->expr->ts.cl->length)
+ if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
{
- cl = p->expr->ts.cl->length;
+ cl = p->expr->ts.u.cl->length;
gfc_extract_int (cl, ¤t_length);
}
/* If gfc_extract_int above set current_length, we implicitly
know the type is BT_INTEGER and it's EXPR_CONSTANT. */
- has_ts = (expr->ts.cl && expr->ts.cl->length_from_typespec);
+ has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
if (! cl
|| (current_length != -1 && current_length < found_length))
/* Resolve all of the expressions in an array list. */
-try
+gfc_try
gfc_resolve_array_constructor (gfc_expr *expr)
{
- try t;
+ gfc_try t;
t = resolve_array_list (expr->value.constructor);
if (t == SUCCESS)
{
expand_info expand_save;
gfc_expr *e;
- try rc;
+ gfc_try rc;
expand_save = current_expand;
current_expand.extract_n = element;
/* Get the size of single dimension of an array specification. The
array is guaranteed to be one dimensional. */
-try
+gfc_try
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
{
if (as == NULL)
}
-try
+gfc_try
spec_size (gfc_array_spec *as, mpz_t *result)
{
mpz_t size;
/* Get the number of elements in an array section. */
-static try
-ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
+gfc_try
+gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
{
mpz_t upper, lower, stride;
- try t;
+ gfc_try t;
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
- gfc_internal_error ("ref_dimen_size(): Bad dimension");
+ gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
switch (ar->dimen_type[dimen])
{
return t;
default:
- gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
+ gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
}
return t;
}
-static try
+static gfc_try
ref_size (gfc_array_ref *ar, mpz_t *result)
{
mpz_t size;
for (d = 0; d < ar->dimen; d++)
{
- if (ref_dimen_size (ar, d, &size) == FAILURE)
+ if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
{
mpz_clear (*result);
return FAILURE;
able to return a result in the 'result' variable, FAILURE
otherwise. */
-try
+gfc_try
gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
{
gfc_ref *ref;
if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
dimen--;
- return ref_dimen_size (&ref->u.ar, i - 1, result);
+ return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
}
}
return SUCCESS;
}
- if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
+ if (array->symtree->n.sym->attr.generic
+ && array->value.function.esym != NULL)
+ {
+ if (spec_dimen_size (array->value.function.esym->as, dimen, result)
+ == FAILURE)
+ return FAILURE;
+ }
+ else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
+ == FAILURE)
return FAILURE;
break;
array. Returns SUCCESS if this is possible, and sets the 'result'
variable. Otherwise returns FAILURE. */
-try
+gfc_try
gfc_array_size (gfc_expr *array, mpz_t *result)
{
expand_info expand_save;
gfc_ref *ref;
- int i, flag;
- try t;
+ int i;
+ gfc_try t;
switch (array->expr_type)
{
case EXPR_ARRAY:
- flag = gfc_suppress_error;
- gfc_suppress_error = 1;
+ gfc_push_suppress_errors ();
expand_save = current_expand;
iter_stack = NULL;
t = expand_constructor (array->value.constructor);
- gfc_suppress_error = flag;
+
+ gfc_pop_suppress_errors ();
if (t == FAILURE)
mpz_clear (*result);
/* Given an array reference, return the shape of the reference in an
array of mpz_t integers. */
-try
+gfc_try
gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
{
int d;
{
if (ar->dimen_type[i] != DIMEN_ELEMENT)
{
- if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
+ if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
goto cleanup;
d++;
}
OSDN Git Service
