/* Array things
- Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
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 100
-
-
/**************** Array reference matching subroutines *****************/
/* Copy an array reference structure. */
gfc_array_ref *
-gfc_copy_array_ref (gfc_array_ref * src)
+gfc_copy_array_ref (gfc_array_ref *src)
{
gfc_array_ref *dest;
int i;
expression. */
static match
-match_subscript (gfc_array_ref * ar, int init)
+match_subscript (gfc_array_ref *ar, int init)
{
match m;
int i;
if (gfc_match_char (':') == MATCH_YES)
{
m = init ? gfc_match_init_expr (&ar->stride[i])
- : gfc_match_expr (&ar->stride[i]);
+ : gfc_match_expr (&ar->stride[i]);
if (m == MATCH_NO)
gfc_error ("Expected array subscript stride at %C");
to consist of init expressions. */
match
-gfc_match_array_ref (gfc_array_ref * ar, gfc_array_spec * as, int init)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
{
match m;
}
}
- gfc_error ("Array reference at %C cannot have more than "
- stringize (GFC_MAX_DIMENSIONS) " dimensions");
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
error:
return MATCH_ERROR;
specifications. */
void
-gfc_free_array_spec (gfc_array_spec * as)
+gfc_free_array_spec (gfc_array_spec *as)
{
int i;
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
-resolve_array_bound (gfc_expr * e, int check_constant)
+static gfc_try
+resolve_array_bound (gfc_expr *e, int check_constant)
{
-
if (e == NULL)
return SUCCESS;
/* Takes an array specification, resolves the expressions that make up
the shape and make sure everything is integral. */
-try
-gfc_resolve_array_spec (gfc_array_spec * as, int check_constant)
+gfc_try
+gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
{
gfc_expr *e;
int i;
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;
individual specifications make sense as a whole.
- Parsed Lower Upper Returned
- ------------------------------------
- : NULL NULL AS_DEFERRED (*)
- x 1 x AS_EXPLICIT
- x: x NULL AS_ASSUMED_SHAPE
- x:y x y AS_EXPLICIT
- x:* x NULL AS_ASSUMED_SIZE
- * 1 NULL AS_ASSUMED_SIZE
+ Parsed Lower Upper Returned
+ ------------------------------------
+ : NULL NULL AS_DEFERRED (*)
+ x 1 x AS_EXPLICIT
+ x: x NULL AS_ASSUMED_SHAPE
+ x:y x y AS_EXPLICIT
+ x:* x NULL AS_ASSUMED_SIZE
+ * 1 NULL AS_ASSUMED_SIZE
(*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
is fixed during the resolution of formal interfaces.
Anything else AS_UNKNOWN. */
static array_type
-match_array_element_spec (gfc_array_spec * as)
+match_array_element_spec (gfc_array_spec *as)
{
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)
}
else
switch (as->type)
- { /* See how current spec meshes with the existing */
+ { /* See how current spec meshes with the existing. */
case AS_UNKNOWN:
goto cleanup;
if (current_type == AS_EXPLICIT)
break;
- gfc_error
- ("Bad array specification for an explicitly shaped array"
- " at %C");
+ gfc_error ("Bad array specification for an explicitly shaped "
+ "array at %C");
goto cleanup;
|| (current_type == AS_DEFERRED))
break;
- gfc_error
- ("Bad array specification for assumed shape array at %C");
+ gfc_error ("Bad array specification for assumed shape "
+ "array at %C");
goto cleanup;
case AS_DEFERRED:
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 "
- stringize (GFC_MAX_DIMENSIONS) " 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_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
+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;
}
/* Copy an array specification. */
gfc_array_spec *
-gfc_copy_array_spec (gfc_array_spec * src)
+gfc_copy_array_spec (gfc_array_spec *src)
{
gfc_array_spec *dest;
int i;
*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]);
return dest;
}
+
/* Returns nonzero if the two expressions are equal. Only handles integer
constants. */
static int
-compare_bounds (gfc_expr * bound1, gfc_expr * bound2)
+compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
{
if (bound1 == NULL || bound2 == NULL
|| bound1->expr_type != EXPR_CONSTANT
return 0;
}
+
/* Compares two array specifications. They must be constant or deferred
shape. */
int
-gfc_compare_array_spec (gfc_array_spec * as1, gfc_array_spec * as2)
+gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
{
int 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;
elements and should be appended to by gfc_append_constructor(). */
gfc_expr *
-gfc_start_constructor (bt type, int kind, locus * where)
+gfc_start_constructor (bt type, int kind, locus *where)
{
gfc_expr *result;
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");
}
constructor onto the base's one according to the offset. */
void
-gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
+gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
{
gfc_constructor *c, *pre;
expr_t type;
{
c = pre = base->value.constructor;
while (c)
- {
- if (type == EXPR_ARRAY)
- {
+ {
+ if (type == EXPR_ARRAY)
+ {
t = mpz_cmp (c->n.offset, c1->n.offset);
- if (t < 0)
- {
- pre = c;
- c = c->next;
- }
- else if (t == 0)
- {
- gfc_error ("duplicated initializer");
- break;
- }
- else
- break;
- }
- else
- {
- pre = c;
- c = c->next;
- }
- }
+ if (t < 0)
+ {
+ pre = c;
+ c = c->next;
+ }
+ else if (t == 0)
+ {
+ gfc_error ("duplicated initializer");
+ break;
+ }
+ else
+ break;
+ }
+ else
+ {
+ pre = c;
+ c = c->next;
+ }
+ }
if (pre != c)
- {
- pre->next = c1;
- c1->next = c;
- }
+ {
+ pre->next = c1;
+ c1->next = c;
+ }
else
- {
- c1->next = c;
- base->value.constructor = c1;
- }
+ {
+ c1->next = c;
+ base->value.constructor = c1;
+ }
}
}
{
gfc_constructor *c;
- c = gfc_getmem (sizeof(gfc_constructor));
+ c = XCNEW (gfc_constructor);
c->expr = NULL;
c->iterator = NULL;
c->next = NULL;
/* Free chains of gfc_constructor structures. */
void
-gfc_free_constructor (gfc_constructor * p)
+gfc_free_constructor (gfc_constructor *p)
{
gfc_constructor *next;
next = p->next;
if (p->expr)
- gfc_free_expr (p->expr);
+ gfc_free_expr (p->expr);
if (p->iterator != NULL)
gfc_free_iterator (p->iterator, 1);
mpz_clear (p->n.offset);
duplicate was found. */
static int
-check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
+check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
{
gfc_expr *e;
if (c->iterator->var->symtree->n.sym == master)
{
- gfc_error
- ("DO-iterator '%s' at %L is inside iterator of the same name",
- master->name, &c->where);
+ gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
+ "same name", master->name, &c->where);
return 1;
}
/* Match a list of array elements. */
static match
-match_array_list (gfc_constructor ** result)
+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)
{
single expression or a list of elements. */
static match
-match_array_cons_element (gfc_constructor ** result)
+match_array_cons_element (gfc_constructor **result)
{
gfc_constructor *p;
gfc_expr *expr;
/* Match an array constructor. */
match
-gfc_match_array_constructor (gfc_expr ** result)
+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)
{
if (gfc_match (" [") == MATCH_NO)
- return MATCH_NO;
+ return MATCH_NO;
else
- {
- if (gfc_notify_std (GFC_STD_F2003, "New in Fortran 2003: [...] "
- "style array constructors at %C") == FAILURE)
- return MATCH_ERROR;
- end_delim = " ]";
- }
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
+ "style array constructors at %C") == FAILURE)
+ return MATCH_ERROR;
+ end_delim = " ]";
+ }
}
else
end_delim = " /)";
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_check_constructor_type (gfc_expr * e)
+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_check_iter_variable (gfc_expr * expr)
+gfc_try
+gfc_check_iter_variable (gfc_expr *expr)
{
-
gfc_symbol *sym;
cons_stack *c;
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
-count_elements (gfc_expr * e)
+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
-extract_element (gfc_expr * e)
+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
-expand (gfc_expr * e)
+static gfc_try
+expand (gfc_expr *e)
{
-
if (current_expand.new_head == NULL)
current_expand.new_head = current_expand.new_tail =
gfc_get_constructor ();
substitute the current value of the iteration variable. */
void
-gfc_simplify_iterator_var (gfc_expr * e)
+gfc_simplify_iterator_var (gfc_expr *e)
{
iterator_stack *p;
/* Expand an expression with that is inside of a constructor,
recursing into other constructors if present. */
-static try
-expand_expr (gfc_expr * e)
+static gfc_try
+expand_expr (gfc_expr *e)
{
-
if (e->expr_type == EXPR_ARRAY)
return expand_constructor (e->value.constructor);
}
-static try
-expand_iterator (gfc_constructor * c)
+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
-expand_constructor (gfc_constructor * c)
+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_expand_constructor (gfc_expr * e)
+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;
function that traverses the expression tree. FIXME. */
int
-gfc_constant_ac (gfc_expr * e)
+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;
expanded (no iterators) and zero if iterators are present. */
int
-gfc_expanded_ac (gfc_expr * e)
+gfc_expanded_ac (gfc_expr *e)
{
gfc_constructor *p;
/* Recursive array list resolution function. All of the elements must
be of the same type. */
-static try
-resolve_array_list (gfc_constructor * p)
+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. */
-static void
-resolve_character_array_constructor (gfc_expr * expr)
+gfc_try
+gfc_resolve_character_array_constructor (gfc_expr *expr)
{
- gfc_constructor * p;
- int max_length;
+ gfc_constructor *p;
+ 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)
{
- expr->ts.cl = gfc_get_charlen ();
- expr->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = expr->ts.cl;
+ for (p = expr->value.constructor; p; p = p->next)
+ 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.u.cl = p->expr->ts.u.cl;
+ goto got_charlen;
+ }
+
+ expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
}
- if (expr->ts.cl->length == NULL)
+got_charlen:
+
+ found_length = -1;
+
+ if (expr->ts.u.cl->length == NULL)
{
- /* Find the maximum length of the elements. Do nothing for variable array
- constructor. */
- for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->expr_type == EXPR_CONSTANT)
- max_length = MAX (p->expr->value.character.length, max_length);
- else
- return;
+ /* Check that all constant string elements have the same length until
+ we reach the end or find a variable-length one. */
- if (max_length != -1)
+ for (p = expr->value.constructor; p; p = p->next)
{
- /* 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)
- gfc_set_constant_character_len (max_length, p->expr);
+ int current_length = -1;
+ gfc_ref *ref;
+ for (ref = p->expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_SUBSTRING
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT
+ && ref->u.ss.end->expr_type == EXPR_CONSTANT)
+ break;
+
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ 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;
+ current_length = (int) j;
+ }
+ 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.u.cl->length->value.integer);
+ current_length = (int) j;
+ }
+ else
+ return SUCCESS;
+
+ 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_resolve_array_constructor (gfc_expr * expr)
+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)
- 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;
}
/* Copy an iterator structure. */
static gfc_iterator *
-copy_iterator (gfc_iterator * src)
+copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
/* Copy a constructor structure. */
gfc_constructor *
-gfc_copy_constructor (gfc_constructor * src)
+gfc_copy_constructor (gfc_constructor *src)
{
gfc_constructor *dest;
gfc_constructor *tail;
have to be particularly fast. */
gfc_expr *
-gfc_get_array_element (gfc_expr * array, int element)
+gfc_get_array_element (gfc_expr *array, int element)
{
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
-spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
+gfc_try
+spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
{
-
if (as == NULL)
return FAILURE;
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
-spec_size (gfc_array_spec * as, mpz_t * result)
+gfc_try
+spec_size (gfc_array_spec *as, mpz_t *result)
{
mpz_t size;
int d;
/* 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
-ref_size (gfc_array_ref * ar, mpz_t * result)
+static gfc_try
+ref_size (gfc_array_ref *ar, mpz_t *result)
{
mpz_t size;
int d;
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_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
+gfc_try
+gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
{
gfc_ref *ref;
int i;
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);
}
}
- if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
+ if (array->shape && array->shape[dimen])
+ {
+ mpz_init_set (*result, array->shape[dimen]);
+ return SUCCESS;
+ }
+
+ 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_array_size (gfc_expr * array, mpz_t * result)
+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_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
+gfc_try
+gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
{
int d;
int i;
{
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++;
}
characterizes the reference. */
gfc_array_ref *
-gfc_find_array_ref (gfc_expr * e)
+gfc_find_array_ref (gfc_expr *e)
{
gfc_ref *ref;
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
- && (ref->u.ar.type == AR_FULL
- || ref->u.ar.type == AR_SECTION))
+ && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
break;
if (ref == NULL)
OSDN Git Service
