/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
gfc_expr *e;
e = gfc_getmem (sizeof (gfc_expr));
-
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
-
+ e->con_by_offset = NULL;
return e;
}
/* Free an argument list and everything below it. */
void
-gfc_free_actual_arglist (gfc_actual_arglist * a1)
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
{
gfc_actual_arglist *a2;
/* Copy an arglist structure and all of the arguments. */
gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist * p)
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
{
gfc_actual_arglist *head, *tail, *new;
/* Free a list of reference structures. */
void
-gfc_free_ref_list (gfc_ref * p)
+gfc_free_ref_list (gfc_ref *p)
{
gfc_ref *q;
int i;
something else or the expression node belongs to another structure. */
static void
-free_expr0 (gfc_expr * e)
+free_expr0 (gfc_expr *e)
{
int n;
switch (e->expr_type)
{
case EXPR_CONSTANT:
+ if (e->from_H)
+ {
+ gfc_free (e->value.character.string);
+ break;
+ }
+
switch (e->ts.type)
{
case BT_INTEGER:
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
gfc_free (e->value.character.string);
break;
/* Free an expression node and everything beneath it. */
void
-gfc_free_expr (gfc_expr * e)
+gfc_free_expr (gfc_expr *e)
{
-
if (e == NULL)
return;
-
+ if (e->con_by_offset)
+ splay_tree_delete (e->con_by_offset);
free_expr0 (e);
gfc_free (e);
}
/* Graft the *src expression onto the *dest subexpression. */
void
-gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
+gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
{
-
free_expr0 (dest);
*dest = *src;
-
gfc_free (src);
}
failure is OK for some callers. */
const char *
-gfc_extract_int (gfc_expr * expr, int *result)
+gfc_extract_int (gfc_expr *expr, int *result)
{
-
if (expr->expr_type != EXPR_CONSTANT)
- return "Constant expression required at %C";
+ return _("Constant expression required at %C");
if (expr->ts.type != BT_INTEGER)
- return "Integer expression required at %C";
+ return _("Integer expression required at %C");
if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
|| (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
{
- return "Integer value too large in expression at %C";
+ return _("Integer value too large in expression at %C");
}
*result = (int) mpz_get_si (expr->value.integer);
/* Recursively copy a list of reference structures. */
static gfc_ref *
-copy_ref (gfc_ref * src)
+copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
}
+/* Detect whether an expression has any vector index array references. */
+
+int
+gfc_has_vector_index (gfc_expr *e)
+{
+ gfc_ref *ref;
+ int i;
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY)
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ return 1;
+ return 0;
+}
+
+
/* Copy a shape array. */
mpz_t *
-gfc_copy_shape (mpz_t * shape, int rank)
+gfc_copy_shape (mpz_t *shape, int rank)
{
mpz_t *new_shape;
int n;
*/
mpz_t *
-gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
+gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
{
mpz_t *new_shape, *s;
int i, n;
if (n < 0 || n >= rank)
return NULL;
- s = new_shape = gfc_get_shape (rank-1);
+ s = new_shape = gfc_get_shape (rank - 1);
for (i = 0; i < rank; i++)
{
if (i == n)
- continue;
+ continue;
mpz_init_set (*s, shape[i]);
s++;
}
return new_shape;
}
+
/* Given an expression pointer, return a copy of the expression. This
subroutine is recursive. */
gfc_expr *
-gfc_copy_expr (gfc_expr * p)
+gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
char *s;
break;
case EXPR_CONSTANT:
+ if (p->from_H)
+ {
+ s = gfc_getmem (p->value.character.length + 1);
+ q->value.character.string = s;
+
+ memcpy (s, p->value.character.string, p->value.character.length + 1);
+ break;
+ }
switch (q->ts.type)
{
case BT_INTEGER:
break;
case BT_REAL:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.real);
+ gfc_set_model_kind (q->ts.kind);
+ mpfr_init (q->value.real);
mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.complex.r);
- mpfr_init (q->value.complex.i);
+ gfc_set_model_kind (q->ts.kind);
+ mpfr_init (q->value.complex.r);
+ mpfr_init (q->value.complex.i);
mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
- memcpy (s, p->value.character.string,
- p->value.character.length + 1);
+ memcpy (s, p->value.character.string, p->value.character.length + 1);
break;
case BT_LOGICAL:
kind numbers mean more precision for numeric types. */
int
-gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
+gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
{
-
return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}
static int
numeric_type (bt type)
{
-
return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
}
/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
int
-gfc_numeric_ts (gfc_typespec * ts)
+gfc_numeric_ts (gfc_typespec *ts)
{
-
return numeric_type (ts->type);
}
/* Returns an expression node that is a logical constant. */
gfc_expr *
-gfc_logical_expr (int i, locus * where)
+gfc_logical_expr (int i, locus *where)
{
gfc_expr *p;
argument list with a NULL pointer terminating the list. */
gfc_expr *
-gfc_build_conversion (gfc_expr * e)
+gfc_build_conversion (gfc_expr *e)
{
gfc_expr *p;
1.0**2 stays as it is. */
void
-gfc_type_convert_binary (gfc_expr * e)
+gfc_type_convert_binary (gfc_expr *e)
{
gfc_expr *op1, *op2;
/* Kind conversions of same type. */
if (op1->ts.type == op2->ts.type)
{
-
if (op1->ts.kind == op2->ts.kind)
{
- /* No type conversions. */
+ /* No type conversions. */
e->ts = op1->ts;
goto done;
}
function expects that the expression has already been simplified. */
int
-gfc_is_constant_expr (gfc_expr * e)
+gfc_is_constant_expr (gfc_expr *e)
{
gfc_constructor *c;
gfc_actual_arglist *arg;
/* Try to collapse intrinsic expressions. */
static try
-simplify_intrinsic_op (gfc_expr * p, int type)
+simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_expr *op1, *op2, *result;
switch (p->value.op.operator)
{
case INTRINSIC_UPLUS:
+ case INTRINSIC_PARENTHESES:
result = gfc_uplus (op1);
break;
return FAILURE;
}
+ result->rank = p->rank;
+ result->where = p->where;
gfc_replace_expr (p, result);
return SUCCESS;
with gfc_simplify_expr(). */
static try
-simplify_constructor (gfc_constructor * c, int type)
+simplify_constructor (gfc_constructor *c, int type)
{
-
for (; c; c = c->next)
{
if (c->iterator
/* Pull a single array element out of an array constructor. */
-static gfc_constructor *
-find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
+static try
+find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
+ gfc_constructor **rval)
{
unsigned long nelemen;
int i;
mpz_t delta;
mpz_t offset;
+ gfc_expr *e;
+ try t;
+
+ t = SUCCESS;
+ e = NULL;
mpz_init_set_ui (offset, 0);
mpz_init (delta);
for (i = 0; i < ar->dimen; i++)
{
- if (ar->start[i]->expr_type != EXPR_CONSTANT)
+ e = gfc_copy_expr (ar->start[i]);
+ if (e->expr_type != EXPR_CONSTANT)
{
cons = NULL;
- break;
+ goto depart;
+ }
+
+ /* Check the bounds. */
+ if (ar->as->upper[i]
+ && (mpz_cmp (e->value.integer, ar->as->upper[i]->value.integer) > 0
+ || mpz_cmp (e->value.integer,
+ ar->as->lower[i]->value.integer) < 0))
+ {
+ gfc_error ("index in dimension %d is out of bounds "
+ "at %L", i + 1, &ar->c_where[i]);
+ cons = NULL;
+ t = FAILURE;
+ goto depart;
}
- mpz_sub (delta, ar->start[i]->value.integer,
- ar->as->lower[i]->value.integer);
+
+ mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
mpz_add (offset, offset, delta);
}
if (cons)
{
- if (mpz_fits_ulong_p (offset))
+ for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
{
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ if (cons->iterator)
{
- if (cons->iterator)
- {
- cons = NULL;
- break;
- }
- cons = cons->next;
+ cons = NULL;
+ goto depart;
}
+ cons = cons->next;
}
- else
- cons = NULL;
}
+depart:
mpz_clear (delta);
mpz_clear (offset);
-
- return cons;
+ if (e)
+ gfc_free_expr (e);
+ *rval = cons;
+ return t;
}
/* Find a component of a structure constructor. */
static gfc_constructor *
-find_component_ref (gfc_constructor * cons, gfc_ref * ref)
+find_component_ref (gfc_constructor *cons, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
the subobject reference in the process. */
static void
-remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
+remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
{
gfc_expr *e;
}
+/* Pull an array section out of an array constructor. */
+
+static try
+find_array_section (gfc_expr *expr, gfc_ref *ref)
+{
+ int idx;
+ int rank;
+ int d;
+ int shape_i;
+ long unsigned one = 1;
+ bool incr_ctr;
+ mpz_t start[GFC_MAX_DIMENSIONS];
+ mpz_t end[GFC_MAX_DIMENSIONS];
+ mpz_t stride[GFC_MAX_DIMENSIONS];
+ mpz_t delta[GFC_MAX_DIMENSIONS];
+ mpz_t ctr[GFC_MAX_DIMENSIONS];
+ mpz_t delta_mpz;
+ mpz_t tmp_mpz;
+ mpz_t nelts;
+ mpz_t ptr;
+ mpz_t index;
+ gfc_constructor *cons;
+ gfc_constructor *base;
+ gfc_expr *begin;
+ gfc_expr *finish;
+ gfc_expr *step;
+ gfc_expr *upper;
+ gfc_expr *lower;
+ gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
+ try t;
+
+ t = SUCCESS;
+
+ base = expr->value.constructor;
+ expr->value.constructor = NULL;
+
+ rank = ref->u.ar.as->rank;
+
+ if (expr->shape == NULL)
+ expr->shape = gfc_get_shape (rank);
+
+ mpz_init_set_ui (delta_mpz, one);
+ mpz_init_set_ui (nelts, one);
+ mpz_init (tmp_mpz);
+
+ /* Do the initialization now, so that we can cleanup without
+ keeping track of where we were. */
+ for (d = 0; d < rank; d++)
+ {
+ mpz_init (delta[d]);
+ mpz_init (start[d]);
+ mpz_init (end[d]);
+ mpz_init (ctr[d]);
+ mpz_init (stride[d]);
+ vecsub[d] = NULL;
+ }
+
+ /* Build the counters to clock through the array reference. */
+ shape_i = 0;
+ for (d = 0; d < rank; d++)
+ {
+ /* Make this stretch of code easier on the eye! */
+ begin = ref->u.ar.start[d];
+ finish = ref->u.ar.end[d];
+ step = ref->u.ar.stride[d];
+ lower = ref->u.ar.as->lower[d];
+ upper = ref->u.ar.as->upper[d];
+
+ if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
+ {
+ gcc_assert (begin);
+ gcc_assert (begin->expr_type == EXPR_ARRAY);
+ gcc_assert (begin->rank == 1);
+ gcc_assert (begin->shape);
+
+ vecsub[d] = begin->value.constructor;
+ mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+ mpz_mul (nelts, nelts, begin->shape[0]);
+ mpz_set (expr->shape[shape_i++], begin->shape[0]);
+
+ /* Check bounds. */
+ for (c = vecsub[d]; c; c = c->next)
+ {
+ if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
+ || mpz_cmp (c->expr->value.integer,
+ lower->value.integer) < 0)
+ {
+ gfc_error ("index in dimension %d is out of bounds "
+ "at %L", d + 1, &ref->u.ar.c_where[d]);
+ t = FAILURE;
+ goto cleanup;
+ }
+ }
+ }
+ else
+ {
+ if ((begin && begin->expr_type != EXPR_CONSTANT)
+ || (finish && finish->expr_type != EXPR_CONSTANT)
+ || (step && step->expr_type != EXPR_CONSTANT))
+ {
+ t = FAILURE;
+ goto cleanup;
+ }
+
+ /* Obtain the stride. */
+ if (step)
+ mpz_set (stride[d], step->value.integer);
+ else
+ mpz_set_ui (stride[d], one);
+
+ if (mpz_cmp_ui (stride[d], 0) == 0)
+ mpz_set_ui (stride[d], one);
+
+ /* Obtain the start value for the index. */
+ if (begin)
+ mpz_set (start[d], begin->value.integer);
+ else
+ mpz_set (start[d], lower->value.integer);
+
+ mpz_set (ctr[d], start[d]);
+
+ /* Obtain the end value for the index. */
+ if (finish)
+ mpz_set (end[d], finish->value.integer);
+ else
+ mpz_set (end[d], upper->value.integer);
+
+ /* Separate 'if' because elements sometimes arrive with
+ non-null end. */
+ if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
+ mpz_set (end [d], begin->value.integer);
+
+ /* Check the bounds. */
+ if (mpz_cmp (ctr[d], upper->value.integer) > 0
+ || mpz_cmp (end[d], upper->value.integer) > 0
+ || mpz_cmp (ctr[d], lower->value.integer) < 0
+ || mpz_cmp (end[d], lower->value.integer) < 0)
+ {
+ gfc_error ("index in dimension %d is out of bounds "
+ "at %L", d + 1, &ref->u.ar.c_where[d]);
+ t = FAILURE;
+ goto cleanup;
+ }
+
+ /* Calculate the number of elements and the shape. */
+ mpz_abs (tmp_mpz, stride[d]);
+ mpz_div (tmp_mpz, stride[d], tmp_mpz);
+ mpz_add (tmp_mpz, end[d], tmp_mpz);
+ mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
+ mpz_div (tmp_mpz, tmp_mpz, stride[d]);
+ mpz_mul (nelts, nelts, tmp_mpz);
+
+ /* An element reference reduces the rank of the expression; don't
+ add anything to the shape array. */
+ if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
+ mpz_set (expr->shape[shape_i++], tmp_mpz);
+ }
+
+ /* Calculate the 'stride' (=delta) for conversion of the
+ counter values into the index along the constructor. */
+ mpz_set (delta[d], delta_mpz);
+ mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
+ mpz_add_ui (tmp_mpz, tmp_mpz, one);
+ mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
+ }
+
+ mpz_init (index);
+ mpz_init (ptr);
+ cons = base;
+
+ /* Now clock through the array reference, calculating the index in
+ the source constructor and transferring the elements to the new
+ constructor. */
+ for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
+ {
+ if (ref->u.ar.offset)
+ mpz_set (ptr, ref->u.ar.offset->value.integer);
+ else
+ mpz_init_set_ui (ptr, 0);
+
+ incr_ctr = true;
+ for (d = 0; d < rank; d++)
+ {
+ mpz_set (tmp_mpz, ctr[d]);
+ mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
+ mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
+ mpz_add (ptr, ptr, tmp_mpz);
+
+ if (!incr_ctr) continue;
+
+ if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
+ {
+ gcc_assert(vecsub[d]);
+
+ if (!vecsub[d]->next)
+ vecsub[d] = ref->u.ar.start[d]->value.constructor;
+ else
+ {
+ vecsub[d] = vecsub[d]->next;
+ incr_ctr = false;
+ }
+ mpz_set (ctr[d], vecsub[d]->expr->value.integer);
+ }
+ else
+ {
+ mpz_add (ctr[d], ctr[d], stride[d]);
+
+ if (mpz_cmp_ui (stride[d], 0) > 0
+ ? mpz_cmp (ctr[d], end[d]) > 0
+ : mpz_cmp (ctr[d], end[d]) < 0)
+ mpz_set (ctr[d], start[d]);
+ else
+ incr_ctr = false;
+ }
+ }
+
+ /* There must be a better way of dealing with negative strides
+ than resetting the index and the constructor pointer! */
+ if (mpz_cmp (ptr, index) < 0)
+ {
+ mpz_set_ui (index, 0);
+ cons = base;
+ }
+
+ while (mpz_cmp (ptr, index) > 0)
+ {
+ mpz_add_ui (index, index, one);
+ cons = cons->next;
+ }
+
+ gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+ }
+
+ mpz_clear (ptr);
+ mpz_clear (index);
+
+cleanup:
+
+ mpz_clear (delta_mpz);
+ mpz_clear (tmp_mpz);
+ mpz_clear (nelts);
+ for (d = 0; d < rank; d++)
+ {
+ mpz_clear (delta[d]);
+ mpz_clear (start[d]);
+ mpz_clear (end[d]);
+ mpz_clear (ctr[d]);
+ mpz_clear (stride[d]);
+ }
+ gfc_free_constructor (base);
+ return t;
+}
+
+/* Pull a substring out of an expression. */
+
+static try
+find_substring_ref (gfc_expr *p, gfc_expr **newp)
+{
+ int end;
+ int start;
+ char *chr;
+
+ if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
+ || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
+ return FAILURE;
+
+ *newp = gfc_copy_expr (p);
+ chr = p->value.character.string;
+ end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
+ start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
+
+ (*newp)->value.character.length = end - start + 1;
+ strncpy ((*newp)->value.character.string, &chr[start - 1],
+ (*newp)->value.character.length);
+ return SUCCESS;
+}
+
+
+
/* Simplify a subobject reference of a constructor. This occurs when
parameter variable values are substituted. */
static try
-simplify_const_ref (gfc_expr * p)
+simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons;
+ gfc_expr *newp;
while (p->ref)
{
switch (p->ref->u.ar.type)
{
case AR_ELEMENT:
- cons = find_array_element (p->value.constructor, &p->ref->u.ar);
+ if (find_array_element (p->value.constructor, &p->ref->u.ar,
+ &cons) == FAILURE)
+ return FAILURE;
+
if (!cons)
return SUCCESS;
+
remove_subobject_ref (p, cons);
break;
+ case AR_SECTION:
+ if (find_array_section (p, p->ref) == FAILURE)
+ return FAILURE;
+ p->ref->u.ar.type = AR_FULL;
+
+ /* FALLTHROUGH */
+
case AR_FULL:
- if (p->ref->next != NULL)
+ if (p->ref->next != NULL
+ && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
- /* TODO: Simplify array subobject references. */
- return SUCCESS;
+ cons = p->value.constructor;
+ for (; cons; cons = cons->next)
+ {
+ cons->expr->ref = copy_ref (p->ref->next);
+ simplify_const_ref (cons->expr);
+ }
}
- gfc_free_ref_list (p->ref);
- p->ref = NULL;
+ gfc_free_ref_list (p->ref);
+ p->ref = NULL;
break;
default:
- /* TODO: Simplify array subsections. */
return SUCCESS;
}
break;
case REF_SUBSTRING:
- /* TODO: Constant substrings. */
- return SUCCESS;
+ if (find_substring_ref (p, &newp) == FAILURE)
+ return FAILURE;
+
+ gfc_replace_expr (p, newp);
+ gfc_free_ref_list (p->ref);
+ p->ref = NULL;
+ break;
}
}
/* Simplify a chain of references. */
static try
-simplify_ref_chain (gfc_ref * ref, int type)
+simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
case REF_ARRAY:
for (n = 0; n < ref->u.ar.dimen; n++)
{
- if (gfc_simplify_expr (ref->u.ar.start[n], type)
- == FAILURE)
+ if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
return FAILURE;
- if (gfc_simplify_expr (ref->u.ar.end[n], type)
- == FAILURE)
+ if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
return FAILURE;
- if (gfc_simplify_expr (ref->u.ar.stride[n], type)
- == FAILURE)
+ if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
return FAILURE;
}
break;
/* Try to substitute the value of a parameter variable. */
static try
-simplify_parameter_variable (gfc_expr * p, int type)
+simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
try t;
e = gfc_copy_expr (p->symtree->n.sym->value);
- if (p->ref)
+ if (e == NULL)
+ return FAILURE;
+
+ e->rank = p->rank;
+
+ /* Do not copy subobject refs for constant. */
+ if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
e->ref = copy_ref (p->ref);
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject
references. */
- if (t == SUCCESS && ! e->ref)
+ if (t == SUCCESS && !e->ref)
gfc_replace_expr (p, e);
else
gfc_free_expr (e);
The expression type is defined for:
0 Basic expression parsing
1 Simplifying array constructors -- will substitute
- iterator values.
+ iterator values.
Returns FAILURE on error, SUCCESS otherwise.
NOTE: Will return SUCCESS even if the expression can not be simplified. */
try
-gfc_simplify_expr (gfc_expr * p, int type)
+gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
if (simplify_ref_chain (p->ref, type) == FAILURE)
return FAILURE;
- /* TODO: evaluate constant substrings. */
+ if (gfc_is_constant_expr (p))
+ {
+ char *s;
+ int start, end;
+
+ gfc_extract_int (p->ref->u.ss.start, &start);
+ start--; /* Convert from one-based to zero-based. */
+ gfc_extract_int (p->ref->u.ss.end, &end);
+ s = gfc_getmem (end - start + 2);
+ memcpy (s, p->value.character.string + start, end - start);
+ s[end - start + 1] = '\0'; /* TODO: C-style string. */
+ gfc_free (p->value.character.string);
+ p->value.character.string = s;
+ p->value.character.length = end - start;
+ p->ts.cl = gfc_get_charlen ();
+ p->ts.cl->next = gfc_current_ns->cl_list;
+ gfc_current_ns->cl_list = p->ts.cl;
+ p->ts.cl->length = gfc_int_expr (p->value.character.length);
+ gfc_free_ref_list (p->ref);
+ p->ref = NULL;
+ p->expr_type = EXPR_CONSTANT;
+ }
break;
case EXPR_OP:
case EXPR_VARIABLE:
/* Only substitute array parameter variables if we are in an
- initialization expression, or we want a subsection. */
+ initialization expression, or we want a subsection. */
if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
&& (gfc_init_expr || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
if (simplify_constructor (p->value.constructor, type) == FAILURE)
return FAILURE;
- if (p->expr_type == EXPR_ARRAY)
+ if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
+ && p->ref->u.ar.type == AR_FULL)
gfc_expand_constructor (p);
if (simplify_const_ref (p) == FAILURE)
be declared as. */
static bt
-et0 (gfc_expr * e)
+et0 (gfc_expr *e)
{
-
if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
return BT_INTEGER;
static try check_init_expr (gfc_expr *);
static try
-check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
+check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
{
gfc_error ("Numeric or CHARACTER operands are required in "
"expression at %L", &e->where);
- return FAILURE;
+ return FAILURE;
}
break;
if (e->value.op.operator == INTRINSIC_POWER
&& check_function == check_init_expr && et0 (op2) != BT_INTEGER)
{
- gfc_error ("Exponent at %L must be INTEGER for an initialization "
- "expression", &op2->where);
- return FAILURE;
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
+ "exponent in an initialization "
+ "expression at %L", &op2->where)
+ == FAILURE)
+ return FAILURE;
}
break;
break;
+ case INTRINSIC_PARENTHESES:
+ break;
+
default:
gfc_error ("Only intrinsic operators can be used in expression at %L",
&e->where);
this problem here. */
static try
-check_inquiry (gfc_expr * e)
+check_inquiry (gfc_expr *e, int not_restricted)
{
const char *name;
/* FIXME: This should be moved into the intrinsic definitions,
to eliminate this ugly hack. */
static const char * const inquiry_function[] = {
- "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
+ "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
"precision", "radix", "range", "tiny", "bit_size", "size", "shape",
"lbound", "ubound", NULL
};
int i;
+ /* An undeclared parameter will get us here (PR25018). */
+ if (e->symtree == NULL)
+ return FAILURE;
+
name = e->symtree->n.sym->name;
for (i = 0; inquiry_function[i]; i++)
if (e == NULL || e->expr_type != EXPR_VARIABLE)
return FAILURE;
- /* At this point we have a numeric inquiry function with a variable
- argument. The type of the variable might be undefined, but we
- need it now, because the arguments of these functions are allowed
- to be undefined. */
+ /* At this point we have an inquiry function with a variable argument. The
+ type of the variable might be undefined, but we need it now, because the
+ arguments of these functions are allowed to be undefined. */
if (e->ts.type == BT_UNKNOWN)
{
if (e->symtree->n.sym->ts.type == BT_UNKNOWN
&& gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
- == FAILURE)
+ == FAILURE)
return FAILURE;
e->ts = e->symtree->n.sym->ts;
}
+ /* Assumed character length will not reduce to a constant expression
+ with LEN, as required by the standard. */
+ if (i == 4 && not_restricted
+ && e->symtree->n.sym->ts.type == BT_CHARACTER
+ && e->symtree->n.sym->ts.cl->length == NULL)
+ gfc_notify_std (GFC_STD_GNU, "assumed character length "
+ "variable '%s' in constant expression at %L",
+ e->symtree->n.sym->name, &e->where);
+
return SUCCESS;
}
FAILURE is returned an error message has been generated. */
static try
-check_init_expr (gfc_expr * e)
+check_init_expr (gfc_expr *e)
{
gfc_actual_arglist *ap;
match m;
case EXPR_FUNCTION:
t = SUCCESS;
- if (check_inquiry (e) != SUCCESS)
+ if (check_inquiry (e, 1) != SUCCESS)
{
t = SUCCESS;
for (ap = e->value.function.actual; ap; ap = ap->next)
if (m == MATCH_NO)
gfc_error ("Function '%s' in initialization expression at %L "
"must be an intrinsic function",
- e->symtree->n.sym->name, &e->where);
+ e->symtree->n.sym->name, &e->where);
if (m != MATCH_YES)
t = FAILURE;
break;
}
- gfc_error ("Variable '%s' at %L cannot appear in an initialization "
+ if (gfc_in_match_data ())
+ break;
+
+ gfc_error ("Parameter '%s' at %L has not been declared or is "
+ "a variable, which does not reduce to a constant "
"expression", e->symtree->n.sym->name, &e->where);
t = FAILURE;
break;
expression, then reducing it to a constant. */
match
-gfc_match_init_expr (gfc_expr ** result)
+gfc_match_init_expr (gfc_expr **result)
{
gfc_expr *expr;
match m;
return MATCH_ERROR;
}
- if (!gfc_is_constant_expr (expr))
- gfc_internal_error ("Initialization expression didn't reduce %C");
+ /* Not all inquiry functions are simplified to constant expressions
+ so it is necessary to call check_inquiry again. */
+ if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) == FAILURE
+ && !gfc_in_match_data ())
+ {
+ gfc_error ("Initialization expression didn't reduce %C");
+ return MATCH_ERROR;
+ }
*result = expr;
}
-
static try check_restricted (gfc_expr *);
/* Given an actual argument list, test to see that each argument is a
integer or character. */
static try
-restricted_args (gfc_actual_arglist * a)
+restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
{
/* Make sure a non-intrinsic function is a specification function. */
static try
-external_spec_function (gfc_expr * e)
+external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
return FAILURE;
}
- if (!f->attr.pure)
+ if (!f->attr.pure && !f->attr.elemental)
{
gfc_error ("Specification function '%s' at %L must be PURE", f->name,
&e->where);
restricted expression. */
static try
-restricted_intrinsic (gfc_expr * e)
+restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
- if (check_inquiry (e) == SUCCESS)
+ if (check_inquiry (e, 0) == SUCCESS)
return SUCCESS;
return restricted_args (e->value.function.actual);
return FAILURE. */
static try
-check_restricted (gfc_expr * e)
+check_restricted (gfc_expr *e)
{
gfc_symbol *sym;
try t;
break;
case EXPR_FUNCTION:
- t = e->value.function.esym ?
- external_spec_function (e) : restricted_intrinsic (e);
+ t = e->value.function.esym ? external_spec_function (e)
+ : restricted_intrinsic (e);
break;
break;
}
+ /* gfc_is_formal_arg broadcasts that a formal argument list is being
+ processed in resolve.c(resolve_formal_arglist). This is done so
+ that host associated dummy array indices are accepted (PR23446).
+ This mechanism also does the same for the specification expressions
+ of array-valued functions. */
if (sym->attr.in_common
|| sym->attr.use_assoc
|| sym->attr.dummy
|| sym->ns != gfc_current_ns
|| (sym->ns->proc_name != NULL
- && sym->ns->proc_name->attr.flavor == FL_MODULE))
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
{
t = SUCCESS;
break;
we return FAILURE, an error has been generated. */
try
-gfc_specification_expr (gfc_expr * e)
+gfc_specification_expr (gfc_expr *e)
{
+ if (e == NULL)
+ return SUCCESS;
if (e->ts.type != BT_INTEGER)
{
/* Given two expressions, make sure that the arrays are conformable. */
try
-gfc_check_conformance (const char *optype, gfc_expr * op1, gfc_expr * op2)
+gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
if (op1->rank != op2->rank)
{
- gfc_error ("Incompatible ranks in %s at %L", optype, &op1->where);
+ gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
+ &op1->where);
return FAILURE;
}
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
- gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
- optype, &op1->where, d + 1, (int) mpz_get_si (op1_size),
+ gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
+ _(optype_msgid), &op1->where, d + 1,
+ (int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
t = FAILURE;
sure that the assignment can take place. */
try
-gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
+gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
+ gfc_ref *ref;
+ int has_pointer;
sym = lvalue->symtree->n.sym;
- if (sym->attr.intent == INTENT_IN)
+ /* Check INTENT(IN), unless the object itself is the component or
+ sub-component of a pointer. */
+ has_pointer = sym->attr.pointer;
+
+ for (ref = lvalue->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+ {
+ has_pointer = 1;
+ break;
+ }
+
+ if (!has_pointer && sym->attr.intent == INTENT_IN)
{
- gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
+ gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
sym->name, &lvalue->where);
return FAILURE;
}
+/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
+ variable local to a function subprogram. Its existence begins when
+ execution of the function is initiated and ends when execution of the
+ function is terminated.....
+ Therefore, the left hand side is no longer a varaiable, when it is: */
+ if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.external)
+ {
+ bool bad_proc;
+ bad_proc = false;
+
+ /* (i) Use associated; */
+ if (sym->attr.use_assoc)
+ bad_proc = true;
+
+ /* (ii) The assignment is in the main program; or */
+ if (gfc_current_ns->proc_name->attr.is_main_program)
+ bad_proc = true;
+
+ /* (iii) A module or internal procedure.... */
+ if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
+ || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
+ && gfc_current_ns->parent
+ && (!(gfc_current_ns->parent->proc_name->attr.function
+ || gfc_current_ns->parent->proc_name->attr.subroutine)
+ || gfc_current_ns->parent->proc_name->attr.is_main_program))
+ {
+ /* .... that is not a function.... */
+ if (!gfc_current_ns->proc_name->attr.function)
+ bad_proc = true;
+
+ /* .... or is not an entry and has a different name. */
+ if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
+ bad_proc = true;
+ }
+
+ if (bad_proc)
+ {
+ gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
+ return FAILURE;
+ }
+ }
+
if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
{
gfc_error ("Incompatible ranks %d and %d in assignment at %L",
return FAILURE;
}
- /* This is a guaranteed segfault and possibly a typo: p = NULL()
- instead of p => NULL() */
- if (rvalue->expr_type == EXPR_NULL)
- gfc_warning ("NULL appears on right-hand side in assignment at %L",
- &rvalue->where);
+ if (rvalue->expr_type == EXPR_NULL)
+ {
+ gfc_error ("NULL appears on right-hand side in assignment at %L",
+ &rvalue->where);
+ return FAILURE;
+ }
+
+ if (sym->attr.cray_pointee
+ && lvalue->ref != NULL
+ && lvalue->ref->u.ar.type == AR_FULL
+ && lvalue->ref->u.ar.as->cp_was_assumed)
+ {
+ gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
+ "is illegal", &lvalue->where);
+ return FAILURE;
+ }
/* This is possibly a typo: x = f() instead of x => f() */
if (gfc_option.warn_surprising
if (!conform)
{
- if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+ /* Numeric can be converted to any other numeric. And Hollerith can be
+ converted to any other type. */
+ if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
+ || rvalue->ts.type == BT_HOLLERITH)
return SUCCESS;
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
NULLIFY statement. */
try
-gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
+gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
+ gfc_ref *ref;
int is_pure;
+ int pointer, check_intent_in;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
{
return FAILURE;
}
- attr = gfc_variable_attr (lvalue, NULL);
- if (!attr.pointer)
+ if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && lvalue->symtree->n.sym->attr.use_assoc)
+ {
+ gfc_error ("'%s' in the pointer assignment at %L cannot be an "
+ "l-value since it is a procedure",
+ lvalue->symtree->n.sym->name, &lvalue->where);
+ return FAILURE;
+ }
+
+
+ /* Check INTENT(IN), unless the object itself is the component or
+ sub-component of a pointer. */
+ check_intent_in = 1;
+ pointer = lvalue->symtree->n.sym->attr.pointer;
+
+ for (ref = lvalue->ref; ref; ref = ref->next)
+ {
+ if (pointer)
+ check_intent_in = 0;
+
+ if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+ pointer = 1;
+ }
+
+ if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where);
+ return FAILURE;
+ }
+
+ if (!pointer)
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
{
- gfc_error ("Bad pointer object in PURE procedure at %L",
- &lvalue->where);
+ gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
return FAILURE;
}
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
pure variable if we're in a pure function. */
- if (rvalue->expr_type == EXPR_NULL)
+ if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
if (lvalue->ts.kind != rvalue->ts.kind)
{
- gfc_error ("Different kind type parameters in pointer "
+ gfc_error ("Different kind type parameters in pointer "
+ "assignment at %L", &lvalue->where);
+ return FAILURE;
+ }
+
+ if (lvalue->rank != rvalue->rank)
+ {
+ gfc_error ("Different ranks in pointer assignment at %L",
+ &lvalue->where);
+ return FAILURE;
+ }
+
+ /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
+ if (rvalue->expr_type == EXPR_NULL)
+ return SUCCESS;
+
+ if (lvalue->ts.type == BT_CHARACTER
+ && lvalue->ts.cl->length && rvalue->ts.cl->length
+ && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
+ rvalue->ts.cl->length)) == 1)
+ {
+ gfc_error ("Different character lengths in pointer "
"assignment at %L", &lvalue->where);
return FAILURE;
}
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
- gfc_error ("Pointer assignment target is neither TARGET "
+ gfc_error ("Pointer assignment target is neither TARGET "
"nor POINTER at %L", &rvalue->where);
return FAILURE;
}
if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
{
- gfc_error ("Bad target in pointer assignment in PURE "
+ gfc_error ("Bad target in pointer assignment in PURE "
"procedure at %L", &rvalue->where);
}
- if (lvalue->rank != rvalue->rank)
+ if (gfc_has_vector_index (rvalue))
+ {
+ gfc_error ("Pointer assignment with vector subscript "
+ "on rhs at %L", &rvalue->where);
+ return FAILURE;
+ }
+
+ if (attr.protected && attr.use_assoc)
{
- gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
- lvalue->rank, rvalue->rank, &rvalue->where);
+ gfc_error ("Pointer assigment target has PROTECTED "
+ "attribute at %L", &rvalue->where);
return FAILURE;
}
symbol. Used for initialization assignments. */
try
-gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
+gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
gfc_expr lvalue;
try r;
lvalue.ts = sym->ts;
if (sym->as)
lvalue.rank = sym->as->rank;
- lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
+ lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
/* See if we have a default initializer. */
for (c = ts->derived->components; c; c = c->next)
{
- if (c->initializer && init == NULL)
- init = gfc_get_expr ();
+ if ((c->initializer || c->allocatable) && init == NULL)
+ init = gfc_get_expr ();
}
if (init == NULL)
for (c = ts->derived->components; c; c = c->next)
{
if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
+ init->value.constructor = tail = gfc_get_constructor ();
else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ {
+ tail->next = gfc_get_constructor ();
+ tail = tail->next;
+ }
if (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
+ tail->expr = gfc_copy_expr (c->initializer);
+
+ if (c->allocatable)
+ {
+ tail->expr = gfc_get_expr ();
+ tail->expr->expr_type = EXPR_NULL;
+ tail->expr->ts = c->ts;
+ }
}
return init;
}
whole array. */
gfc_expr *
-gfc_get_variable_expr (gfc_symtree * var)
+gfc_get_variable_expr (gfc_symtree *var)
{
gfc_expr *e;
return e;
}
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
+
+void
+gfc_expr_set_symbols_referenced (gfc_expr *expr)
+{
+ gfc_actual_arglist *arg;
+ gfc_constructor *c;
+ gfc_ref *ref;
+ int i;
+
+ if (!expr) return;
+
+ switch (expr->expr_type)
+ {
+ case EXPR_OP:
+ gfc_expr_set_symbols_referenced (expr->value.op.op1);
+ gfc_expr_set_symbols_referenced (expr->value.op.op2);
+ break;
+
+ case EXPR_FUNCTION:
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ gfc_expr_set_symbols_referenced (arg->expr);
+ break;
+
+ case EXPR_VARIABLE:
+ gfc_set_sym_referenced (expr->symtree->n.sym);
+ break;
+
+ case EXPR_CONSTANT:
+ case EXPR_NULL:
+ case EXPR_SUBSTRING:
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = expr->value.constructor; c; c = c->next)
+ gfc_expr_set_symbols_referenced (c->expr);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
+ gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
+ gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
+ }
+ break;
+
+ case REF_COMPONENT:
+ break;
+
+ case REF_SUBSTRING:
+ gfc_expr_set_symbols_referenced (ref->u.ss.start);
+ gfc_expr_set_symbols_referenced (ref->u.ss.end);
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+}
OSDN Git Service
