/* 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
-
+#include "constructor.h"
/**************** 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, bool match_star)
{
- match m;
+ match m = MATCH_ERROR;
+ bool star = false;
int i;
- i = ar->dimen;
+ i = ar->dimen + ar->codimen;
ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
goto end_element;
/* Get start element. */
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+
+ if (!star && init)
m = gfc_match_init_expr (&ar->start[i]);
- else
+ else if (!star)
m = gfc_match_expr (&ar->start[i]);
- if (m == MATCH_NO)
+ if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
+ return MATCH_NO;
+ else if (m == MATCH_NO)
gfc_error ("Expected array subscript at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_match_char (':') == MATCH_NO)
- return MATCH_YES;
+ goto matched;
+
+ if (star)
+ {
+ gfc_error ("Unexpected '*' in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
/* Get an optional end element. Because we've seen the colon, we
definitely have a range along this dimension. */
end_element:
ar->dimen_type[i] = DIMEN_RANGE;
- if (init)
+ if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
+ star = true;
+ else if (init)
m = gfc_match_init_expr (&ar->end[i]);
else
m = gfc_match_expr (&ar->end[i]);
/* See if we have an optional stride. */
if (gfc_match_char (':') == MATCH_YES)
{
+ if (star)
+ {
+ gfc_error ("Strides not allowed in coarray subscript at %C");
+ return MATCH_ERROR;
+ }
+
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");
return MATCH_ERROR;
}
+matched:
+ if (star)
+ ar->dimen_type[i] = DIMEN_STAR;
+
return MATCH_YES;
}
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,
+ int corank)
{
match m;
+ bool matched_bracket = false;
memset (ar, '\0', sizeof (ar));
ar->where = gfc_current_locus;
ar->as = as;
+ ar->type = AR_UNKNOWN;
+
+ if (gfc_match_char ('[') == MATCH_YES)
+ {
+ matched_bracket = true;
+ goto coarray;
+ }
if (gfc_match_char ('(') != MATCH_YES)
{
return MATCH_YES;
}
- ar->type = AR_UNKNOWN;
-
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
{
- m = match_subscript (ar, init);
+ m = match_subscript (ar, init, false);
if (m == MATCH_ERROR)
- goto error;
+ return MATCH_ERROR;
if (gfc_match_char (')') == MATCH_YES)
- goto matched;
+ {
+ ar->dimen++;
+ goto coarray;
+ }
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Invalid form of array reference at %C");
- goto error;
+ return MATCH_ERROR;
}
}
- gfc_error ("Array reference at %C cannot have more than "
- stringize (GFC_MAX_DIMENSIONS) " dimensions");
-
-error:
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
return MATCH_ERROR;
-matched:
- ar->dimen++;
+coarray:
+ if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
+ {
+ if (ar->dimen > 0)
+ return MATCH_YES;
+ else
+ return MATCH_ERROR;
+ }
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ return MATCH_ERROR;
+ }
+
+ if (corank == 0)
+ {
+ gfc_error ("Unexpected coarray designator at %C");
+ return MATCH_ERROR;
+ }
+
+ for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
+ {
+ m = match_subscript (ar, init, ar->codimen == (corank - 1));
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match_char (']') == MATCH_YES)
+ {
+ ar->codimen++;
+ if (ar->codimen < corank)
+ {
+ gfc_error ("Too few codimensions at %C, expected %d not %d",
+ corank, ar->codimen);
+ return MATCH_ERROR;
+ }
+ if (ar->codimen > corank)
+ {
+ gfc_error ("Too many codimensions at %C, expected %d not %d",
+ corank, ar->codimen);
+ return MATCH_ERROR;
+ }
+ return MATCH_YES;
+ }
+
+ if (gfc_match_char (',') != MATCH_YES)
+ {
+ if (gfc_match_char ('*') == MATCH_YES)
+ gfc_error ("Unexpected '*' for codimension %d of %d at %C",
+ ar->codimen + 1, corank);
+ else
+ gfc_error ("Invalid form of coarray reference at %C");
+ return MATCH_ERROR;
+ }
+ if (ar->codimen >= corank)
+ {
+ gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
+ ar->codimen + 1, corank);
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_error ("Array reference at %C cannot have more than %d dimensions",
+ GFC_MAX_DIMENSIONS);
+ return MATCH_ERROR;
- return MATCH_YES;
}
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]);
}
- gfc_free (as);
+ free (as);
}
/* 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;
|| gfc_specification_expr (e) == FAILURE)
return FAILURE;
- if (check_constant && gfc_is_constant_expr (e) == 0)
+ if (check_constant && !gfc_is_constant_expr (e))
{
- gfc_error ("Variable '%s' at %L in this context must be constant",
- e->symtree->n.sym->name, &e->where);
+ if (e->expr_type == EXPR_VARIABLE)
+ gfc_error ("Variable '%s' at %L in this context must be constant",
+ e->symtree->n.sym->name, &e->where);
+ else
+ gfc_error ("Expression at %L in this context must be constant",
+ &e->where);
return FAILURE;
}
/* 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)
{
- *lower = gfc_int_expr (1);
+ *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
return AS_ASSUMED_SIZE;
}
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)
{
- *lower = gfc_int_expr (1);
+ *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
return AS_EXPLICIT;
}
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 ();
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ if (!match_dim)
+ goto coarray;
+
+ if (gfc_match_char ('(') != MATCH_YES)
{
- as->lower[i] = NULL;
- as->upper[i] = NULL;
+ if (!match_codim)
+ goto done;
+ goto coarray;
}
- as->rank = 1;
-
for (;;)
{
+ as->rank++;
current_type = match_array_element_spec (as);
+ /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
+ and implied-shape specifications. If the rank is at least 2, we can
+ distinguish between them. But for rank 1, we currently return
+ ASSUMED_SIZE; this gets adjusted later when we know for sure
+ whether the symbol parsed is a PARAMETER or not. */
+
if (as->rank == 1)
{
if (current_type == AS_UNKNOWN)
}
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;
+ case AS_IMPLIED_SHAPE:
+ if (current_type != AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Bad array specification for implied-shape"
+ " array at %C");
+ goto cleanup;
+ }
+ break;
+
case AS_EXPLICIT:
if (current_type == AS_ASSUMED_SIZE)
{
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;
case AS_ASSUMED_SIZE:
+ if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
+ {
+ as->type = AS_IMPLIED_SHAPE;
+ break;
+ }
+
gfc_error ("Bad specification for assumed size array at %C");
goto cleanup;
}
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_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+ goto cleanup;
+ }
+
+ if (as->rank >= GFC_MAX_DIMENSIONS)
+ {
+ gfc_error ("Array specification at %C has more than %d "
+ "dimensions", GFC_MAX_DIMENSIONS);
+ 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_IMPLIED_SHAPE:
+ 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->rank + 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);
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 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];
+ }
+ }
+ 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;
/****************** Array constructor functions ******************/
-/* Start an array constructor. The constructor starts with zero
- elements and should be appended to by gfc_append_constructor(). */
-
-gfc_expr *
-gfc_start_constructor (bt type, int kind, locus * where)
-{
- gfc_expr *result;
-
- result = gfc_get_expr ();
-
- result->expr_type = EXPR_ARRAY;
- result->rank = 1;
-
- result->ts.type = type;
- result->ts.kind = kind;
- result->where = *where;
- return result;
-}
-
-
-/* Given an array constructor expression, append the new expression
- node onto the constructor. */
-
-void
-gfc_append_constructor (gfc_expr * base, gfc_expr * new)
-{
- gfc_constructor *c;
-
- if (base->value.constructor == NULL)
- base->value.constructor = c = gfc_get_constructor ();
- else
- {
- c = base->value.constructor;
- while (c->next)
- c = c->next;
-
- c->next = gfc_get_constructor ();
- c = c->next;
- }
-
- c->expr = new;
-
- if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
- gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
-}
-
-
-/* Given an array constructor expression, insert the new expression's
- constructor onto the base's one according to the offset. */
-
-void
-gfc_insert_constructor (gfc_expr * base, gfc_constructor * c1)
-{
- gfc_constructor *c, *pre;
- expr_t type;
- int t;
-
- type = base->expr_type;
-
- if (base->value.constructor == NULL)
- base->value.constructor = c1;
- else
- {
- c = pre = base->value.constructor;
- while (c)
- {
- 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 (pre != c)
- {
- pre->next = c1;
- c1->next = c;
- }
- else
- {
- c1->next = c;
- base->value.constructor = c1;
- }
- }
-}
-
-
-/* Get a new constructor. */
-
-gfc_constructor *
-gfc_get_constructor (void)
-{
- gfc_constructor *c;
-
- c = gfc_getmem (sizeof(gfc_constructor));
- c->expr = NULL;
- c->iterator = NULL;
- c->next = NULL;
- mpz_init_set_si (c->n.offset, 0);
- mpz_init_set_si (c->repeat, 0);
- return c;
-}
-
-
-/* Free chains of gfc_constructor structures. */
-
-void
-gfc_free_constructor (gfc_constructor * p)
-{
- gfc_constructor *next;
-
- if (p == NULL)
- return;
-
- for (; p; p = next)
- {
- next = p->next;
-
- if (p->expr)
- gfc_free_expr (p->expr);
- if (p->iterator != NULL)
- gfc_free_iterator (p->iterator, 1);
- mpz_clear (p->n.offset);
- mpz_clear (p->repeat);
- gfc_free (p);
- }
-}
-
/* Given an expression node that might be an array constructor and a
symbol, make sure that no iterators in this or child constructors
duplicate was found. */
static int
-check_duplicate_iterator (gfc_constructor * c, gfc_symbol * master)
+check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
e = c->expr;
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;
}
/* Forward declaration because these functions are mutually recursive. */
-static match match_array_cons_element (gfc_constructor **);
+static match match_array_cons_element (gfc_constructor_base *);
/* Match a list of array elements. */
static match
-match_array_list (gfc_constructor ** result)
+match_array_list (gfc_constructor_base *result)
{
- gfc_constructor *p, *head, *tail, *new;
+ gfc_constructor_base head;
+ gfc_constructor *p;
gfc_iterator iter;
locus old_loc;
gfc_expr *e;
if (m != MATCH_YES)
goto cleanup;
- tail = head;
-
if (gfc_match_char (',') != MATCH_YES)
{
m = MATCH_NO;
if (m == MATCH_ERROR)
goto cleanup;
- m = match_array_cons_element (&new);
+ m = match_array_cons_element (&head);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto cleanup; /* Could be a complex constant */
}
- tail->next = new;
- tail = new;
-
if (gfc_match_char (',') != MATCH_YES)
{
if (n > 2)
goto cleanup;
}
- e = gfc_get_expr ();
- e->expr_type = EXPR_ARRAY;
- e->where = old_loc;
+ e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
e->value.constructor = head;
- p = gfc_get_constructor ();
- p->where = gfc_current_locus;
+ p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
p->iterator = gfc_get_iterator ();
*p->iterator = iter;
- p->expr = e;
- *result = p;
-
return MATCH_YES;
syntax:
m = MATCH_ERROR;
cleanup:
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
gfc_free_iterator (&iter, 0);
gfc_current_locus = old_loc;
return m;
single expression or a list of elements. */
static match
-match_array_cons_element (gfc_constructor ** result)
+match_array_cons_element (gfc_constructor_base *result)
{
- gfc_constructor *p;
gfc_expr *expr;
match m;
if (m != MATCH_YES)
return m;
- p = gfc_get_constructor ();
- p->where = gfc_current_locus;
- p->expr = expr;
-
- *result = p;
+ gfc_constructor_append_expr (result, expr, &gfc_current_locus);
return MATCH_YES;
}
/* 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_base head, 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;
+ head = new_cons = 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 (ts.deferred)
+ {
+ gfc_error ("Type-spec at %L cannot contain a deferred "
+ "type parameter", &where);
+ 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 (&head);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
- if (head == NULL)
- head = new;
- else
- tail->next = new;
-
- tail = new;
-
if (gfc_match_char (',') == MATCH_NO)
break;
}
if (gfc_match (end_delim) == MATCH_NO)
goto syntax;
- expr = gfc_get_expr ();
-
- expr->expr_type = EXPR_ARRAY;
-
- expr->value.constructor = head;
+done:
/* Size must be calculated at resolution time. */
+ if (seen_ts)
+ {
+ expr = gfc_get_array_expr (ts.type, ts.kind, &where);
+ expr->ts = ts;
+ }
+ else
+ expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
- expr->where = where;
- expr->rank = 1;
+ expr->value.constructor = head;
+ if (expr->ts.u.cl)
+ expr->ts.u.cl->length_from_typespec = seen_ts;
*result = expr;
return MATCH_YES;
gfc_error ("Syntax error in array constructor at %C");
cleanup:
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
return MATCH_ERROR;
}
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_base base, bool convert)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
e = c->expr;
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_base, 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;
sym = expr->symtree->n.sym;
- for (c = base; c; c = c->previous)
+ for (c = base; c && c->iterator; c = c->previous)
if (sym == c->iterator->var->symtree->n.sym)
return SUCCESS;
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_base ctor, gfc_try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
- try t;
+ gfc_try t;
+ gfc_constructor *c;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
{
e = c->expr;
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;
typedef struct
{
- gfc_constructor *new_head, *new_tail;
+ gfc_constructor_base base;
int extract_count, extract_n;
gfc_expr *extracted;
mpz_t *count;
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_base);
/* 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)
{
+ gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
+ e, &e->where);
- if (current_expand.new_head == NULL)
- current_expand.new_head = current_expand.new_tail =
- gfc_get_constructor ();
- else
- {
- current_expand.new_tail->next = gfc_get_constructor ();
- current_expand.new_tail = current_expand.new_tail->next;
- }
-
- current_expand.new_tail->where = e->where;
- current_expand.new_tail->expr = e;
-
- mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
- current_expand.new_tail->n.component = current_expand.component;
- mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
+ c->n.component = current_expand.component;
return SUCCESS;
}
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;
if (p == NULL)
return; /* Variable not found */
- gfc_replace_expr (e, gfc_int_expr (0));
+ gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
mpz_set (e->value.integer, p->value);
/* 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_base base)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
{
if (c->iterator != NULL)
{
gfc_free_expr (e);
return FAILURE;
}
- current_expand.offset = &c->n.offset;
- current_expand.component = c->n.component;
+ current_expand.offset = &c->offset;
current_expand.repeat = &c->repeat;
+ current_expand.component = c->n.component;
if (current_expand.expand_work_function (e) == FAILURE)
return FAILURE;
}
}
+/* Given an array expression and an element number (starting at zero),
+ return a pointer to the array element. NULL is returned if the
+ size of the array has been exceeded. The expression node returned
+ remains a part of the array and should not be freed. Access is not
+ efficient at all, but this is another place where things do not
+ have to be particularly fast. */
+
+static gfc_expr *
+gfc_get_array_element (gfc_expr *array, int element)
+{
+ expand_info expand_save;
+ gfc_expr *e;
+ gfc_try rc;
+
+ expand_save = current_expand;
+ current_expand.extract_n = element;
+ current_expand.expand_work_function = extract_element;
+ current_expand.extracted = NULL;
+ current_expand.extract_count = 0;
+
+ iter_stack = NULL;
+
+ rc = expand_constructor (array->value.constructor);
+ e = current_expand.extracted;
+ current_expand = expand_save;
+
+ if (rc == FAILURE)
+ return NULL;
+
+ return 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, bool fatal)
{
expand_info expand_save;
gfc_expr *f;
- try rc;
+ gfc_try rc;
- f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
+ /* If we can successfully get an array element at the max array size then
+ the array is too big to expand, so we just return. */
+ f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
if (f != NULL)
{
gfc_free_expr (f);
+ if (fatal)
+ {
+ gfc_error ("The number of elements in the array constructor "
+ "at %L requires an increase of the allowed %d "
+ "upper limit. See -fmax-array-constructor "
+ "option", &e->where,
+ gfc_option.flag_max_array_constructor);
+ return FAILURE;
+ }
return SUCCESS;
}
+ /* We now know the array is not too big so go ahead and try to expand it. */
expand_save = current_expand;
- current_expand.new_head = current_expand.new_tail = NULL;
+ current_expand.base = NULL;
iter_stack = NULL;
if (expand_constructor (e->value.constructor) == FAILURE)
{
- gfc_free_constructor (current_expand.new_head);
+ gfc_constructor_free (current_expand.base);
rc = FAILURE;
goto done;
}
- gfc_free_constructor (e->value.constructor);
- e->value.constructor = current_expand.new_head;
+ gfc_constructor_free (e->value.constructor);
+ e->value.constructor = current_expand.base;
rc = SUCCESS;
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;
iter_stack = NULL;
expand_save = current_expand;
- current_expand.expand_work_function = constant_element;
+ current_expand.expand_work_function = is_constant_element;
rc = expand_constructor (e->value.constructor);
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;
+ gfc_constructor *c;
if (e->expr_type == EXPR_ARRAY)
- for (p = e->value.constructor; p; p = p->next)
- if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
return 0;
return 1;
/* 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_base base)
{
- try t;
+ gfc_try t;
+ gfc_constructor *c;
t = SUCCESS;
- for (; p; p = p->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
- if (p->iterator != NULL
- && gfc_resolve_iterator (p->iterator, false) == FAILURE)
+ if (c->iterator != NULL
+ && gfc_resolve_iterator (c->iterator, false) == FAILURE)
t = FAILURE;
- if (gfc_resolve_expr (p->expr) == FAILURE)
+ if (gfc_resolve_expr (c->expr) == FAILURE)
t = FAILURE;
}
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 = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
+ 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;
-
- if (max_length != -1)
+ /* Check that all constant string elements have the same length until
+ we reach the end or find a variable-length one. */
+
+ for (p = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
{
- /* 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_get_int_expr (gfc_default_integer_kind,
+ NULL, 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 = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
+ 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)
+gfc_iterator *
+gfc_copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
}
-/* Copy a constructor structure. */
-
-gfc_constructor *
-gfc_copy_constructor (gfc_constructor * src)
-{
- gfc_constructor *dest;
- gfc_constructor *tail;
-
- if (src == NULL)
- return NULL;
-
- dest = tail = NULL;
- while (src)
- {
- if (dest == NULL)
- dest = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
- tail->where = src->where;
- tail->expr = gfc_copy_expr (src->expr);
- tail->iterator = copy_iterator (src->iterator);
- mpz_set (tail->n.offset, src->n.offset);
- tail->n.component = src->n.component;
- mpz_set (tail->repeat, src->repeat);
- src = src->next;
- }
-
- return dest;
-}
-
-
-/* Given an array expression and an element number (starting at zero),
- return a pointer to the array element. NULL is returned if the
- size of the array has been exceeded. The expression node returned
- remains a part of the array and should not be freed. Access is not
- efficient at all, but this is another place where things do not
- have to be particularly fast. */
-
-gfc_expr *
-gfc_get_array_element (gfc_expr * array, int element)
-{
- expand_info expand_save;
- gfc_expr *e;
- try rc;
-
- expand_save = current_expand;
- current_expand.extract_n = element;
- current_expand.expand_work_function = extract_element;
- current_expand.extracted = NULL;
- current_expand.extract_count = 0;
-
- iter_stack = NULL;
-
- rc = expand_constructor (array->value.constructor);
- e = current_expand.extracted;
- current_expand = expand_save;
-
- if (rc == FAILURE)
- return NULL;
-
- return e;
-}
-
-
/********* Subroutines for determining the size of an array *********/
/* These are needed just to accommodate RESHAPE(). There are no
/* 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. */
+/* Get the number of elements in an array section. Optionally, also supply
+ the end value. */
-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 *end)
{
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])
{
mpz_set_ui (*result, 0);
t = SUCCESS;
+ if (end)
+ {
+ mpz_init (*end);
+
+ mpz_sub_ui (*end, *result, 1UL);
+ mpz_mul (*end, *end, stride);
+ mpz_add (*end, *end, lower);
+ }
+
cleanup:
mpz_clear (upper);
mpz_clear (lower);
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, NULL) == 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, NULL);
}
}
- 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], NULL) == FAILURE)
goto cleanup;
d++;
}
}
cleanup:
- for (d--; d >= 0; d--)
- mpz_clear (shape[d]);
-
+ gfc_clear_shape (shape, d);
return FAILURE;
}
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
