/* Array things
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#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)
e = as->upper[i];
if (resolve_array_bound (e, check_constant) == FAILURE)
return FAILURE;
+
+ if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
+ continue;
+
+ /* If the size is negative in this dimension, set it to zero. */
+ if (as->lower[i]->expr_type == EXPR_CONSTANT
+ && as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (as->upper[i]->value.integer,
+ as->lower[i]->value.integer) < 0)
+ {
+ gfc_free_expr (as->upper[i]);
+ as->upper[i] = gfc_copy_expr (as->lower[i]);
+ mpz_sub_ui (as->upper[i]->value.integer,
+ as->upper[i]->value.integer, 1);
+ }
}
return SUCCESS;
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;
}
- as->rank++;
+ 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;
+ }
+
+ 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;
node onto the constructor. */
void
-gfc_append_constructor (gfc_expr *base, gfc_expr *new)
+gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
{
gfc_constructor *c;
c = c->next;
}
- c->expr = new;
+ c->expr = new_expr;
- if (new->ts.type != base->ts.type || new->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");
}
{
gfc_constructor *c;
- c = gfc_getmem (sizeof(gfc_constructor));
+ c = XCNEW (gfc_constructor);
c->expr = NULL;
c->iterator = NULL;
c->next = NULL;
static match
match_array_list (gfc_constructor **result)
{
- gfc_constructor *p, *head, *tail, *new;
+ gfc_constructor *p, *head, *tail, *new_cons;
gfc_iterator iter;
locus old_loc;
gfc_expr *e;
if (m == MATCH_ERROR)
goto cleanup;
- m = match_array_cons_element (&new);
+ m = match_array_cons_element (&new_cons);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto cleanup; /* Could be a complex constant */
}
- tail->next = new;
- tail = new;
+ tail->next = new_cons;
+ tail = new_cons;
if (gfc_match_char (',') != MATCH_YES)
{
match
gfc_match_array_constructor (gfc_expr **result)
{
- gfc_constructor *head, *tail, *new;
+ gfc_constructor *head, *tail, *new_cons;
gfc_expr *expr;
+ gfc_typespec ts;
locus where;
match m;
const char *end_delim;
+ bool seen_ts;
if (gfc_match (" (/") == MATCH_NO)
{
where = gfc_current_locus;
head = tail = NULL;
+ seen_ts = false;
+
+ /* Try to match an optional "type-spec ::" */
+ if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
+ {
+ seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+ if (seen_ts)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
+ "including type specification at %C") == FAILURE)
+ goto cleanup;
+ }
+ }
+
+ if (! seen_ts)
+ gfc_current_locus = where;
if (gfc_match (end_delim) == MATCH_YES)
{
- gfc_error ("Empty array constructor at %C is not allowed");
- goto cleanup;
+ if (seen_ts)
+ goto done;
+ else
+ {
+ gfc_error ("Empty array constructor at %C is not allowed");
+ goto cleanup;
+ }
}
for (;;)
{
- m = match_array_cons_element (&new);
+ m = match_array_cons_element (&new_cons);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (head == NULL)
- head = new;
+ head = new_cons;
else
- tail->next = new;
+ tail->next = new_cons;
- tail = new;
+ tail = new_cons;
if (gfc_match_char (',') == MATCH_NO)
break;
if (gfc_match (end_delim) == MATCH_NO)
goto syntax;
+done:
expr = gfc_get_expr ();
expr->expr_type = EXPR_ARRAY;
expr->value.constructor = head;
/* Size must be calculated at resolution time. */
+ if (seen_ts)
+ expr->ts = ts;
+ else
+ expr->ts.type = BT_UNKNOWN;
+
+ if (expr->ts.u.cl)
+ expr->ts.u.cl->length_from_typespec = seen_ts;
+
expr->where = where;
expr->rank = 1;
cons_state;
static int
-check_element_type (gfc_expr *expr)
+check_element_type (gfc_expr *expr, bool convert)
{
if (cons_state == CONS_BAD)
return 0; /* Suppress further errors */
if (gfc_compare_types (&constructor_ts, &expr->ts))
return 0;
+ if (convert)
+ return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
+
gfc_error ("Element in %s array constructor at %L is %s",
gfc_typename (&constructor_ts), &expr->where,
gfc_typename (&expr->ts));
/* Recursive work function for gfc_check_constructor_type(). */
-static try
-check_constructor_type (gfc_constructor *c)
+static gfc_try
+check_constructor_type (gfc_constructor *c, bool convert)
{
gfc_expr *e;
if (e->expr_type == EXPR_ARRAY)
{
- if (check_constructor_type (e->value.constructor) == FAILURE)
+ if (check_constructor_type (e->value.constructor, convert) == FAILURE)
return FAILURE;
continue;
}
- if (check_element_type (e))
+ if (check_element_type (e, convert))
return FAILURE;
}
/* 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;
- cons_state = CONS_START;
- gfc_clear_ts (&constructor_ts);
+ if (e->ts.type != BT_UNKNOWN)
+ {
+ cons_state = CONS_GOOD;
+ constructor_ts = e->ts;
+ }
+ else
+ {
+ cons_state = CONS_START;
+ gfc_clear_ts (&constructor_ts);
+ }
- t = check_constructor_type (e->value.constructor);
+ /* If e->ts.type != BT_UNKNOWN, the array constructor included a
+ typespec, and we will now convert the values on the fly. */
+ t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
e->ts = constructor_ts;
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;
mpz_init (trip);
mpz_init (frame.value);
+ frame.prev = NULL;
start = gfc_copy_expr (c->iterator->start);
if (gfc_simplify_expr (start, 1) == FAILURE)
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;
return t;
}
-/* Resolve character array constructor. If it is a constant character array and
- not specified character length, update character length to the maximum of
- its element constructors' length. */
+/* Resolve character array constructor. If it has a specified constant character
+ length, pad/truncate the elements here; if the length is not specified and
+ all elements are of compile-time known length, emit an error as this is
+ invalid. */
-void
+gfc_try
gfc_resolve_character_array_constructor (gfc_expr *expr)
{
gfc_constructor *p;
- int max_length;
+ int found_length;
gcc_assert (expr->expr_type == EXPR_ARRAY);
gcc_assert (expr->ts.type == BT_CHARACTER);
- max_length = -1;
-
- 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:
- if (expr->ts.cl->length == NULL)
+ found_length = -1;
+
+ if (expr->ts.u.cl->length == NULL)
{
- /* Find the maximum length of the elements. Do nothing for variable
- array constructor, unless the character length is constant or
- there is a constant substring reference. */
+ /* Check that all constant string elements have the same length until
+ we reach the end or find a variable-length one. */
for (p = expr->value.constructor; p; p = p->next)
{
+ int current_length = -1;
gfc_ref *ref;
for (ref = p->expr->ref; ref; ref = ref->next)
if (ref->type == REF_SUBSTRING
break;
if (p->expr->expr_type == EXPR_CONSTANT)
- max_length = MAX (p->expr->value.character.length, max_length);
+ current_length = p->expr->value.character.length;
else if (ref)
{
long j;
j = mpz_get_ui (ref->u.ss.end->value.integer)
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
- max_length = MAX ((int) j, max_length);
+ 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);
- max_length = MAX ((int) j, max_length);
+ j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
+ current_length = (int) j;
}
else
- return;
- }
+ return SUCCESS;
- if (max_length != -1)
- {
- /* Update the character length of the array constructor. */
- expr->ts.cl->length = gfc_int_expr (max_length);
- /* Update the element constructors. */
- for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (max_length, p->expr, true);
+ gcc_assert (current_length != -1);
+
+ if (found_length == -1)
+ found_length = current_length;
+ else if (found_length != current_length)
+ {
+ gfc_error ("Different CHARACTER lengths (%d/%d) in array"
+ " constructor at %L", found_length, current_length,
+ &p->expr->where);
+ return FAILURE;
+ }
+
+ gcc_assert (found_length == current_length);
}
+
+ gcc_assert (found_length != -1);
+
+ /* Update the character length of the array constructor. */
+ 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.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.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
+ (without typespec) all elements are verified to have the same length
+ anyway. */
+ if (found_length != -1)
+ for (p = expr->value.constructor; p; p = p->next)
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_expr *cl = NULL;
+ int current_length = -1;
+ bool has_ts;
+
+ if (p->expr->ts.u.cl && p->expr->ts.u.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.u.cl && expr->ts.u.cl->length_from_typespec);
+
+ if (! cl
+ || (current_length != -1 && current_length < found_length))
+ gfc_set_constant_character_len (found_length, p->expr,
+ has_ts ? -1 : found_length);
+ }
+ }
+
+ return SUCCESS;
}
/* 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)
t = gfc_check_constructor_type (expr);
- if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
- gfc_resolve_character_array_constructor (expr);
+
+ /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
+ the call to this function, so we don't need to call it here; if it was
+ called twice, an error message there would be duplicated. */
return t;
}
{
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. */
-static try
+gfc_try
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
{
if (as == NULL)
if (as->type != AS_EXPLICIT
|| as->lower[dimen]->expr_type != EXPR_CONSTANT
- || as->upper[dimen]->expr_type != EXPR_CONSTANT)
+ || as->upper[dimen]->expr_type != EXPR_CONSTANT
+ || as->lower[dimen]->ts.type != BT_INTEGER
+ || as->upper[dimen]->ts.type != BT_INTEGER)
return FAILURE;
mpz_init (*result);
}
-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
