/* Array things
|
/* Array things
|
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Andy Vaught
|
Contributed by Andy Vaught
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "match.h"
|
#include "match.h"
|
|
|
/**************** Array reference matching subroutines *****************/
|
/**************** Array reference matching subroutines *****************/
|
|
|
/* Copy an array reference structure. */
|
/* Copy an array reference structure. */
|
|
|
gfc_array_ref *
|
gfc_array_ref *
|
gfc_copy_array_ref (gfc_array_ref *src)
|
gfc_copy_array_ref (gfc_array_ref *src)
|
{
|
{
|
gfc_array_ref *dest;
|
gfc_array_ref *dest;
|
int i;
|
int i;
|
|
|
if (src == NULL)
|
if (src == NULL)
|
return NULL;
|
return NULL;
|
|
|
dest = gfc_get_array_ref ();
|
dest = gfc_get_array_ref ();
|
|
|
*dest = *src;
|
*dest = *src;
|
|
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
{
|
{
|
dest->start[i] = gfc_copy_expr (src->start[i]);
|
dest->start[i] = gfc_copy_expr (src->start[i]);
|
dest->end[i] = gfc_copy_expr (src->end[i]);
|
dest->end[i] = gfc_copy_expr (src->end[i]);
|
dest->stride[i] = gfc_copy_expr (src->stride[i]);
|
dest->stride[i] = gfc_copy_expr (src->stride[i]);
|
}
|
}
|
|
|
dest->offset = gfc_copy_expr (src->offset);
|
dest->offset = gfc_copy_expr (src->offset);
|
|
|
return dest;
|
return dest;
|
}
|
}
|
|
|
|
|
/* Match a single dimension of an array reference. This can be a
|
/* Match a single dimension of an array reference. This can be a
|
single element or an array section. Any modifications we've made
|
single element or an array section. Any modifications we've made
|
to the ar structure are cleaned up by the caller. If the init
|
to the ar structure are cleaned up by the caller. If the init
|
is set, we require the subscript to be a valid initialization
|
is set, we require the subscript to be a valid initialization
|
expression. */
|
expression. */
|
|
|
static match
|
static match
|
match_subscript (gfc_array_ref *ar, int init)
|
match_subscript (gfc_array_ref *ar, int init)
|
{
|
{
|
match m;
|
match m;
|
int i;
|
int i;
|
|
|
i = ar->dimen;
|
i = ar->dimen;
|
|
|
ar->c_where[i] = gfc_current_locus;
|
ar->c_where[i] = gfc_current_locus;
|
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
|
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
|
|
|
/* We can't be sure of the difference between DIMEN_ELEMENT and
|
/* We can't be sure of the difference between DIMEN_ELEMENT and
|
DIMEN_VECTOR until we know the type of the element itself at
|
DIMEN_VECTOR until we know the type of the element itself at
|
resolution time. */
|
resolution time. */
|
|
|
ar->dimen_type[i] = DIMEN_UNKNOWN;
|
ar->dimen_type[i] = DIMEN_UNKNOWN;
|
|
|
if (gfc_match_char (':') == MATCH_YES)
|
if (gfc_match_char (':') == MATCH_YES)
|
goto end_element;
|
goto end_element;
|
|
|
/* Get start element. */
|
/* Get start element. */
|
if (init)
|
if (init)
|
m = gfc_match_init_expr (&ar->start[i]);
|
m = gfc_match_init_expr (&ar->start[i]);
|
else
|
else
|
m = gfc_match_expr (&ar->start[i]);
|
m = gfc_match_expr (&ar->start[i]);
|
|
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Expected array subscript at %C");
|
gfc_error ("Expected array subscript at %C");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
if (gfc_match_char (':') == MATCH_NO)
|
if (gfc_match_char (':') == MATCH_NO)
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
/* Get an optional end element. Because we've seen the colon, we
|
/* Get an optional end element. Because we've seen the colon, we
|
definitely have a range along this dimension. */
|
definitely have a range along this dimension. */
|
end_element:
|
end_element:
|
ar->dimen_type[i] = DIMEN_RANGE;
|
ar->dimen_type[i] = DIMEN_RANGE;
|
|
|
if (init)
|
if (init)
|
m = gfc_match_init_expr (&ar->end[i]);
|
m = gfc_match_init_expr (&ar->end[i]);
|
else
|
else
|
m = gfc_match_expr (&ar->end[i]);
|
m = gfc_match_expr (&ar->end[i]);
|
|
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
/* See if we have an optional stride. */
|
/* See if we have an optional stride. */
|
if (gfc_match_char (':') == MATCH_YES)
|
if (gfc_match_char (':') == MATCH_YES)
|
{
|
{
|
m = init ? gfc_match_init_expr (&ar->stride[i])
|
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)
|
if (m == MATCH_NO)
|
gfc_error ("Expected array subscript stride at %C");
|
gfc_error ("Expected array subscript stride at %C");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Match an array reference, whether it is the whole array or a
|
/* Match an array reference, whether it is the whole array or a
|
particular elements or a section. If init is set, the reference has
|
particular elements or a section. If init is set, the reference has
|
to consist of init expressions. */
|
to consist of init expressions. */
|
|
|
match
|
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;
|
match m;
|
|
|
memset (ar, '\0', sizeof (ar));
|
memset (ar, '\0', sizeof (ar));
|
|
|
ar->where = gfc_current_locus;
|
ar->where = gfc_current_locus;
|
ar->as = as;
|
ar->as = as;
|
|
|
if (gfc_match_char ('(') != MATCH_YES)
|
if (gfc_match_char ('(') != MATCH_YES)
|
{
|
{
|
ar->type = AR_FULL;
|
ar->type = AR_FULL;
|
ar->dimen = 0;
|
ar->dimen = 0;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
ar->type = AR_UNKNOWN;
|
ar->type = AR_UNKNOWN;
|
|
|
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
|
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
|
{
|
{
|
m = match_subscript (ar, init);
|
m = match_subscript (ar, init);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto error;
|
goto error;
|
|
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
goto matched;
|
goto matched;
|
|
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
{
|
{
|
gfc_error ("Invalid form of array reference at %C");
|
gfc_error ("Invalid form of array reference at %C");
|
goto error;
|
goto error;
|
}
|
}
|
}
|
}
|
|
|
gfc_error ("Array reference at %C cannot have more than %d dimensions",
|
gfc_error ("Array reference at %C cannot have more than %d dimensions",
|
GFC_MAX_DIMENSIONS);
|
GFC_MAX_DIMENSIONS);
|
|
|
error:
|
error:
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
|
|
matched:
|
matched:
|
ar->dimen++;
|
ar->dimen++;
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/************** Array specification matching subroutines ***************/
|
/************** Array specification matching subroutines ***************/
|
|
|
/* Free all of the expressions associated with array bounds
|
/* Free all of the expressions associated with array bounds
|
specifications. */
|
specifications. */
|
|
|
void
|
void
|
gfc_free_array_spec (gfc_array_spec *as)
|
gfc_free_array_spec (gfc_array_spec *as)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (as == NULL)
|
if (as == NULL)
|
return;
|
return;
|
|
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
{
|
{
|
gfc_free_expr (as->lower[i]);
|
gfc_free_expr (as->lower[i]);
|
gfc_free_expr (as->upper[i]);
|
gfc_free_expr (as->upper[i]);
|
}
|
}
|
|
|
gfc_free (as);
|
gfc_free (as);
|
}
|
}
|
|
|
|
|
/* Take an array bound, resolves the expression, that make up the
|
/* Take an array bound, resolves the expression, that make up the
|
shape and check associated constraints. */
|
shape and check associated constraints. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_array_bound (gfc_expr *e, int check_constant)
|
resolve_array_bound (gfc_expr *e, int check_constant)
|
{
|
{
|
if (e == NULL)
|
if (e == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (gfc_resolve_expr (e) == FAILURE
|
if (gfc_resolve_expr (e) == FAILURE
|
|| gfc_specification_expr (e) == FAILURE)
|
|| gfc_specification_expr (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (check_constant && gfc_is_constant_expr (e) == 0)
|
if (check_constant && gfc_is_constant_expr (e) == 0)
|
{
|
{
|
gfc_error ("Variable '%s' at %L in this context must be constant",
|
gfc_error ("Variable '%s' at %L in this context must be constant",
|
e->symtree->n.sym->name, &e->where);
|
e->symtree->n.sym->name, &e->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Takes an array specification, resolves the expressions that make up
|
/* Takes an array specification, resolves the expressions that make up
|
the shape and make sure everything is integral. */
|
the shape and make sure everything is integral. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
|
gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
int i;
|
int i;
|
|
|
if (as == NULL)
|
if (as == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
{
|
{
|
e = as->lower[i];
|
e = as->lower[i];
|
if (resolve_array_bound (e, check_constant) == FAILURE)
|
if (resolve_array_bound (e, check_constant) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
e = as->upper[i];
|
e = as->upper[i];
|
if (resolve_array_bound (e, check_constant) == FAILURE)
|
if (resolve_array_bound (e, check_constant) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
|
if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
|
continue;
|
continue;
|
|
|
/* If the size is negative in this dimension, set it to zero. */
|
/* If the size is negative in this dimension, set it to zero. */
|
if (as->lower[i]->expr_type == EXPR_CONSTANT
|
if (as->lower[i]->expr_type == EXPR_CONSTANT
|
&& as->upper[i]->expr_type == EXPR_CONSTANT
|
&& as->upper[i]->expr_type == EXPR_CONSTANT
|
&& mpz_cmp (as->upper[i]->value.integer,
|
&& mpz_cmp (as->upper[i]->value.integer,
|
as->lower[i]->value.integer) < 0)
|
as->lower[i]->value.integer) < 0)
|
{
|
{
|
gfc_free_expr (as->upper[i]);
|
gfc_free_expr (as->upper[i]);
|
as->upper[i] = gfc_copy_expr (as->lower[i]);
|
as->upper[i] = gfc_copy_expr (as->lower[i]);
|
mpz_sub_ui (as->upper[i]->value.integer,
|
mpz_sub_ui (as->upper[i]->value.integer,
|
as->upper[i]->value.integer, 1);
|
as->upper[i]->value.integer, 1);
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Match a single array element specification. The return values as
|
/* Match a single array element specification. The return values as
|
well as the upper and lower bounds of the array spec are filled
|
well as the upper and lower bounds of the array spec are filled
|
in according to what we see on the input. The caller makes sure
|
in according to what we see on the input. The caller makes sure
|
individual specifications make sense as a whole.
|
individual specifications make sense as a whole.
|
|
|
|
|
Parsed Lower Upper Returned
|
Parsed Lower Upper Returned
|
------------------------------------
|
------------------------------------
|
: NULL NULL AS_DEFERRED (*)
|
: NULL NULL AS_DEFERRED (*)
|
x 1 x AS_EXPLICIT
|
x 1 x AS_EXPLICIT
|
x: x NULL AS_ASSUMED_SHAPE
|
x: x NULL AS_ASSUMED_SHAPE
|
x:y x y AS_EXPLICIT
|
x:y x y AS_EXPLICIT
|
x:* x NULL AS_ASSUMED_SIZE
|
x:* x NULL AS_ASSUMED_SIZE
|
* 1 NULL AS_ASSUMED_SIZE
|
* 1 NULL AS_ASSUMED_SIZE
|
|
|
(*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
|
(*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE. This
|
is fixed during the resolution of formal interfaces.
|
is fixed during the resolution of formal interfaces.
|
|
|
Anything else AS_UNKNOWN. */
|
Anything else AS_UNKNOWN. */
|
|
|
static array_type
|
static array_type
|
match_array_element_spec (gfc_array_spec *as)
|
match_array_element_spec (gfc_array_spec *as)
|
{
|
{
|
gfc_expr **upper, **lower;
|
gfc_expr **upper, **lower;
|
match m;
|
match m;
|
|
|
lower = &as->lower[as->rank - 1];
|
lower = &as->lower[as->rank - 1];
|
upper = &as->upper[as->rank - 1];
|
upper = &as->upper[as->rank - 1];
|
|
|
if (gfc_match_char ('*') == MATCH_YES)
|
if (gfc_match_char ('*') == MATCH_YES)
|
{
|
{
|
*lower = gfc_int_expr (1);
|
*lower = gfc_int_expr (1);
|
return AS_ASSUMED_SIZE;
|
return AS_ASSUMED_SIZE;
|
}
|
}
|
|
|
if (gfc_match_char (':') == MATCH_YES)
|
if (gfc_match_char (':') == MATCH_YES)
|
return AS_DEFERRED;
|
return AS_DEFERRED;
|
|
|
m = gfc_match_expr (upper);
|
m = gfc_match_expr (upper);
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
gfc_error ("Expected expression in array specification at %C");
|
gfc_error ("Expected expression in array specification at %C");
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return AS_UNKNOWN;
|
return AS_UNKNOWN;
|
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
|
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
|
return AS_UNKNOWN;
|
return AS_UNKNOWN;
|
|
|
if (gfc_match_char (':') == MATCH_NO)
|
if (gfc_match_char (':') == MATCH_NO)
|
{
|
{
|
*lower = gfc_int_expr (1);
|
*lower = gfc_int_expr (1);
|
return AS_EXPLICIT;
|
return AS_EXPLICIT;
|
}
|
}
|
|
|
*lower = *upper;
|
*lower = *upper;
|
*upper = NULL;
|
*upper = NULL;
|
|
|
if (gfc_match_char ('*') == MATCH_YES)
|
if (gfc_match_char ('*') == MATCH_YES)
|
return AS_ASSUMED_SIZE;
|
return AS_ASSUMED_SIZE;
|
|
|
m = gfc_match_expr (upper);
|
m = gfc_match_expr (upper);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
return AS_UNKNOWN;
|
return AS_UNKNOWN;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
return AS_ASSUMED_SHAPE;
|
return AS_ASSUMED_SHAPE;
|
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
|
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
|
return AS_UNKNOWN;
|
return AS_UNKNOWN;
|
|
|
return AS_EXPLICIT;
|
return AS_EXPLICIT;
|
}
|
}
|
|
|
|
|
/* Matches an array specification, incidentally figuring out what sort
|
/* Matches an array specification, incidentally figuring out what sort
|
it is. */
|
it is. */
|
|
|
match
|
match
|
gfc_match_array_spec (gfc_array_spec **asp)
|
gfc_match_array_spec (gfc_array_spec **asp)
|
{
|
{
|
array_type current_type;
|
array_type current_type;
|
gfc_array_spec *as;
|
gfc_array_spec *as;
|
int i;
|
int i;
|
|
|
if (gfc_match_char ('(') != MATCH_YES)
|
if (gfc_match_char ('(') != MATCH_YES)
|
{
|
{
|
*asp = NULL;
|
*asp = NULL;
|
return MATCH_NO;
|
return MATCH_NO;
|
}
|
}
|
|
|
as = gfc_get_array_spec ();
|
as = gfc_get_array_spec ();
|
|
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
{
|
{
|
as->lower[i] = NULL;
|
as->lower[i] = NULL;
|
as->upper[i] = NULL;
|
as->upper[i] = NULL;
|
}
|
}
|
|
|
as->rank = 1;
|
as->rank = 1;
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
current_type = match_array_element_spec (as);
|
current_type = match_array_element_spec (as);
|
|
|
if (as->rank == 1)
|
if (as->rank == 1)
|
{
|
{
|
if (current_type == AS_UNKNOWN)
|
if (current_type == AS_UNKNOWN)
|
goto cleanup;
|
goto cleanup;
|
as->type = current_type;
|
as->type = current_type;
|
}
|
}
|
else
|
else
|
switch (as->type)
|
switch (as->type)
|
{ /* See how current spec meshes with the existing. */
|
{ /* See how current spec meshes with the existing. */
|
case AS_UNKNOWN:
|
case AS_UNKNOWN:
|
goto cleanup;
|
goto cleanup;
|
|
|
case AS_EXPLICIT:
|
case AS_EXPLICIT:
|
if (current_type == AS_ASSUMED_SIZE)
|
if (current_type == AS_ASSUMED_SIZE)
|
{
|
{
|
as->type = AS_ASSUMED_SIZE;
|
as->type = AS_ASSUMED_SIZE;
|
break;
|
break;
|
}
|
}
|
|
|
if (current_type == AS_EXPLICIT)
|
if (current_type == AS_EXPLICIT)
|
break;
|
break;
|
|
|
gfc_error ("Bad array specification for an explicitly shaped "
|
gfc_error ("Bad array specification for an explicitly shaped "
|
"array at %C");
|
"array at %C");
|
|
|
goto cleanup;
|
goto cleanup;
|
|
|
case AS_ASSUMED_SHAPE:
|
case AS_ASSUMED_SHAPE:
|
if ((current_type == AS_ASSUMED_SHAPE)
|
if ((current_type == AS_ASSUMED_SHAPE)
|
|| (current_type == AS_DEFERRED))
|
|| (current_type == AS_DEFERRED))
|
break;
|
break;
|
|
|
gfc_error ("Bad array specification for assumed shape "
|
gfc_error ("Bad array specification for assumed shape "
|
"array at %C");
|
"array at %C");
|
goto cleanup;
|
goto cleanup;
|
|
|
case AS_DEFERRED:
|
case AS_DEFERRED:
|
if (current_type == AS_DEFERRED)
|
if (current_type == AS_DEFERRED)
|
break;
|
break;
|
|
|
if (current_type == AS_ASSUMED_SHAPE)
|
if (current_type == AS_ASSUMED_SHAPE)
|
{
|
{
|
as->type = AS_ASSUMED_SHAPE;
|
as->type = AS_ASSUMED_SHAPE;
|
break;
|
break;
|
}
|
}
|
|
|
gfc_error ("Bad specification for deferred shape array at %C");
|
gfc_error ("Bad specification for deferred shape array at %C");
|
goto cleanup;
|
goto cleanup;
|
|
|
case AS_ASSUMED_SIZE:
|
case AS_ASSUMED_SIZE:
|
gfc_error ("Bad specification for assumed size array at %C");
|
gfc_error ("Bad specification for assumed size array at %C");
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (gfc_match_char (')') == MATCH_YES)
|
if (gfc_match_char (')') == MATCH_YES)
|
break;
|
break;
|
|
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
{
|
{
|
gfc_error ("Expected another dimension in array declaration at %C");
|
gfc_error ("Expected another dimension in array declaration at %C");
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (as->rank >= GFC_MAX_DIMENSIONS)
|
if (as->rank >= GFC_MAX_DIMENSIONS)
|
{
|
{
|
gfc_error ("Array specification at %C has more than %d dimensions",
|
gfc_error ("Array specification at %C has more than %d dimensions",
|
GFC_MAX_DIMENSIONS);
|
GFC_MAX_DIMENSIONS);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
if (as->rank >= 7
|
if (as->rank >= 7
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
|
&& gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
|
"specification at %C with more than 7 dimensions")
|
"specification at %C with more than 7 dimensions")
|
== FAILURE)
|
== FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
as->rank++;
|
as->rank++;
|
}
|
}
|
|
|
/* If a lower bounds of an assumed shape array is blank, put in one. */
|
/* If a lower bounds of an assumed shape array is blank, put in one. */
|
if (as->type == AS_ASSUMED_SHAPE)
|
if (as->type == AS_ASSUMED_SHAPE)
|
{
|
{
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
{
|
{
|
if (as->lower[i] == NULL)
|
if (as->lower[i] == NULL)
|
as->lower[i] = gfc_int_expr (1);
|
as->lower[i] = gfc_int_expr (1);
|
}
|
}
|
}
|
}
|
*asp = as;
|
*asp = as;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
cleanup:
|
cleanup:
|
/* Something went wrong. */
|
/* Something went wrong. */
|
gfc_free_array_spec (as);
|
gfc_free_array_spec (as);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
/* Given a symbol and an array specification, modify the symbol to
|
/* Given a symbol and an array specification, modify the symbol to
|
have that array specification. The error locus is needed in case
|
have that array specification. The error locus is needed in case
|
something goes wrong. On failure, the caller must free the spec. */
|
something goes wrong. On failure, the caller must free the spec. */
|
|
|
gfc_try
|
gfc_try
|
gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
|
gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
|
{
|
{
|
if (as == NULL)
|
if (as == NULL)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
|
if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
sym->as = as;
|
sym->as = as;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Copy an array specification. */
|
/* Copy an array specification. */
|
|
|
gfc_array_spec *
|
gfc_array_spec *
|
gfc_copy_array_spec (gfc_array_spec *src)
|
gfc_copy_array_spec (gfc_array_spec *src)
|
{
|
{
|
gfc_array_spec *dest;
|
gfc_array_spec *dest;
|
int i;
|
int i;
|
|
|
if (src == NULL)
|
if (src == NULL)
|
return NULL;
|
return NULL;
|
|
|
dest = gfc_get_array_spec ();
|
dest = gfc_get_array_spec ();
|
|
|
*dest = *src;
|
*dest = *src;
|
|
|
for (i = 0; i < dest->rank; i++)
|
for (i = 0; i < dest->rank; i++)
|
{
|
{
|
dest->lower[i] = gfc_copy_expr (dest->lower[i]);
|
dest->lower[i] = gfc_copy_expr (dest->lower[i]);
|
dest->upper[i] = gfc_copy_expr (dest->upper[i]);
|
dest->upper[i] = gfc_copy_expr (dest->upper[i]);
|
}
|
}
|
|
|
return dest;
|
return dest;
|
}
|
}
|
|
|
|
|
/* Returns nonzero if the two expressions are equal. Only handles integer
|
/* Returns nonzero if the two expressions are equal. Only handles integer
|
constants. */
|
constants. */
|
|
|
static int
|
static int
|
compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
|
compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
|
{
|
{
|
if (bound1 == NULL || bound2 == NULL
|
if (bound1 == NULL || bound2 == NULL
|
|| bound1->expr_type != EXPR_CONSTANT
|
|| bound1->expr_type != EXPR_CONSTANT
|
|| bound2->expr_type != EXPR_CONSTANT
|
|| bound2->expr_type != EXPR_CONSTANT
|
|| bound1->ts.type != BT_INTEGER
|
|| bound1->ts.type != BT_INTEGER
|
|| bound2->ts.type != BT_INTEGER)
|
|| bound2->ts.type != BT_INTEGER)
|
gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
|
gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
|
|
|
if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
|
if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
|
return 1;
|
return 1;
|
else
|
else
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Compares two array specifications. They must be constant or deferred
|
/* Compares two array specifications. They must be constant or deferred
|
shape. */
|
shape. */
|
|
|
int
|
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;
|
int i;
|
|
|
if (as1 == NULL && as2 == NULL)
|
if (as1 == NULL && as2 == NULL)
|
return 1;
|
return 1;
|
|
|
if (as1 == NULL || as2 == NULL)
|
if (as1 == NULL || as2 == NULL)
|
return 0;
|
return 0;
|
|
|
if (as1->rank != as2->rank)
|
if (as1->rank != as2->rank)
|
return 0;
|
return 0;
|
|
|
if (as1->rank == 0)
|
if (as1->rank == 0)
|
return 1;
|
return 1;
|
|
|
if (as1->type != as2->type)
|
if (as1->type != as2->type)
|
return 0;
|
return 0;
|
|
|
if (as1->type == AS_EXPLICIT)
|
if (as1->type == AS_EXPLICIT)
|
for (i = 0; i < as1->rank; i++)
|
for (i = 0; i < as1->rank; i++)
|
{
|
{
|
if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
|
if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
|
return 0;
|
return 0;
|
|
|
if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
|
if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
|
return 0;
|
return 0;
|
}
|
}
|
|
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
/****************** Array constructor functions ******************/
|
/****************** Array constructor functions ******************/
|
|
|
/* Start an array constructor. The constructor starts with zero
|
/* Start an array constructor. The constructor starts with zero
|
elements and should be appended to by gfc_append_constructor(). */
|
elements and should be appended to by gfc_append_constructor(). */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_start_constructor (bt type, int kind, locus *where)
|
gfc_start_constructor (bt type, int kind, locus *where)
|
{
|
{
|
gfc_expr *result;
|
gfc_expr *result;
|
|
|
result = gfc_get_expr ();
|
result = gfc_get_expr ();
|
|
|
result->expr_type = EXPR_ARRAY;
|
result->expr_type = EXPR_ARRAY;
|
result->rank = 1;
|
result->rank = 1;
|
|
|
result->ts.type = type;
|
result->ts.type = type;
|
result->ts.kind = kind;
|
result->ts.kind = kind;
|
result->where = *where;
|
result->where = *where;
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/* Given an array constructor expression, append the new expression
|
/* Given an array constructor expression, append the new expression
|
node onto the constructor. */
|
node onto the constructor. */
|
|
|
void
|
void
|
gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
|
gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
|
{
|
{
|
gfc_constructor *c;
|
gfc_constructor *c;
|
|
|
if (base->value.constructor == NULL)
|
if (base->value.constructor == NULL)
|
base->value.constructor = c = gfc_get_constructor ();
|
base->value.constructor = c = gfc_get_constructor ();
|
else
|
else
|
{
|
{
|
c = base->value.constructor;
|
c = base->value.constructor;
|
while (c->next)
|
while (c->next)
|
c = c->next;
|
c = c->next;
|
|
|
c->next = gfc_get_constructor ();
|
c->next = gfc_get_constructor ();
|
c = c->next;
|
c = c->next;
|
}
|
}
|
|
|
c->expr = new_expr;
|
c->expr = new_expr;
|
|
|
if (new_expr
|
if (new_expr
|
&& (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
|
&& (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_internal_error ("gfc_append_constructor(): New node has wrong kind");
|
}
|
}
|
|
|
|
|
/* Given an array constructor expression, insert the new expression's
|
/* Given an array constructor expression, insert the new expression's
|
constructor onto the base's one according to the offset. */
|
constructor onto the base's one according to the offset. */
|
|
|
void
|
void
|
gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
|
gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
|
{
|
{
|
gfc_constructor *c, *pre;
|
gfc_constructor *c, *pre;
|
expr_t type;
|
expr_t type;
|
int t;
|
int t;
|
|
|
type = base->expr_type;
|
type = base->expr_type;
|
|
|
if (base->value.constructor == NULL)
|
if (base->value.constructor == NULL)
|
base->value.constructor = c1;
|
base->value.constructor = c1;
|
else
|
else
|
{
|
{
|
c = pre = base->value.constructor;
|
c = pre = base->value.constructor;
|
while (c)
|
while (c)
|
{
|
{
|
if (type == EXPR_ARRAY)
|
if (type == EXPR_ARRAY)
|
{
|
{
|
t = mpz_cmp (c->n.offset, c1->n.offset);
|
t = mpz_cmp (c->n.offset, c1->n.offset);
|
if (t < 0)
|
if (t < 0)
|
{
|
{
|
pre = c;
|
pre = c;
|
c = c->next;
|
c = c->next;
|
}
|
}
|
else if (t == 0)
|
else if (t == 0)
|
{
|
{
|
gfc_error ("duplicated initializer");
|
gfc_error ("duplicated initializer");
|
break;
|
break;
|
}
|
}
|
else
|
else
|
break;
|
break;
|
}
|
}
|
else
|
else
|
{
|
{
|
pre = c;
|
pre = c;
|
c = c->next;
|
c = c->next;
|
}
|
}
|
}
|
}
|
|
|
if (pre != c)
|
if (pre != c)
|
{
|
{
|
pre->next = c1;
|
pre->next = c1;
|
c1->next = c;
|
c1->next = c;
|
}
|
}
|
else
|
else
|
{
|
{
|
c1->next = c;
|
c1->next = c;
|
base->value.constructor = c1;
|
base->value.constructor = c1;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Get a new constructor. */
|
/* Get a new constructor. */
|
|
|
gfc_constructor *
|
gfc_constructor *
|
gfc_get_constructor (void)
|
gfc_get_constructor (void)
|
{
|
{
|
gfc_constructor *c;
|
gfc_constructor *c;
|
|
|
c = XCNEW (gfc_constructor);
|
c = XCNEW (gfc_constructor);
|
c->expr = NULL;
|
c->expr = NULL;
|
c->iterator = NULL;
|
c->iterator = NULL;
|
c->next = NULL;
|
c->next = NULL;
|
mpz_init_set_si (c->n.offset, 0);
|
mpz_init_set_si (c->n.offset, 0);
|
mpz_init_set_si (c->repeat, 0);
|
mpz_init_set_si (c->repeat, 0);
|
return c;
|
return c;
|
}
|
}
|
|
|
|
|
/* Free chains of gfc_constructor structures. */
|
/* Free chains of gfc_constructor structures. */
|
|
|
void
|
void
|
gfc_free_constructor (gfc_constructor *p)
|
gfc_free_constructor (gfc_constructor *p)
|
{
|
{
|
gfc_constructor *next;
|
gfc_constructor *next;
|
|
|
if (p == NULL)
|
if (p == NULL)
|
return;
|
return;
|
|
|
for (; p; p = next)
|
for (; p; p = next)
|
{
|
{
|
next = p->next;
|
next = p->next;
|
|
|
if (p->expr)
|
if (p->expr)
|
gfc_free_expr (p->expr);
|
gfc_free_expr (p->expr);
|
if (p->iterator != NULL)
|
if (p->iterator != NULL)
|
gfc_free_iterator (p->iterator, 1);
|
gfc_free_iterator (p->iterator, 1);
|
mpz_clear (p->n.offset);
|
mpz_clear (p->n.offset);
|
mpz_clear (p->repeat);
|
mpz_clear (p->repeat);
|
gfc_free (p);
|
gfc_free (p);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Given an expression node that might be an array constructor and a
|
/* Given an expression node that might be an array constructor and a
|
symbol, make sure that no iterators in this or child constructors
|
symbol, make sure that no iterators in this or child constructors
|
use the symbol as an implied-DO iterator. Returns nonzero if a
|
use the symbol as an implied-DO iterator. Returns nonzero if a
|
duplicate was found. */
|
duplicate was found. */
|
|
|
static int
|
static int
|
check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
|
check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
{
|
{
|
e = c->expr;
|
e = c->expr;
|
|
|
if (e->expr_type == EXPR_ARRAY
|
if (e->expr_type == EXPR_ARRAY
|
&& check_duplicate_iterator (e->value.constructor, master))
|
&& check_duplicate_iterator (e->value.constructor, master))
|
return 1;
|
return 1;
|
|
|
if (c->iterator == NULL)
|
if (c->iterator == NULL)
|
continue;
|
continue;
|
|
|
if (c->iterator->var->symtree->n.sym == master)
|
if (c->iterator->var->symtree->n.sym == master)
|
{
|
{
|
gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
|
gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
|
"same name", master->name, &c->where);
|
"same name", master->name, &c->where);
|
|
|
return 1;
|
return 1;
|
}
|
}
|
}
|
}
|
|
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/* Forward declaration because these functions are mutually recursive. */
|
/* Forward declaration because these functions are mutually recursive. */
|
static match match_array_cons_element (gfc_constructor **);
|
static match match_array_cons_element (gfc_constructor **);
|
|
|
/* Match a list of array elements. */
|
/* Match a list of array elements. */
|
|
|
static match
|
static match
|
match_array_list (gfc_constructor **result)
|
match_array_list (gfc_constructor **result)
|
{
|
{
|
gfc_constructor *p, *head, *tail, *new_cons;
|
gfc_constructor *p, *head, *tail, *new_cons;
|
gfc_iterator iter;
|
gfc_iterator iter;
|
locus old_loc;
|
locus old_loc;
|
gfc_expr *e;
|
gfc_expr *e;
|
match m;
|
match m;
|
int n;
|
int n;
|
|
|
old_loc = gfc_current_locus;
|
old_loc = gfc_current_locus;
|
|
|
if (gfc_match_char ('(') == MATCH_NO)
|
if (gfc_match_char ('(') == MATCH_NO)
|
return MATCH_NO;
|
return MATCH_NO;
|
|
|
memset (&iter, '\0', sizeof (gfc_iterator));
|
memset (&iter, '\0', sizeof (gfc_iterator));
|
head = NULL;
|
head = NULL;
|
|
|
m = match_array_cons_element (&head);
|
m = match_array_cons_element (&head);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
goto cleanup;
|
goto cleanup;
|
|
|
tail = head;
|
tail = head;
|
|
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
{
|
{
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
for (n = 1;; n++)
|
for (n = 1;; n++)
|
{
|
{
|
m = gfc_match_iterator (&iter, 0);
|
m = gfc_match_iterator (&iter, 0);
|
if (m == MATCH_YES)
|
if (m == MATCH_YES)
|
break;
|
break;
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
|
|
m = match_array_cons_element (&new_cons);
|
m = match_array_cons_element (&new_cons);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
{
|
{
|
if (n > 2)
|
if (n > 2)
|
goto syntax;
|
goto syntax;
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup; /* Could be a complex constant */
|
goto cleanup; /* Could be a complex constant */
|
}
|
}
|
|
|
tail->next = new_cons;
|
tail->next = new_cons;
|
tail = new_cons;
|
tail = new_cons;
|
|
|
if (gfc_match_char (',') != MATCH_YES)
|
if (gfc_match_char (',') != MATCH_YES)
|
{
|
{
|
if (n > 2)
|
if (n > 2)
|
goto syntax;
|
goto syntax;
|
m = MATCH_NO;
|
m = MATCH_NO;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
if (gfc_match_char (')') != MATCH_YES)
|
if (gfc_match_char (')') != MATCH_YES)
|
goto syntax;
|
goto syntax;
|
|
|
if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
|
if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
|
{
|
{
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->expr_type = EXPR_ARRAY;
|
e->expr_type = EXPR_ARRAY;
|
e->where = old_loc;
|
e->where = old_loc;
|
e->value.constructor = head;
|
e->value.constructor = head;
|
|
|
p = gfc_get_constructor ();
|
p = gfc_get_constructor ();
|
p->where = gfc_current_locus;
|
p->where = gfc_current_locus;
|
p->iterator = gfc_get_iterator ();
|
p->iterator = gfc_get_iterator ();
|
*p->iterator = iter;
|
*p->iterator = iter;
|
|
|
p->expr = e;
|
p->expr = e;
|
*result = p;
|
*result = p;
|
|
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in array constructor at %C");
|
gfc_error ("Syntax error in array constructor at %C");
|
m = MATCH_ERROR;
|
m = MATCH_ERROR;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
gfc_free_iterator (&iter, 0);
|
gfc_free_iterator (&iter, 0);
|
gfc_current_locus = old_loc;
|
gfc_current_locus = old_loc;
|
return m;
|
return m;
|
}
|
}
|
|
|
|
|
/* Match a single element of an array constructor, which can be a
|
/* Match a single element of an array constructor, which can be a
|
single expression or a list of elements. */
|
single expression or a list of elements. */
|
|
|
static match
|
static match
|
match_array_cons_element (gfc_constructor **result)
|
match_array_cons_element (gfc_constructor **result)
|
{
|
{
|
gfc_constructor *p;
|
gfc_constructor *p;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
match m;
|
match m;
|
|
|
m = match_array_list (result);
|
m = match_array_list (result);
|
if (m != MATCH_NO)
|
if (m != MATCH_NO)
|
return m;
|
return m;
|
|
|
m = gfc_match_expr (&expr);
|
m = gfc_match_expr (&expr);
|
if (m != MATCH_YES)
|
if (m != MATCH_YES)
|
return m;
|
return m;
|
|
|
p = gfc_get_constructor ();
|
p = gfc_get_constructor ();
|
p->where = gfc_current_locus;
|
p->where = gfc_current_locus;
|
p->expr = expr;
|
p->expr = expr;
|
|
|
*result = p;
|
*result = p;
|
return MATCH_YES;
|
return MATCH_YES;
|
}
|
}
|
|
|
|
|
/* Match an array constructor. */
|
/* Match an array constructor. */
|
|
|
match
|
match
|
gfc_match_array_constructor (gfc_expr **result)
|
gfc_match_array_constructor (gfc_expr **result)
|
{
|
{
|
gfc_constructor *head, *tail, *new_cons;
|
gfc_constructor *head, *tail, *new_cons;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
gfc_typespec ts;
|
gfc_typespec ts;
|
locus where;
|
locus where;
|
match m;
|
match m;
|
const char *end_delim;
|
const char *end_delim;
|
bool seen_ts;
|
bool seen_ts;
|
|
|
if (gfc_match (" (/") == MATCH_NO)
|
if (gfc_match (" (/") == MATCH_NO)
|
{
|
{
|
if (gfc_match (" [") == MATCH_NO)
|
if (gfc_match (" [") == MATCH_NO)
|
return MATCH_NO;
|
return MATCH_NO;
|
else
|
else
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
|
"style array constructors at %C") == FAILURE)
|
"style array constructors at %C") == FAILURE)
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
end_delim = " ]";
|
end_delim = " ]";
|
}
|
}
|
}
|
}
|
else
|
else
|
end_delim = " /)";
|
end_delim = " /)";
|
|
|
where = gfc_current_locus;
|
where = gfc_current_locus;
|
head = tail = NULL;
|
head = tail = NULL;
|
seen_ts = false;
|
seen_ts = false;
|
|
|
/* Try to match an optional "type-spec ::" */
|
/* Try to match an optional "type-spec ::" */
|
if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
|
if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
|
{
|
{
|
seen_ts = (gfc_match (" ::") == MATCH_YES);
|
seen_ts = (gfc_match (" ::") == MATCH_YES);
|
|
|
if (seen_ts)
|
if (seen_ts)
|
{
|
{
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
|
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
|
"including type specification at %C") == FAILURE)
|
"including type specification at %C") == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
if (! seen_ts)
|
if (! seen_ts)
|
gfc_current_locus = where;
|
gfc_current_locus = where;
|
|
|
if (gfc_match (end_delim) == MATCH_YES)
|
if (gfc_match (end_delim) == MATCH_YES)
|
{
|
{
|
if (seen_ts)
|
if (seen_ts)
|
goto done;
|
goto done;
|
else
|
else
|
{
|
{
|
gfc_error ("Empty array constructor at %C is not allowed");
|
gfc_error ("Empty array constructor at %C is not allowed");
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
}
|
}
|
|
|
for (;;)
|
for (;;)
|
{
|
{
|
m = match_array_cons_element (&new_cons);
|
m = match_array_cons_element (&new_cons);
|
if (m == MATCH_ERROR)
|
if (m == MATCH_ERROR)
|
goto cleanup;
|
goto cleanup;
|
if (m == MATCH_NO)
|
if (m == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
|
|
if (head == NULL)
|
if (head == NULL)
|
head = new_cons;
|
head = new_cons;
|
else
|
else
|
tail->next = new_cons;
|
tail->next = new_cons;
|
|
|
tail = new_cons;
|
tail = new_cons;
|
|
|
if (gfc_match_char (',') == MATCH_NO)
|
if (gfc_match_char (',') == MATCH_NO)
|
break;
|
break;
|
}
|
}
|
|
|
if (gfc_match (end_delim) == MATCH_NO)
|
if (gfc_match (end_delim) == MATCH_NO)
|
goto syntax;
|
goto syntax;
|
|
|
done:
|
done:
|
expr = gfc_get_expr ();
|
expr = gfc_get_expr ();
|
|
|
expr->expr_type = EXPR_ARRAY;
|
expr->expr_type = EXPR_ARRAY;
|
|
|
expr->value.constructor = head;
|
expr->value.constructor = head;
|
/* Size must be calculated at resolution time. */
|
/* Size must be calculated at resolution time. */
|
|
|
if (seen_ts)
|
if (seen_ts)
|
expr->ts = ts;
|
expr->ts = ts;
|
else
|
else
|
expr->ts.type = BT_UNKNOWN;
|
expr->ts.type = BT_UNKNOWN;
|
|
|
if (expr->ts.u.cl)
|
if (expr->ts.u.cl)
|
expr->ts.u.cl->length_from_typespec = seen_ts;
|
expr->ts.u.cl->length_from_typespec = seen_ts;
|
|
|
expr->where = where;
|
expr->where = where;
|
expr->rank = 1;
|
expr->rank = 1;
|
|
|
*result = expr;
|
*result = expr;
|
return MATCH_YES;
|
return MATCH_YES;
|
|
|
syntax:
|
syntax:
|
gfc_error ("Syntax error in array constructor at %C");
|
gfc_error ("Syntax error in array constructor at %C");
|
|
|
cleanup:
|
cleanup:
|
gfc_free_constructor (head);
|
gfc_free_constructor (head);
|
return MATCH_ERROR;
|
return MATCH_ERROR;
|
}
|
}
|
|
|
|
|
|
|
/************** Check array constructors for correctness **************/
|
/************** Check array constructors for correctness **************/
|
|
|
/* Given an expression, compare it's type with the type of the current
|
/* Given an expression, compare it's type with the type of the current
|
constructor. Returns nonzero if an error was issued. The
|
constructor. Returns nonzero if an error was issued. The
|
cons_state variable keeps track of whether the type of the
|
cons_state variable keeps track of whether the type of the
|
constructor being read or resolved is known to be good, bad or just
|
constructor being read or resolved is known to be good, bad or just
|
starting out. */
|
starting out. */
|
|
|
static gfc_typespec constructor_ts;
|
static gfc_typespec constructor_ts;
|
static enum
|
static enum
|
{ CONS_START, CONS_GOOD, CONS_BAD }
|
{ CONS_START, CONS_GOOD, CONS_BAD }
|
cons_state;
|
cons_state;
|
|
|
static int
|
static int
|
check_element_type (gfc_expr *expr, bool convert)
|
check_element_type (gfc_expr *expr, bool convert)
|
{
|
{
|
if (cons_state == CONS_BAD)
|
if (cons_state == CONS_BAD)
|
return 0; /* Suppress further errors */
|
return 0; /* Suppress further errors */
|
|
|
if (cons_state == CONS_START)
|
if (cons_state == CONS_START)
|
{
|
{
|
if (expr->ts.type == BT_UNKNOWN)
|
if (expr->ts.type == BT_UNKNOWN)
|
cons_state = CONS_BAD;
|
cons_state = CONS_BAD;
|
else
|
else
|
{
|
{
|
cons_state = CONS_GOOD;
|
cons_state = CONS_GOOD;
|
constructor_ts = expr->ts;
|
constructor_ts = expr->ts;
|
}
|
}
|
|
|
return 0;
|
return 0;
|
}
|
}
|
|
|
if (gfc_compare_types (&constructor_ts, &expr->ts))
|
if (gfc_compare_types (&constructor_ts, &expr->ts))
|
return 0;
|
return 0;
|
|
|
if (convert)
|
if (convert)
|
return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
|
return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
|
|
|
gfc_error ("Element in %s array constructor at %L is %s",
|
gfc_error ("Element in %s array constructor at %L is %s",
|
gfc_typename (&constructor_ts), &expr->where,
|
gfc_typename (&constructor_ts), &expr->where,
|
gfc_typename (&expr->ts));
|
gfc_typename (&expr->ts));
|
|
|
cons_state = CONS_BAD;
|
cons_state = CONS_BAD;
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
/* Recursive work function for gfc_check_constructor_type(). */
|
/* Recursive work function for gfc_check_constructor_type(). */
|
|
|
static gfc_try
|
static gfc_try
|
check_constructor_type (gfc_constructor *c, bool convert)
|
check_constructor_type (gfc_constructor *c, bool convert)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
{
|
{
|
e = c->expr;
|
e = c->expr;
|
|
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
{
|
{
|
if (check_constructor_type (e->value.constructor, convert) == FAILURE)
|
if (check_constructor_type (e->value.constructor, convert) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
continue;
|
continue;
|
}
|
}
|
|
|
if (check_element_type (e, convert))
|
if (check_element_type (e, convert))
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Check that all elements of an array constructor are the same type.
|
/* Check that all elements of an array constructor are the same type.
|
On FAILURE, an error has been generated. */
|
On FAILURE, an error has been generated. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_constructor_type (gfc_expr *e)
|
gfc_check_constructor_type (gfc_expr *e)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
if (e->ts.type != BT_UNKNOWN)
|
if (e->ts.type != BT_UNKNOWN)
|
{
|
{
|
cons_state = CONS_GOOD;
|
cons_state = CONS_GOOD;
|
constructor_ts = e->ts;
|
constructor_ts = e->ts;
|
}
|
}
|
else
|
else
|
{
|
{
|
cons_state = CONS_START;
|
cons_state = CONS_START;
|
gfc_clear_ts (&constructor_ts);
|
gfc_clear_ts (&constructor_ts);
|
}
|
}
|
|
|
/* If e->ts.type != BT_UNKNOWN, the array constructor included a
|
/* If e->ts.type != BT_UNKNOWN, the array constructor included a
|
typespec, and we will now convert the values on the fly. */
|
typespec, and we will now convert the values on the fly. */
|
t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
|
t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
|
if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
|
if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
|
e->ts = constructor_ts;
|
e->ts = constructor_ts;
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
|
|
typedef struct cons_stack
|
typedef struct cons_stack
|
{
|
{
|
gfc_iterator *iterator;
|
gfc_iterator *iterator;
|
struct cons_stack *previous;
|
struct cons_stack *previous;
|
}
|
}
|
cons_stack;
|
cons_stack;
|
|
|
static cons_stack *base;
|
static cons_stack *base;
|
|
|
static gfc_try check_constructor (gfc_constructor *, gfc_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
|
/* Check an EXPR_VARIABLE expression in a constructor to make sure
|
that that variable is an iteration variables. */
|
that that variable is an iteration variables. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_iter_variable (gfc_expr *expr)
|
gfc_check_iter_variable (gfc_expr *expr)
|
{
|
{
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
cons_stack *c;
|
cons_stack *c;
|
|
|
sym = expr->symtree->n.sym;
|
sym = expr->symtree->n.sym;
|
|
|
for (c = base; c; c = c->previous)
|
for (c = base; c; c = c->previous)
|
if (sym == c->iterator->var->symtree->n.sym)
|
if (sym == c->iterator->var->symtree->n.sym)
|
return SUCCESS;
|
return SUCCESS;
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Recursive work function for gfc_check_constructor(). This amounts
|
/* Recursive work function for gfc_check_constructor(). This amounts
|
to calling the check function for each expression in the
|
to calling the check function for each expression in the
|
constructor, giving variables with the names of iterators a pass. */
|
constructor, giving variables with the names of iterators a pass. */
|
|
|
static gfc_try
|
static gfc_try
|
check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
|
check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
|
{
|
{
|
cons_stack element;
|
cons_stack element;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_try t;
|
gfc_try t;
|
|
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
{
|
{
|
e = c->expr;
|
e = c->expr;
|
|
|
if (e->expr_type != EXPR_ARRAY)
|
if (e->expr_type != EXPR_ARRAY)
|
{
|
{
|
if ((*check_function) (e) == FAILURE)
|
if ((*check_function) (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
continue;
|
continue;
|
}
|
}
|
|
|
element.previous = base;
|
element.previous = base;
|
element.iterator = c->iterator;
|
element.iterator = c->iterator;
|
|
|
base = &element;
|
base = &element;
|
t = check_constructor (e->value.constructor, check_function);
|
t = check_constructor (e->value.constructor, check_function);
|
base = element.previous;
|
base = element.previous;
|
|
|
if (t == FAILURE)
|
if (t == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
/* Nothing went wrong, so all OK. */
|
/* Nothing went wrong, so all OK. */
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Checks a constructor to see if it is a particular kind of
|
/* Checks a constructor to see if it is a particular kind of
|
expression -- specification, restricted, or initialization as
|
expression -- specification, restricted, or initialization as
|
determined by the check_function. */
|
determined by the check_function. */
|
|
|
gfc_try
|
gfc_try
|
gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
|
gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
|
{
|
{
|
cons_stack *base_save;
|
cons_stack *base_save;
|
gfc_try t;
|
gfc_try t;
|
|
|
base_save = base;
|
base_save = base;
|
base = NULL;
|
base = NULL;
|
|
|
t = check_constructor (expr->value.constructor, check_function);
|
t = check_constructor (expr->value.constructor, check_function);
|
base = base_save;
|
base = base_save;
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
|
|
/**************** Simplification of array constructors ****************/
|
/**************** Simplification of array constructors ****************/
|
|
|
iterator_stack *iter_stack;
|
iterator_stack *iter_stack;
|
|
|
typedef struct
|
typedef struct
|
{
|
{
|
gfc_constructor *new_head, *new_tail;
|
gfc_constructor *new_head, *new_tail;
|
int extract_count, extract_n;
|
int extract_count, extract_n;
|
gfc_expr *extracted;
|
gfc_expr *extracted;
|
mpz_t *count;
|
mpz_t *count;
|
|
|
mpz_t *offset;
|
mpz_t *offset;
|
gfc_component *component;
|
gfc_component *component;
|
mpz_t *repeat;
|
mpz_t *repeat;
|
|
|
gfc_try (*expand_work_function) (gfc_expr *);
|
gfc_try (*expand_work_function) (gfc_expr *);
|
}
|
}
|
expand_info;
|
expand_info;
|
|
|
static expand_info current_expand;
|
static expand_info current_expand;
|
|
|
static gfc_try expand_constructor (gfc_constructor *);
|
static gfc_try expand_constructor (gfc_constructor *);
|
|
|
|
|
/* Work function that counts the number of elements present in a
|
/* Work function that counts the number of elements present in a
|
constructor. */
|
constructor. */
|
|
|
static gfc_try
|
static gfc_try
|
count_elements (gfc_expr *e)
|
count_elements (gfc_expr *e)
|
{
|
{
|
mpz_t result;
|
mpz_t result;
|
|
|
if (e->rank == 0)
|
if (e->rank == 0)
|
mpz_add_ui (*current_expand.count, *current_expand.count, 1);
|
mpz_add_ui (*current_expand.count, *current_expand.count, 1);
|
else
|
else
|
{
|
{
|
if (gfc_array_size (e, &result) == FAILURE)
|
if (gfc_array_size (e, &result) == FAILURE)
|
{
|
{
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
mpz_add (*current_expand.count, *current_expand.count, result);
|
mpz_add (*current_expand.count, *current_expand.count, result);
|
mpz_clear (result);
|
mpz_clear (result);
|
}
|
}
|
|
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Work function that extracts a particular element from an array
|
/* Work function that extracts a particular element from an array
|
constructor, freeing the rest. */
|
constructor, freeing the rest. */
|
|
|
static gfc_try
|
static gfc_try
|
extract_element (gfc_expr *e)
|
extract_element (gfc_expr *e)
|
{
|
{
|
if (e->rank != 0)
|
if (e->rank != 0)
|
{ /* Something unextractable */
|
{ /* Something unextractable */
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
if (current_expand.extract_count == current_expand.extract_n)
|
if (current_expand.extract_count == current_expand.extract_n)
|
current_expand.extracted = e;
|
current_expand.extracted = e;
|
else
|
else
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
current_expand.extract_count++;
|
current_expand.extract_count++;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Work function that constructs a new constructor out of the old one,
|
/* Work function that constructs a new constructor out of the old one,
|
stringing new elements together. */
|
stringing new elements together. */
|
|
|
static gfc_try
|
static gfc_try
|
expand (gfc_expr *e)
|
expand (gfc_expr *e)
|
{
|
{
|
if (current_expand.new_head == NULL)
|
if (current_expand.new_head == NULL)
|
current_expand.new_head = current_expand.new_tail =
|
current_expand.new_head = current_expand.new_tail =
|
gfc_get_constructor ();
|
gfc_get_constructor ();
|
else
|
else
|
{
|
{
|
current_expand.new_tail->next = gfc_get_constructor ();
|
current_expand.new_tail->next = gfc_get_constructor ();
|
current_expand.new_tail = current_expand.new_tail->next;
|
current_expand.new_tail = current_expand.new_tail->next;
|
}
|
}
|
|
|
current_expand.new_tail->where = e->where;
|
current_expand.new_tail->where = e->where;
|
current_expand.new_tail->expr = e;
|
current_expand.new_tail->expr = e;
|
|
|
mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
|
mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
|
current_expand.new_tail->n.component = current_expand.component;
|
current_expand.new_tail->n.component = current_expand.component;
|
mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
|
mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an initialization expression that is a variable reference,
|
/* Given an initialization expression that is a variable reference,
|
substitute the current value of the iteration variable. */
|
substitute the current value of the iteration variable. */
|
|
|
void
|
void
|
gfc_simplify_iterator_var (gfc_expr *e)
|
gfc_simplify_iterator_var (gfc_expr *e)
|
{
|
{
|
iterator_stack *p;
|
iterator_stack *p;
|
|
|
for (p = iter_stack; p; p = p->prev)
|
for (p = iter_stack; p; p = p->prev)
|
if (e->symtree == p->variable)
|
if (e->symtree == p->variable)
|
break;
|
break;
|
|
|
if (p == NULL)
|
if (p == NULL)
|
return; /* Variable not found */
|
return; /* Variable not found */
|
|
|
gfc_replace_expr (e, gfc_int_expr (0));
|
gfc_replace_expr (e, gfc_int_expr (0));
|
|
|
mpz_set (e->value.integer, p->value);
|
mpz_set (e->value.integer, p->value);
|
|
|
return;
|
return;
|
}
|
}
|
|
|
|
|
/* Expand an expression with that is inside of a constructor,
|
/* Expand an expression with that is inside of a constructor,
|
recursing into other constructors if present. */
|
recursing into other constructors if present. */
|
|
|
static gfc_try
|
static gfc_try
|
expand_expr (gfc_expr *e)
|
expand_expr (gfc_expr *e)
|
{
|
{
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
return expand_constructor (e->value.constructor);
|
return expand_constructor (e->value.constructor);
|
|
|
e = gfc_copy_expr (e);
|
e = gfc_copy_expr (e);
|
|
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
{
|
{
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
return current_expand.expand_work_function (e);
|
return current_expand.expand_work_function (e);
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
expand_iterator (gfc_constructor *c)
|
expand_iterator (gfc_constructor *c)
|
{
|
{
|
gfc_expr *start, *end, *step;
|
gfc_expr *start, *end, *step;
|
iterator_stack frame;
|
iterator_stack frame;
|
mpz_t trip;
|
mpz_t trip;
|
gfc_try t;
|
gfc_try t;
|
|
|
end = step = NULL;
|
end = step = NULL;
|
|
|
t = FAILURE;
|
t = FAILURE;
|
|
|
mpz_init (trip);
|
mpz_init (trip);
|
mpz_init (frame.value);
|
mpz_init (frame.value);
|
frame.prev = NULL;
|
frame.prev = NULL;
|
|
|
start = gfc_copy_expr (c->iterator->start);
|
start = gfc_copy_expr (c->iterator->start);
|
if (gfc_simplify_expr (start, 1) == FAILURE)
|
if (gfc_simplify_expr (start, 1) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
|
if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
|
goto cleanup;
|
goto cleanup;
|
|
|
end = gfc_copy_expr (c->iterator->end);
|
end = gfc_copy_expr (c->iterator->end);
|
if (gfc_simplify_expr (end, 1) == FAILURE)
|
if (gfc_simplify_expr (end, 1) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
|
if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
|
goto cleanup;
|
goto cleanup;
|
|
|
step = gfc_copy_expr (c->iterator->step);
|
step = gfc_copy_expr (c->iterator->step);
|
if (gfc_simplify_expr (step, 1) == FAILURE)
|
if (gfc_simplify_expr (step, 1) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
|
if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
|
goto cleanup;
|
goto cleanup;
|
|
|
if (mpz_sgn (step->value.integer) == 0)
|
if (mpz_sgn (step->value.integer) == 0)
|
{
|
{
|
gfc_error ("Iterator step at %L cannot be zero", &step->where);
|
gfc_error ("Iterator step at %L cannot be zero", &step->where);
|
goto cleanup;
|
goto cleanup;
|
}
|
}
|
|
|
/* Calculate the trip count of the loop. */
|
/* Calculate the trip count of the loop. */
|
mpz_sub (trip, end->value.integer, start->value.integer);
|
mpz_sub (trip, end->value.integer, start->value.integer);
|
mpz_add (trip, trip, step->value.integer);
|
mpz_add (trip, trip, step->value.integer);
|
mpz_tdiv_q (trip, trip, step->value.integer);
|
mpz_tdiv_q (trip, trip, step->value.integer);
|
|
|
mpz_set (frame.value, start->value.integer);
|
mpz_set (frame.value, start->value.integer);
|
|
|
frame.prev = iter_stack;
|
frame.prev = iter_stack;
|
frame.variable = c->iterator->var->symtree;
|
frame.variable = c->iterator->var->symtree;
|
iter_stack = &frame;
|
iter_stack = &frame;
|
|
|
while (mpz_sgn (trip) > 0)
|
while (mpz_sgn (trip) > 0)
|
{
|
{
|
if (expand_expr (c->expr) == FAILURE)
|
if (expand_expr (c->expr) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
mpz_add (frame.value, frame.value, step->value.integer);
|
mpz_add (frame.value, frame.value, step->value.integer);
|
mpz_sub_ui (trip, trip, 1);
|
mpz_sub_ui (trip, trip, 1);
|
}
|
}
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
cleanup:
|
cleanup:
|
gfc_free_expr (start);
|
gfc_free_expr (start);
|
gfc_free_expr (end);
|
gfc_free_expr (end);
|
gfc_free_expr (step);
|
gfc_free_expr (step);
|
|
|
mpz_clear (trip);
|
mpz_clear (trip);
|
mpz_clear (frame.value);
|
mpz_clear (frame.value);
|
|
|
iter_stack = frame.prev;
|
iter_stack = frame.prev;
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Expand a constructor into constant constructors without any
|
/* Expand a constructor into constant constructors without any
|
iterators, calling the work function for each of the expanded
|
iterators, calling the work function for each of the expanded
|
expressions. The work function needs to either save or free the
|
expressions. The work function needs to either save or free the
|
passed expression. */
|
passed expression. */
|
|
|
static gfc_try
|
static gfc_try
|
expand_constructor (gfc_constructor *c)
|
expand_constructor (gfc_constructor *c)
|
{
|
{
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
for (; c; c = c->next)
|
for (; c; c = c->next)
|
{
|
{
|
if (c->iterator != NULL)
|
if (c->iterator != NULL)
|
{
|
{
|
if (expand_iterator (c) == FAILURE)
|
if (expand_iterator (c) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
continue;
|
continue;
|
}
|
}
|
|
|
e = c->expr;
|
e = c->expr;
|
|
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
{
|
{
|
if (expand_constructor (e->value.constructor) == FAILURE)
|
if (expand_constructor (e->value.constructor) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
continue;
|
continue;
|
}
|
}
|
|
|
e = gfc_copy_expr (e);
|
e = gfc_copy_expr (e);
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
if (gfc_simplify_expr (e, 1) == FAILURE)
|
{
|
{
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
current_expand.offset = &c->n.offset;
|
current_expand.offset = &c->n.offset;
|
current_expand.component = c->n.component;
|
current_expand.component = c->n.component;
|
current_expand.repeat = &c->repeat;
|
current_expand.repeat = &c->repeat;
|
if (current_expand.expand_work_function (e) == FAILURE)
|
if (current_expand.expand_work_function (e) == FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Top level subroutine for expanding constructors. We only expand
|
/* Top level subroutine for expanding constructors. We only expand
|
constructor if they are small enough. */
|
constructor if they are small enough. */
|
|
|
gfc_try
|
gfc_try
|
gfc_expand_constructor (gfc_expr *e)
|
gfc_expand_constructor (gfc_expr *e)
|
{
|
{
|
expand_info expand_save;
|
expand_info expand_save;
|
gfc_expr *f;
|
gfc_expr *f;
|
gfc_try rc;
|
gfc_try rc;
|
|
|
f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
|
f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
|
if (f != NULL)
|
if (f != NULL)
|
{
|
{
|
gfc_free_expr (f);
|
gfc_free_expr (f);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
expand_save = current_expand;
|
expand_save = current_expand;
|
current_expand.new_head = current_expand.new_tail = NULL;
|
current_expand.new_head = current_expand.new_tail = NULL;
|
|
|
iter_stack = NULL;
|
iter_stack = NULL;
|
|
|
current_expand.expand_work_function = expand;
|
current_expand.expand_work_function = expand;
|
|
|
if (expand_constructor (e->value.constructor) == FAILURE)
|
if (expand_constructor (e->value.constructor) == FAILURE)
|
{
|
{
|
gfc_free_constructor (current_expand.new_head);
|
gfc_free_constructor (current_expand.new_head);
|
rc = FAILURE;
|
rc = FAILURE;
|
goto done;
|
goto done;
|
}
|
}
|
|
|
gfc_free_constructor (e->value.constructor);
|
gfc_free_constructor (e->value.constructor);
|
e->value.constructor = current_expand.new_head;
|
e->value.constructor = current_expand.new_head;
|
|
|
rc = SUCCESS;
|
rc = SUCCESS;
|
|
|
done:
|
done:
|
current_expand = expand_save;
|
current_expand = expand_save;
|
|
|
return rc;
|
return rc;
|
}
|
}
|
|
|
|
|
/* Work function for checking that an element of a constructor is a
|
/* Work function for checking that an element of a constructor is a
|
constant, after removal of any iteration variables. We return
|
constant, after removal of any iteration variables. We return
|
FAILURE if not so. */
|
FAILURE if not so. */
|
|
|
static gfc_try
|
static gfc_try
|
is_constant_element (gfc_expr *e)
|
is_constant_element (gfc_expr *e)
|
{
|
{
|
int rv;
|
int rv;
|
|
|
rv = gfc_is_constant_expr (e);
|
rv = gfc_is_constant_expr (e);
|
gfc_free_expr (e);
|
gfc_free_expr (e);
|
|
|
return rv ? SUCCESS : FAILURE;
|
return rv ? SUCCESS : FAILURE;
|
}
|
}
|
|
|
|
|
/* Given an array constructor, determine if the constructor is
|
/* Given an array constructor, determine if the constructor is
|
constant or not by expanding it and making sure that all elements
|
constant or not by expanding it and making sure that all elements
|
are constants. This is a bit of a hack since something like (/ (i,
|
are constants. This is a bit of a hack since something like (/ (i,
|
i=1,100000000) /) will take a while as* opposed to a more clever
|
i=1,100000000) /) will take a while as* opposed to a more clever
|
function that traverses the expression tree. FIXME. */
|
function that traverses the expression tree. FIXME. */
|
|
|
int
|
int
|
gfc_constant_ac (gfc_expr *e)
|
gfc_constant_ac (gfc_expr *e)
|
{
|
{
|
expand_info expand_save;
|
expand_info expand_save;
|
gfc_try rc;
|
gfc_try rc;
|
gfc_constructor * con;
|
gfc_constructor * con;
|
|
|
rc = SUCCESS;
|
rc = SUCCESS;
|
|
|
if (e->value.constructor
|
if (e->value.constructor
|
&& e->value.constructor->expr->expr_type == EXPR_ARRAY)
|
&& e->value.constructor->expr->expr_type == EXPR_ARRAY)
|
{
|
{
|
/* Expand the constructor. */
|
/* Expand the constructor. */
|
iter_stack = NULL;
|
iter_stack = NULL;
|
expand_save = current_expand;
|
expand_save = current_expand;
|
current_expand.expand_work_function = is_constant_element;
|
current_expand.expand_work_function = is_constant_element;
|
|
|
rc = expand_constructor (e->value.constructor);
|
rc = expand_constructor (e->value.constructor);
|
|
|
current_expand = expand_save;
|
current_expand = expand_save;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* No need to expand this further. */
|
/* No need to expand this further. */
|
for (con = e->value.constructor; con; con = con->next)
|
for (con = e->value.constructor; con; con = con->next)
|
{
|
{
|
if (con->expr->expr_type == EXPR_CONSTANT)
|
if (con->expr->expr_type == EXPR_CONSTANT)
|
continue;
|
continue;
|
else
|
else
|
{
|
{
|
if (!gfc_is_constant_expr (con->expr))
|
if (!gfc_is_constant_expr (con->expr))
|
rc = FAILURE;
|
rc = FAILURE;
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
if (rc == FAILURE)
|
if (rc == FAILURE)
|
return 0;
|
return 0;
|
|
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
/* Returns nonzero if an array constructor has been completely
|
/* Returns nonzero if an array constructor has been completely
|
expanded (no iterators) and zero if iterators are present. */
|
expanded (no iterators) and zero if iterators are present. */
|
|
|
int
|
int
|
gfc_expanded_ac (gfc_expr *e)
|
gfc_expanded_ac (gfc_expr *e)
|
{
|
{
|
gfc_constructor *p;
|
gfc_constructor *p;
|
|
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
for (p = e->value.constructor; p; p = p->next)
|
for (p = e->value.constructor; p; p = p->next)
|
if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
|
if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
|
return 0;
|
return 0;
|
|
|
return 1;
|
return 1;
|
}
|
}
|
|
|
|
|
/*************** Type resolution of array constructors ***************/
|
/*************** Type resolution of array constructors ***************/
|
|
|
/* Recursive array list resolution function. All of the elements must
|
/* Recursive array list resolution function. All of the elements must
|
be of the same type. */
|
be of the same type. */
|
|
|
static gfc_try
|
static gfc_try
|
resolve_array_list (gfc_constructor *p)
|
resolve_array_list (gfc_constructor *p)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
for (; p; p = p->next)
|
for (; p; p = p->next)
|
{
|
{
|
if (p->iterator != NULL
|
if (p->iterator != NULL
|
&& gfc_resolve_iterator (p->iterator, false) == FAILURE)
|
&& gfc_resolve_iterator (p->iterator, false) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
|
|
if (gfc_resolve_expr (p->expr) == FAILURE)
|
if (gfc_resolve_expr (p->expr) == FAILURE)
|
t = FAILURE;
|
t = FAILURE;
|
}
|
}
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
/* Resolve character array constructor. If it has a specified constant character
|
/* Resolve character array constructor. If it has a specified constant character
|
length, pad/truncate the elements here; if the length is not specified and
|
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
|
all elements are of compile-time known length, emit an error as this is
|
invalid. */
|
invalid. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_character_array_constructor (gfc_expr *expr)
|
gfc_resolve_character_array_constructor (gfc_expr *expr)
|
{
|
{
|
gfc_constructor *p;
|
gfc_constructor *p;
|
int found_length;
|
int found_length;
|
|
|
gcc_assert (expr->expr_type == EXPR_ARRAY);
|
gcc_assert (expr->expr_type == EXPR_ARRAY);
|
gcc_assert (expr->ts.type == BT_CHARACTER);
|
gcc_assert (expr->ts.type == BT_CHARACTER);
|
|
|
if (expr->ts.u.cl == NULL)
|
if (expr->ts.u.cl == NULL)
|
{
|
{
|
for (p = expr->value.constructor; p; p = p->next)
|
for (p = expr->value.constructor; p; p = p->next)
|
if (p->expr->ts.u.cl != NULL)
|
if (p->expr->ts.u.cl != NULL)
|
{
|
{
|
/* Ensure that if there is a char_len around that it is
|
/* Ensure that if there is a char_len around that it is
|
used; otherwise the middle-end confuses them! */
|
used; otherwise the middle-end confuses them! */
|
expr->ts.u.cl = p->expr->ts.u.cl;
|
expr->ts.u.cl = p->expr->ts.u.cl;
|
goto got_charlen;
|
goto got_charlen;
|
}
|
}
|
|
|
expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
}
|
}
|
|
|
got_charlen:
|
got_charlen:
|
|
|
found_length = -1;
|
found_length = -1;
|
|
|
if (expr->ts.u.cl->length == NULL)
|
if (expr->ts.u.cl->length == NULL)
|
{
|
{
|
/* Check that all constant string elements have the same length until
|
/* Check that all constant string elements have the same length until
|
we reach the end or find a variable-length one. */
|
we reach the end or find a variable-length one. */
|
|
|
for (p = expr->value.constructor; p; p = p->next)
|
for (p = expr->value.constructor; p; p = p->next)
|
{
|
{
|
int current_length = -1;
|
int current_length = -1;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
for (ref = p->expr->ref; ref; ref = ref->next)
|
for (ref = p->expr->ref; ref; ref = ref->next)
|
if (ref->type == REF_SUBSTRING
|
if (ref->type == REF_SUBSTRING
|
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
|
&& ref->u.ss.start->expr_type == EXPR_CONSTANT
|
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
|
&& ref->u.ss.end->expr_type == EXPR_CONSTANT)
|
break;
|
break;
|
|
|
if (p->expr->expr_type == EXPR_CONSTANT)
|
if (p->expr->expr_type == EXPR_CONSTANT)
|
current_length = p->expr->value.character.length;
|
current_length = p->expr->value.character.length;
|
else if (ref)
|
else if (ref)
|
{
|
{
|
long j;
|
long j;
|
j = mpz_get_ui (ref->u.ss.end->value.integer)
|
j = mpz_get_ui (ref->u.ss.end->value.integer)
|
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
|
- mpz_get_ui (ref->u.ss.start->value.integer) + 1;
|
current_length = (int) j;
|
current_length = (int) j;
|
}
|
}
|
else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
|
else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
|
&& p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
&& p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
{
|
{
|
long j;
|
long j;
|
j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
|
j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
|
current_length = (int) j;
|
current_length = (int) j;
|
}
|
}
|
else
|
else
|
return SUCCESS;
|
return SUCCESS;
|
|
|
gcc_assert (current_length != -1);
|
gcc_assert (current_length != -1);
|
|
|
if (found_length == -1)
|
if (found_length == -1)
|
found_length = current_length;
|
found_length = current_length;
|
else if (found_length != current_length)
|
else if (found_length != current_length)
|
{
|
{
|
gfc_error ("Different CHARACTER lengths (%d/%d) in array"
|
gfc_error ("Different CHARACTER lengths (%d/%d) in array"
|
" constructor at %L", found_length, current_length,
|
" constructor at %L", found_length, current_length,
|
&p->expr->where);
|
&p->expr->where);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
gcc_assert (found_length == current_length);
|
gcc_assert (found_length == current_length);
|
}
|
}
|
|
|
gcc_assert (found_length != -1);
|
gcc_assert (found_length != -1);
|
|
|
/* Update the character length of the array constructor. */
|
/* Update the character length of the array constructor. */
|
expr->ts.u.cl->length = gfc_int_expr (found_length);
|
expr->ts.u.cl->length = gfc_int_expr (found_length);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* We've got a character length specified. It should be an integer,
|
/* We've got a character length specified. It should be an integer,
|
otherwise an error is signalled elsewhere. */
|
otherwise an error is signalled elsewhere. */
|
gcc_assert (expr->ts.u.cl->length);
|
gcc_assert (expr->ts.u.cl->length);
|
|
|
/* If we've got a constant character length, pad according to this.
|
/* 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
|
gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
|
max_length only if they pass. */
|
max_length only if they pass. */
|
gfc_extract_int (expr->ts.u.cl->length, &found_length);
|
gfc_extract_int (expr->ts.u.cl->length, &found_length);
|
|
|
/* Now pad/truncate the elements accordingly to the specified character
|
/* Now pad/truncate the elements accordingly to the specified character
|
length. This is ok inside this conditional, as in the case above
|
length. This is ok inside this conditional, as in the case above
|
(without typespec) all elements are verified to have the same length
|
(without typespec) all elements are verified to have the same length
|
anyway. */
|
anyway. */
|
if (found_length != -1)
|
if (found_length != -1)
|
for (p = expr->value.constructor; p; p = p->next)
|
for (p = expr->value.constructor; p; p = p->next)
|
if (p->expr->expr_type == EXPR_CONSTANT)
|
if (p->expr->expr_type == EXPR_CONSTANT)
|
{
|
{
|
gfc_expr *cl = NULL;
|
gfc_expr *cl = NULL;
|
int current_length = -1;
|
int current_length = -1;
|
bool has_ts;
|
bool has_ts;
|
|
|
if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
|
if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
|
{
|
{
|
cl = p->expr->ts.u.cl->length;
|
cl = p->expr->ts.u.cl->length;
|
gfc_extract_int (cl, ¤t_length);
|
gfc_extract_int (cl, ¤t_length);
|
}
|
}
|
|
|
/* If gfc_extract_int above set current_length, we implicitly
|
/* If gfc_extract_int above set current_length, we implicitly
|
know the type is BT_INTEGER and it's EXPR_CONSTANT. */
|
know the type is BT_INTEGER and it's EXPR_CONSTANT. */
|
|
|
has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
|
has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
|
|
|
if (! cl
|
if (! cl
|
|| (current_length != -1 && current_length < found_length))
|
|| (current_length != -1 && current_length < found_length))
|
gfc_set_constant_character_len (found_length, p->expr,
|
gfc_set_constant_character_len (found_length, p->expr,
|
has_ts ? -1 : found_length);
|
has_ts ? -1 : found_length);
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Resolve all of the expressions in an array list. */
|
/* Resolve all of the expressions in an array list. */
|
|
|
gfc_try
|
gfc_try
|
gfc_resolve_array_constructor (gfc_expr *expr)
|
gfc_resolve_array_constructor (gfc_expr *expr)
|
{
|
{
|
gfc_try t;
|
gfc_try t;
|
|
|
t = resolve_array_list (expr->value.constructor);
|
t = resolve_array_list (expr->value.constructor);
|
if (t == SUCCESS)
|
if (t == SUCCESS)
|
t = gfc_check_constructor_type (expr);
|
t = gfc_check_constructor_type (expr);
|
|
|
/* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
|
/* 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
|
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. */
|
called twice, an error message there would be duplicated. */
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
/* Copy an iterator structure. */
|
/* Copy an iterator structure. */
|
|
|
static gfc_iterator *
|
static gfc_iterator *
|
copy_iterator (gfc_iterator *src)
|
copy_iterator (gfc_iterator *src)
|
{
|
{
|
gfc_iterator *dest;
|
gfc_iterator *dest;
|
|
|
if (src == NULL)
|
if (src == NULL)
|
return NULL;
|
return NULL;
|
|
|
dest = gfc_get_iterator ();
|
dest = gfc_get_iterator ();
|
|
|
dest->var = gfc_copy_expr (src->var);
|
dest->var = gfc_copy_expr (src->var);
|
dest->start = gfc_copy_expr (src->start);
|
dest->start = gfc_copy_expr (src->start);
|
dest->end = gfc_copy_expr (src->end);
|
dest->end = gfc_copy_expr (src->end);
|
dest->step = gfc_copy_expr (src->step);
|
dest->step = gfc_copy_expr (src->step);
|
|
|
return dest;
|
return dest;
|
}
|
}
|
|
|
|
|
/* Copy a constructor structure. */
|
/* Copy a constructor structure. */
|
|
|
gfc_constructor *
|
gfc_constructor *
|
gfc_copy_constructor (gfc_constructor *src)
|
gfc_copy_constructor (gfc_constructor *src)
|
{
|
{
|
gfc_constructor *dest;
|
gfc_constructor *dest;
|
gfc_constructor *tail;
|
gfc_constructor *tail;
|
|
|
if (src == NULL)
|
if (src == NULL)
|
return NULL;
|
return NULL;
|
|
|
dest = tail = NULL;
|
dest = tail = NULL;
|
while (src)
|
while (src)
|
{
|
{
|
if (dest == NULL)
|
if (dest == NULL)
|
dest = tail = gfc_get_constructor ();
|
dest = tail = gfc_get_constructor ();
|
else
|
else
|
{
|
{
|
tail->next = gfc_get_constructor ();
|
tail->next = gfc_get_constructor ();
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
tail->where = src->where;
|
tail->where = src->where;
|
tail->expr = gfc_copy_expr (src->expr);
|
tail->expr = gfc_copy_expr (src->expr);
|
tail->iterator = copy_iterator (src->iterator);
|
tail->iterator = copy_iterator (src->iterator);
|
mpz_set (tail->n.offset, src->n.offset);
|
mpz_set (tail->n.offset, src->n.offset);
|
tail->n.component = src->n.component;
|
tail->n.component = src->n.component;
|
mpz_set (tail->repeat, src->repeat);
|
mpz_set (tail->repeat, src->repeat);
|
src = src->next;
|
src = src->next;
|
}
|
}
|
|
|
return dest;
|
return dest;
|
}
|
}
|
|
|
|
|
/* Given an array expression and an element number (starting at zero),
|
/* Given an array expression and an element number (starting at zero),
|
return a pointer to the array element. NULL is returned if the
|
return a pointer to the array element. NULL is returned if the
|
size of the array has been exceeded. The expression node returned
|
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
|
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
|
efficient at all, but this is another place where things do not
|
have to be particularly fast. */
|
have to be particularly fast. */
|
|
|
gfc_expr *
|
gfc_expr *
|
gfc_get_array_element (gfc_expr *array, int element)
|
gfc_get_array_element (gfc_expr *array, int element)
|
{
|
{
|
expand_info expand_save;
|
expand_info expand_save;
|
gfc_expr *e;
|
gfc_expr *e;
|
gfc_try rc;
|
gfc_try rc;
|
|
|
expand_save = current_expand;
|
expand_save = current_expand;
|
current_expand.extract_n = element;
|
current_expand.extract_n = element;
|
current_expand.expand_work_function = extract_element;
|
current_expand.expand_work_function = extract_element;
|
current_expand.extracted = NULL;
|
current_expand.extracted = NULL;
|
current_expand.extract_count = 0;
|
current_expand.extract_count = 0;
|
|
|
iter_stack = NULL;
|
iter_stack = NULL;
|
|
|
rc = expand_constructor (array->value.constructor);
|
rc = expand_constructor (array->value.constructor);
|
e = current_expand.extracted;
|
e = current_expand.extracted;
|
current_expand = expand_save;
|
current_expand = expand_save;
|
|
|
if (rc == FAILURE)
|
if (rc == FAILURE)
|
return NULL;
|
return NULL;
|
|
|
return e;
|
return e;
|
}
|
}
|
|
|
|
|
/********* Subroutines for determining the size of an array *********/
|
/********* Subroutines for determining the size of an array *********/
|
|
|
/* These are needed just to accommodate RESHAPE(). There are no
|
/* These are needed just to accommodate RESHAPE(). There are no
|
diagnostics here, we just return a negative number if something
|
diagnostics here, we just return a negative number if something
|
goes wrong. */
|
goes wrong. */
|
|
|
|
|
/* Get the size of single dimension of an array specification. The
|
/* Get the size of single dimension of an array specification. The
|
array is guaranteed to be one dimensional. */
|
array is guaranteed to be one dimensional. */
|
|
|
gfc_try
|
gfc_try
|
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
|
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
|
{
|
{
|
if (as == NULL)
|
if (as == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
if (dimen < 0 || dimen > as->rank - 1)
|
if (dimen < 0 || dimen > as->rank - 1)
|
gfc_internal_error ("spec_dimen_size(): Bad dimension");
|
gfc_internal_error ("spec_dimen_size(): Bad dimension");
|
|
|
if (as->type != AS_EXPLICIT
|
if (as->type != AS_EXPLICIT
|
|| as->lower[dimen]->expr_type != EXPR_CONSTANT
|
|| 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->lower[dimen]->ts.type != BT_INTEGER
|
|| as->upper[dimen]->ts.type != BT_INTEGER)
|
|| as->upper[dimen]->ts.type != BT_INTEGER)
|
return FAILURE;
|
return FAILURE;
|
|
|
mpz_init (*result);
|
mpz_init (*result);
|
|
|
mpz_sub (*result, as->upper[dimen]->value.integer,
|
mpz_sub (*result, as->upper[dimen]->value.integer,
|
as->lower[dimen]->value.integer);
|
as->lower[dimen]->value.integer);
|
|
|
mpz_add_ui (*result, *result, 1);
|
mpz_add_ui (*result, *result, 1);
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
gfc_try
|
gfc_try
|
spec_size (gfc_array_spec *as, mpz_t *result)
|
spec_size (gfc_array_spec *as, mpz_t *result)
|
{
|
{
|
mpz_t size;
|
mpz_t size;
|
int d;
|
int d;
|
|
|
mpz_init_set_ui (*result, 1);
|
mpz_init_set_ui (*result, 1);
|
|
|
for (d = 0; d < as->rank; d++)
|
for (d = 0; d < as->rank; d++)
|
{
|
{
|
if (spec_dimen_size (as, d, &size) == FAILURE)
|
if (spec_dimen_size (as, d, &size) == FAILURE)
|
{
|
{
|
mpz_clear (*result);
|
mpz_clear (*result);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
mpz_mul (*result, *result, size);
|
mpz_mul (*result, *result, size);
|
mpz_clear (size);
|
mpz_clear (size);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Get the number of elements in an array section. */
|
/* Get the number of elements in an array section. */
|
|
|
gfc_try
|
gfc_try
|
gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
|
gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
|
{
|
{
|
mpz_t upper, lower, stride;
|
mpz_t upper, lower, stride;
|
gfc_try t;
|
gfc_try t;
|
|
|
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
|
if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
|
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
|
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
|
|
|
switch (ar->dimen_type[dimen])
|
switch (ar->dimen_type[dimen])
|
{
|
{
|
case DIMEN_ELEMENT:
|
case DIMEN_ELEMENT:
|
mpz_init (*result);
|
mpz_init (*result);
|
mpz_set_ui (*result, 1);
|
mpz_set_ui (*result, 1);
|
t = SUCCESS;
|
t = SUCCESS;
|
break;
|
break;
|
|
|
case DIMEN_VECTOR:
|
case DIMEN_VECTOR:
|
t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
|
t = gfc_array_size (ar->start[dimen], result); /* Recurse! */
|
break;
|
break;
|
|
|
case DIMEN_RANGE:
|
case DIMEN_RANGE:
|
mpz_init (upper);
|
mpz_init (upper);
|
mpz_init (lower);
|
mpz_init (lower);
|
mpz_init (stride);
|
mpz_init (stride);
|
t = FAILURE;
|
t = FAILURE;
|
|
|
if (ar->start[dimen] == NULL)
|
if (ar->start[dimen] == NULL)
|
{
|
{
|
if (ar->as->lower[dimen] == NULL
|
if (ar->as->lower[dimen] == NULL
|
|| ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
|
|| ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
|
goto cleanup;
|
goto cleanup;
|
mpz_set (lower, ar->as->lower[dimen]->value.integer);
|
mpz_set (lower, ar->as->lower[dimen]->value.integer);
|
}
|
}
|
else
|
else
|
{
|
{
|
if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
|
if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
|
goto cleanup;
|
goto cleanup;
|
mpz_set (lower, ar->start[dimen]->value.integer);
|
mpz_set (lower, ar->start[dimen]->value.integer);
|
}
|
}
|
|
|
if (ar->end[dimen] == NULL)
|
if (ar->end[dimen] == NULL)
|
{
|
{
|
if (ar->as->upper[dimen] == NULL
|
if (ar->as->upper[dimen] == NULL
|
|| ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
|
|| ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
|
goto cleanup;
|
goto cleanup;
|
mpz_set (upper, ar->as->upper[dimen]->value.integer);
|
mpz_set (upper, ar->as->upper[dimen]->value.integer);
|
}
|
}
|
else
|
else
|
{
|
{
|
if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
|
if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
|
goto cleanup;
|
goto cleanup;
|
mpz_set (upper, ar->end[dimen]->value.integer);
|
mpz_set (upper, ar->end[dimen]->value.integer);
|
}
|
}
|
|
|
if (ar->stride[dimen] == NULL)
|
if (ar->stride[dimen] == NULL)
|
mpz_set_ui (stride, 1);
|
mpz_set_ui (stride, 1);
|
else
|
else
|
{
|
{
|
if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
|
if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
|
goto cleanup;
|
goto cleanup;
|
mpz_set (stride, ar->stride[dimen]->value.integer);
|
mpz_set (stride, ar->stride[dimen]->value.integer);
|
}
|
}
|
|
|
mpz_init (*result);
|
mpz_init (*result);
|
mpz_sub (*result, upper, lower);
|
mpz_sub (*result, upper, lower);
|
mpz_add (*result, *result, stride);
|
mpz_add (*result, *result, stride);
|
mpz_div (*result, *result, stride);
|
mpz_div (*result, *result, stride);
|
|
|
/* Zero stride caught earlier. */
|
/* Zero stride caught earlier. */
|
if (mpz_cmp_ui (*result, 0) < 0)
|
if (mpz_cmp_ui (*result, 0) < 0)
|
mpz_set_ui (*result, 0);
|
mpz_set_ui (*result, 0);
|
t = SUCCESS;
|
t = SUCCESS;
|
|
|
cleanup:
|
cleanup:
|
mpz_clear (upper);
|
mpz_clear (upper);
|
mpz_clear (lower);
|
mpz_clear (lower);
|
mpz_clear (stride);
|
mpz_clear (stride);
|
return t;
|
return t;
|
|
|
default:
|
default:
|
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
|
gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
|
}
|
}
|
|
|
return t;
|
return t;
|
}
|
}
|
|
|
|
|
static gfc_try
|
static gfc_try
|
ref_size (gfc_array_ref *ar, mpz_t *result)
|
ref_size (gfc_array_ref *ar, mpz_t *result)
|
{
|
{
|
mpz_t size;
|
mpz_t size;
|
int d;
|
int d;
|
|
|
mpz_init_set_ui (*result, 1);
|
mpz_init_set_ui (*result, 1);
|
|
|
for (d = 0; d < ar->dimen; d++)
|
for (d = 0; d < ar->dimen; d++)
|
{
|
{
|
if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
|
if (gfc_ref_dimen_size (ar, d, &size) == FAILURE)
|
{
|
{
|
mpz_clear (*result);
|
mpz_clear (*result);
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
mpz_mul (*result, *result, size);
|
mpz_mul (*result, *result, size);
|
mpz_clear (size);
|
mpz_clear (size);
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an array expression and a dimension, figure out how many
|
/* Given an array expression and a dimension, figure out how many
|
elements it has along that dimension. Returns SUCCESS if we were
|
elements it has along that dimension. Returns SUCCESS if we were
|
able to return a result in the 'result' variable, FAILURE
|
able to return a result in the 'result' variable, FAILURE
|
otherwise. */
|
otherwise. */
|
|
|
gfc_try
|
gfc_try
|
gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
|
gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
int i;
|
int i;
|
|
|
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
|
if (dimen < 0 || array == NULL || dimen > array->rank - 1)
|
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
|
gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
|
|
|
switch (array->expr_type)
|
switch (array->expr_type)
|
{
|
{
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
case EXPR_FUNCTION:
|
case EXPR_FUNCTION:
|
for (ref = array->ref; ref; ref = ref->next)
|
for (ref = array->ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type != REF_ARRAY)
|
if (ref->type != REF_ARRAY)
|
continue;
|
continue;
|
|
|
if (ref->u.ar.type == AR_FULL)
|
if (ref->u.ar.type == AR_FULL)
|
return spec_dimen_size (ref->u.ar.as, dimen, result);
|
return spec_dimen_size (ref->u.ar.as, dimen, result);
|
|
|
if (ref->u.ar.type == AR_SECTION)
|
if (ref->u.ar.type == AR_SECTION)
|
{
|
{
|
for (i = 0; dimen >= 0; i++)
|
for (i = 0; dimen >= 0; i++)
|
if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
|
if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
|
dimen--;
|
dimen--;
|
|
|
return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
|
return gfc_ref_dimen_size (&ref->u.ar, i - 1, result);
|
}
|
}
|
}
|
}
|
|
|
if (array->shape && array->shape[dimen])
|
if (array->shape && array->shape[dimen])
|
{
|
{
|
mpz_init_set (*result, array->shape[dimen]);
|
mpz_init_set (*result, array->shape[dimen]);
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
if (array->symtree->n.sym->attr.generic
|
if (array->symtree->n.sym->attr.generic
|
&& array->value.function.esym != NULL)
|
&& array->value.function.esym != NULL)
|
{
|
{
|
if (spec_dimen_size (array->value.function.esym->as, dimen, result)
|
if (spec_dimen_size (array->value.function.esym->as, dimen, result)
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
|
else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
|
== FAILURE)
|
== FAILURE)
|
return FAILURE;
|
return FAILURE;
|
|
|
break;
|
break;
|
|
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
if (array->shape == NULL) {
|
if (array->shape == NULL) {
|
/* Expressions with rank > 1 should have "shape" properly set */
|
/* Expressions with rank > 1 should have "shape" properly set */
|
if ( array->rank != 1 )
|
if ( array->rank != 1 )
|
gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
|
gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
|
return gfc_array_size(array, result);
|
return gfc_array_size(array, result);
|
}
|
}
|
|
|
/* Fall through */
|
/* Fall through */
|
default:
|
default:
|
if (array->shape == NULL)
|
if (array->shape == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
mpz_init_set (*result, array->shape[dimen]);
|
mpz_init_set (*result, array->shape[dimen]);
|
|
|
break;
|
break;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an array expression, figure out how many elements are in the
|
/* Given an array expression, figure out how many elements are in the
|
array. Returns SUCCESS if this is possible, and sets the 'result'
|
array. Returns SUCCESS if this is possible, and sets the 'result'
|
variable. Otherwise returns FAILURE. */
|
variable. Otherwise returns FAILURE. */
|
|
|
gfc_try
|
gfc_try
|
gfc_array_size (gfc_expr *array, mpz_t *result)
|
gfc_array_size (gfc_expr *array, mpz_t *result)
|
{
|
{
|
expand_info expand_save;
|
expand_info expand_save;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
int i;
|
int i;
|
gfc_try t;
|
gfc_try t;
|
|
|
switch (array->expr_type)
|
switch (array->expr_type)
|
{
|
{
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
gfc_push_suppress_errors ();
|
gfc_push_suppress_errors ();
|
|
|
expand_save = current_expand;
|
expand_save = current_expand;
|
|
|
current_expand.count = result;
|
current_expand.count = result;
|
mpz_init_set_ui (*result, 0);
|
mpz_init_set_ui (*result, 0);
|
|
|
current_expand.expand_work_function = count_elements;
|
current_expand.expand_work_function = count_elements;
|
iter_stack = NULL;
|
iter_stack = NULL;
|
|
|
t = expand_constructor (array->value.constructor);
|
t = expand_constructor (array->value.constructor);
|
|
|
gfc_pop_suppress_errors ();
|
gfc_pop_suppress_errors ();
|
|
|
if (t == FAILURE)
|
if (t == FAILURE)
|
mpz_clear (*result);
|
mpz_clear (*result);
|
current_expand = expand_save;
|
current_expand = expand_save;
|
return t;
|
return t;
|
|
|
case EXPR_VARIABLE:
|
case EXPR_VARIABLE:
|
for (ref = array->ref; ref; ref = ref->next)
|
for (ref = array->ref; ref; ref = ref->next)
|
{
|
{
|
if (ref->type != REF_ARRAY)
|
if (ref->type != REF_ARRAY)
|
continue;
|
continue;
|
|
|
if (ref->u.ar.type == AR_FULL)
|
if (ref->u.ar.type == AR_FULL)
|
return spec_size (ref->u.ar.as, result);
|
return spec_size (ref->u.ar.as, result);
|
|
|
if (ref->u.ar.type == AR_SECTION)
|
if (ref->u.ar.type == AR_SECTION)
|
return ref_size (&ref->u.ar, result);
|
return ref_size (&ref->u.ar, result);
|
}
|
}
|
|
|
return spec_size (array->symtree->n.sym->as, result);
|
return spec_size (array->symtree->n.sym->as, result);
|
|
|
|
|
default:
|
default:
|
if (array->rank == 0 || array->shape == NULL)
|
if (array->rank == 0 || array->shape == NULL)
|
return FAILURE;
|
return FAILURE;
|
|
|
mpz_init_set_ui (*result, 1);
|
mpz_init_set_ui (*result, 1);
|
|
|
for (i = 0; i < array->rank; i++)
|
for (i = 0; i < array->rank; i++)
|
mpz_mul (*result, *result, array->shape[i]);
|
mpz_mul (*result, *result, array->shape[i]);
|
|
|
break;
|
break;
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
}
|
}
|
|
|
|
|
/* Given an array reference, return the shape of the reference in an
|
/* Given an array reference, return the shape of the reference in an
|
array of mpz_t integers. */
|
array of mpz_t integers. */
|
|
|
gfc_try
|
gfc_try
|
gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
|
gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
|
{
|
{
|
int d;
|
int d;
|
int i;
|
int i;
|
|
|
d = 0;
|
d = 0;
|
|
|
switch (ar->type)
|
switch (ar->type)
|
{
|
{
|
case AR_FULL:
|
case AR_FULL:
|
for (; d < ar->as->rank; d++)
|
for (; d < ar->as->rank; d++)
|
if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
|
if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
|
|
return SUCCESS;
|
return SUCCESS;
|
|
|
case AR_SECTION:
|
case AR_SECTION:
|
for (i = 0; i < ar->dimen; i++)
|
for (i = 0; i < ar->dimen; i++)
|
{
|
{
|
if (ar->dimen_type[i] != DIMEN_ELEMENT)
|
if (ar->dimen_type[i] != DIMEN_ELEMENT)
|
{
|
{
|
if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
|
if (gfc_ref_dimen_size (ar, i, &shape[d]) == FAILURE)
|
goto cleanup;
|
goto cleanup;
|
d++;
|
d++;
|
}
|
}
|
}
|
}
|
|
|
return SUCCESS;
|
return SUCCESS;
|
|
|
default:
|
default:
|
break;
|
break;
|
}
|
}
|
|
|
cleanup:
|
cleanup:
|
for (d--; d >= 0; d--)
|
for (d--; d >= 0; d--)
|
mpz_clear (shape[d]);
|
mpz_clear (shape[d]);
|
|
|
return FAILURE;
|
return FAILURE;
|
}
|
}
|
|
|
|
|
/* Given an array expression, find the array reference structure that
|
/* Given an array expression, find the array reference structure that
|
characterizes the reference. */
|
characterizes the reference. */
|
|
|
gfc_array_ref *
|
gfc_array_ref *
|
gfc_find_array_ref (gfc_expr *e)
|
gfc_find_array_ref (gfc_expr *e)
|
{
|
{
|
gfc_ref *ref;
|
gfc_ref *ref;
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
for (ref = e->ref; ref; ref = ref->next)
|
if (ref->type == REF_ARRAY
|
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;
|
break;
|
|
|
if (ref == NULL)
|
if (ref == NULL)
|
gfc_internal_error ("gfc_find_array_ref(): No ref found");
|
gfc_internal_error ("gfc_find_array_ref(): No ref found");
|
|
|
return &ref->u.ar;
|
return &ref->u.ar;
|
}
|
}
|
|
|
|
|
/* Find out if an array shape is known at compile time. */
|
/* Find out if an array shape is known at compile time. */
|
|
|
int
|
int
|
gfc_is_compile_time_shape (gfc_array_spec *as)
|
gfc_is_compile_time_shape (gfc_array_spec *as)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (as->type != AS_EXPLICIT)
|
if (as->type != AS_EXPLICIT)
|
return 0;
|
return 0;
|
|
|
for (i = 0; i < as->rank; i++)
|
for (i = 0; i < as->rank; i++)
|
if (!gfc_is_constant_expr (as->lower[i])
|
if (!gfc_is_constant_expr (as->lower[i])
|
|| !gfc_is_constant_expr (as->upper[i]))
|
|| !gfc_is_constant_expr (as->upper[i]))
|
return 0;
|
return 0;
|
|
|
return 1;
|
return 1;
|
}
|
}
|
|
|
