/* 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, 2008
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "arith.h"
#include "match.h"
+#include "target-memory.h" /* for gfc_convert_boz */
/* Get a new expr node. */
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;
- }
-
+ /* Free any parts of the value that need freeing. */
switch (e->ts.type)
{
case BT_INTEGER:
break;
case BT_CHARACTER:
- case BT_HOLLERITH:
gfc_free (e->value.character.string);
break;
break;
}
+ /* Free the representation, except in character constants where it
+ is the same as value.character.string and thus already freed. */
+ if (e->representation.string && e->ts.type != BT_CHARACTER)
+ gfc_free (e->representation.string);
+
break;
case EXPR_OP:
/* 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");
/* 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;
{ s1 ... sN-1 sN+1 ... sR-1}
If anything goes wrong -- N is not a constant, its value is out
- of range -- or anything else, just returns NULL.
-*/
+ of range -- or anything else, just returns NULL. */
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;
return NULL;
n = mpz_get_si (dim->value.integer);
- n--; /* Convert to zero based index */
+ n--; /* Convert to zero based index. */
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)
+ /* Copy target representation, if it exists. */
+ if (p->representation.string)
{
- s = gfc_getmem (p->value.character.length + 1);
- q->value.character.string = s;
+ s = gfc_getmem (p->representation.length + 1);
+ q->representation.string = s;
- memcpy (s, p->value.character.string,
- p->value.character.length + 1);
- break;
+ memcpy (s, p->representation.string, p->representation.length + 1);
}
+
+ /* Copy the values of any pointer components of p->value. */
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;
+ if (p->representation.string)
+ q->value.character.string = q->representation.string;
+ else
+ {
+ s = gfc_getmem (p->value.character.length + 1);
+ q->value.character.string = s;
- memcpy (s, p->value.character.string,
- p->value.character.length + 1);
+ /* This is the case for the C_NULL_CHAR named constant. */
+ if (p->value.character.length == 0
+ && (p->ts.is_c_interop || p->ts.is_iso_c))
+ {
+ *s = '\0';
+ /* Need to set the length to 1 to make sure the NUL
+ terminator is copied. */
+ q->value.character.length = 1;
+ }
+ else
+ memcpy (s, p->value.character.string,
+ p->value.character.length + 1);
+ }
break;
+ case BT_HOLLERITH:
case BT_LOGICAL:
case BT_DERIVED:
- break; /* Already done */
+ break; /* Already done. */
case BT_PROCEDURE:
+ case BT_VOID:
+ /* Should never be reached. */
case BT_UNKNOWN:
gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached */
+ /* Not reached. */
}
break;
switch (q->value.op.operator)
{
case INTRINSIC_NOT:
+ case INTRINSIC_PARENTHESES:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
break;
- default: /* Binary operators */
+ default: /* Binary operators. */
q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
break;
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;
}
}
+static match
+check_specification_function (gfc_expr *e)
+{
+ gfc_symbol *sym;
+
+ if (!e->symtree)
+ return MATCH_NO;
+
+ sym = e->symtree->n.sym;
+
+ /* F95, 7.1.6.2; F2003, 7.1.7 */
+ if (sym
+ && sym->attr.function
+ && sym->attr.pure
+ && !sym->attr.intrinsic
+ && !sym->attr.recursive
+ && sym->attr.proc != PROC_INTERNAL
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && sym->attr.proc != PROC_UNKNOWN
+ && sym->formal == NULL)
+ return MATCH_YES;
+
+ return MATCH_NO;
+}
+
/* Function to determine if an expression is constant or not. This
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;
rv = (gfc_is_constant_expr (e->value.op.op1)
&& (e->value.op.op2 == NULL
|| gfc_is_constant_expr (e->value.op.op2)));
-
break;
case EXPR_VARIABLE:
break;
case EXPR_FUNCTION:
+ /* Specification functions are constant. */
+ if (check_specification_function (e) == MATCH_YES)
+ {
+ rv = 1;
+ break;
+ }
+
/* Call to intrinsic with at least one argument. */
rv = 0;
if (e->value.function.isym && e->value.function.actual)
break;
case EXPR_SUBSTRING:
- rv = (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
+ rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+ && gfc_is_constant_expr (e->ref->u.ss.end));
break;
case EXPR_STRUCTURE:
}
+/* Is true if an array reference is followed by a component or substring
+ reference. */
+bool
+is_subref_array (gfc_expr * e)
+{
+ gfc_ref * ref;
+ bool seen_array;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (e->symtree->n.sym->attr.subref_array_pointer)
+ return true;
+
+ seen_array = false;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type != AR_ELEMENT)
+ seen_array = true;
+
+ if (seen_array
+ && ref->type != REF_ARRAY)
+ return seen_array;
+ }
+ return false;
+}
+
+
/* Try to collapse intrinsic expressions. */
static try
-simplify_intrinsic_op (gfc_expr * p, int type)
+simplify_intrinsic_op (gfc_expr *p, int type)
{
+ gfc_intrinsic_op op;
gfc_expr *op1, *op2, *result;
if (p->value.op.operator == INTRINSIC_USER)
op1 = p->value.op.op1;
op2 = p->value.op.op2;
+ op = p->value.op.operator;
if (gfc_simplify_expr (op1, type) == FAILURE)
return FAILURE;
|| (op2 != NULL && !gfc_is_constant_expr (op2)))
return SUCCESS;
- /* Rip p apart */
+ /* Rip p apart. */
p->value.op.op1 = NULL;
p->value.op.op2 = NULL;
- switch (p->value.op.operator)
+ switch (op)
{
+ case INTRINSIC_PARENTHESES:
+ result = gfc_parentheses (op1);
+ break;
+
case INTRINSIC_UPLUS:
result = gfc_uplus (op1);
break;
break;
case INTRINSIC_EQ:
- result = gfc_eq (op1, op2);
+ case INTRINSIC_EQ_OS:
+ result = gfc_eq (op1, op2, op);
break;
case INTRINSIC_NE:
- result = gfc_ne (op1, op2);
+ case INTRINSIC_NE_OS:
+ result = gfc_ne (op1, op2, op);
break;
case INTRINSIC_GT:
- result = gfc_gt (op1, op2);
+ case INTRINSIC_GT_OS:
+ result = gfc_gt (op1, op2, op);
break;
case INTRINSIC_GE:
- result = gfc_ge (op1, op2);
+ case INTRINSIC_GE_OS:
+ result = gfc_ge (op1, op2, op);
break;
case INTRINSIC_LT:
- result = gfc_lt (op1, op2);
+ case INTRINSIC_LT_OS:
+ result = gfc_lt (op1, op2, op);
break;
case INTRINSIC_LE:
- result = gfc_le (op1, op2);
+ case INTRINSIC_LE_OS:
+ result = gfc_le (op1, op2, op);
break;
case INTRINSIC_NOT:
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)
{
+ gfc_expr *p;
for (; c; c = c->next)
{
|| gfc_simplify_expr (c->iterator->step, type) == FAILURE))
return FAILURE;
- if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
- return FAILURE;
+ if (c->expr)
+ {
+ /* Try and simplify a copy. Replace the original if successful
+ but keep going through the constructor at all costs. Not
+ doing so can make a dog's dinner of complicated things. */
+ p = gfc_copy_expr (c->expr);
+
+ if (gfc_simplify_expr (p, type) == FAILURE)
+ {
+ gfc_free_expr (p);
+ continue;
+ }
+
+ gfc_replace_expr (c->expr, p);
+ }
}
return SUCCESS;
/* 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;
+ mpz_t span;
+ mpz_t tmp;
+ gfc_expr *e;
+ try t;
+
+ t = SUCCESS;
+ e = NULL;
mpz_init_set_ui (offset, 0);
mpz_init (delta);
+ mpz_init (tmp);
+ mpz_init_set_ui (span, 1);
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;
}
- mpz_sub (delta, ar->start[i]->value.integer,
- ar->as->lower[i]->value.integer);
- mpz_add (offset, offset, delta);
- }
-
- if (cons)
- {
- if (mpz_fits_ulong_p (offset))
+ /* Check the bounds. */
+ if ((ar->as->upper[i]
+ && ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (e->value.integer,
+ ar->as->upper[i]->value.integer) > 0)
+ ||
+ (ar->as->lower[i]->expr_type == EXPR_CONSTANT
+ && mpz_cmp (e->value.integer,
+ ar->as->lower[i]->value.integer) < 0))
{
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
- {
- if (cons->iterator)
- {
- cons = NULL;
- break;
- }
- cons = cons->next;
- }
+ gfc_error ("Index in dimension %d is out of bounds "
+ "at %L", i + 1, &ar->c_where[i]);
+ cons = NULL;
+ t = FAILURE;
+ goto depart;
}
- else
- cons = NULL;
+
+ mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
+ mpz_mul (delta, delta, span);
+ mpz_add (offset, offset, delta);
+
+ mpz_set_ui (tmp, 1);
+ mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
+ mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
+ mpz_mul (span, span, tmp);
}
+ for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ {
+ if (cons)
+ {
+ if (cons->iterator)
+ {
+ cons = NULL;
+
+ goto depart;
+ }
+ cons = cons->next;
+ }
+ }
+
+depart:
mpz_clear (delta);
mpz_clear (offset);
-
- return cons;
+ mpz_clear (span);
+ mpz_clear (tmp);
+ 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);
+
+ if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
+ {
+ t = FAILURE;
+ goto cleanup;
+ }
+
+ 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_set (tmp_mpz, stride[d]);
+ 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 (cons && cons->next && 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;
+ int length;
+ 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);
+ gfc_free ((*newp)->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);
+ length = end - start + 1;
+
+ chr = (*newp)->value.character.string = gfc_getmem (length + 1);
+ (*newp)->value.character.length = length;
+ memcpy (chr, &p->value.character.string[start - 1], length);
+ chr[length] = '\0';
+ 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;
+
+ /* Fall through. */
+
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 (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)
+ /* Only use the simplification if it eliminated all subobject references. */
+ 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;
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 + 1);
+ if (p->ref && p->ref->u.ss.start)
+ {
+ gfc_extract_int (p->ref->u.ss.start, &start);
+ start--; /* Convert from one-based to zero-based. */
+ }
+ else
+ start = 0;
+
+ if (p->ref && p->ref->u.ss.end)
+ gfc_extract_int (p->ref->u.ss.end, &end);
+ else
+ end = p->value.character.length;
+
+ s = gfc_getmem (end - start + 2);
memcpy (s, p->value.character.string + start, end - start);
- s[end] = '\0'; /* TODO: C-style string for debugging. */
+ 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;
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 *);
+
+/* Scalarize an expression for an elemental intrinsic call. */
+
+static try
+scalarize_intrinsic_call (gfc_expr *e)
+{
+ gfc_actual_arglist *a, *b;
+ gfc_constructor *args[5], *ctor, *new_ctor;
+ gfc_expr *expr, *old;
+ int n, i, rank[5];
+
+ old = gfc_copy_expr (e);
+
+/* Assume that the old expression carries the type information and
+ that the first arg carries all the shape information. */
+ expr = gfc_copy_expr (old->value.function.actual->expr);
+ gfc_free_constructor (expr->value.constructor);
+ expr->value.constructor = NULL;
+
+ expr->ts = old->ts;
+ expr->expr_type = EXPR_ARRAY;
+
+ /* Copy the array argument constructors into an array, with nulls
+ for the scalars. */
+ n = 0;
+ a = old->value.function.actual;
+ for (; a; a = a->next)
+ {
+ /* Check that this is OK for an initialization expression. */
+ if (a->expr && check_init_expr (a->expr) == FAILURE)
+ goto cleanup;
+
+ rank[n] = 0;
+ if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
+ {
+ rank[n] = a->expr->rank;
+ ctor = a->expr->symtree->n.sym->value->value.constructor;
+ args[n] = gfc_copy_constructor (ctor);
+ }
+ else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
+ {
+ if (a->expr->rank)
+ rank[n] = a->expr->rank;
+ else
+ rank[n] = 1;
+ args[n] = gfc_copy_constructor (a->expr->value.constructor);
+ }
+ else
+ args[n] = NULL;
+ n++;
+ }
+
+ for (i = 1; i < n; i++)
+ if (rank[i] && rank[i] != rank[0])
+ goto compliance;
+
+ /* Using the first argument as the master, step through the array
+ calling the function for each element and advancing the array
+ constructors together. */
+ ctor = args[0];
+ new_ctor = NULL;
+ for (; ctor; ctor = ctor->next)
+ {
+ if (expr->value.constructor == NULL)
+ expr->value.constructor
+ = new_ctor = gfc_get_constructor ();
+ else
+ {
+ new_ctor->next = gfc_get_constructor ();
+ new_ctor = new_ctor->next;
+ }
+ new_ctor->expr = gfc_copy_expr (old);
+ gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+ a = NULL;
+ b = old->value.function.actual;
+ for (i = 0; i < n; i++)
+ {
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
+ else
+ {
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
+ }
+ if (args[i])
+ a->expr = gfc_copy_expr (args[i]->expr);
+ else
+ a->expr = gfc_copy_expr (b->expr);
+
+ b = b->next;
+ }
+
+ /* Simplify the function calls. */
+ if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
+ goto cleanup;
+
+ for (i = 0; i < n; i++)
+ if (args[i])
+ args[i] = args[i]->next;
+
+ for (i = 1; i < n; i++)
+ if (rank[i] && ((args[i] != NULL && args[0] == NULL)
+ || (args[i] == NULL && args[0] != NULL)))
+ goto compliance;
+ }
+
+ free_expr0 (e);
+ *e = *expr;
+ gfc_free_expr (old);
+ return SUCCESS;
+
+compliance:
+ gfc_error_now ("elemental function arguments at %C are not compliant");
+
+cleanup:
+ gfc_free_expr (expr);
+ gfc_free_expr (old);
+ return FAILURE;
+}
+
+
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;
break;
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
if ((*check_function) (op2) == FAILURE)
return FAILURE;
{
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);
}
+static match
+check_init_expr_arguments (gfc_expr *e)
+{
+ gfc_actual_arglist *ap;
-/* Certain inquiry functions are specifically allowed to have variable
- arguments, which is an exception to the normal requirement that an
- initialization function have initialization arguments. We head off
- this problem here. */
+ for (ap = e->value.function.actual; ap; ap = ap->next)
+ if (check_init_expr (ap->expr) == FAILURE)
+ return MATCH_ERROR;
-static try
-check_inquiry (gfc_expr * e)
+ return MATCH_YES;
+}
+
+/* F95, 7.1.6.1, Initialization expressions, (7)
+ F2003, 7.1.7 Initialization expression, (8) */
+
+static match
+check_inquiry (gfc_expr *e, int not_restricted)
{
const char *name;
+ const char *const *functions;
+
+ static const char *const inquiry_func_f95[] = {
+ "lbound", "shape", "size", "ubound",
+ "bit_size", "len", "kind",
+ "digits", "epsilon", "huge", "maxexponent", "minexponent",
+ "precision", "radix", "range", "tiny",
+ NULL
+ };
- /* 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",
- "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
- "lbound", "ubound", NULL
+ static const char *const inquiry_func_f2003[] = {
+ "lbound", "shape", "size", "ubound",
+ "bit_size", "len", "kind",
+ "digits", "epsilon", "huge", "maxexponent", "minexponent",
+ "precision", "radix", "range", "tiny",
+ "new_line", NULL
};
int i;
+ gfc_actual_arglist *ap;
+
+ if (!e->value.function.isym
+ || !e->value.function.isym->inquiry)
+ return MATCH_NO;
+
+ /* An undeclared parameter will get us here (PR25018). */
+ if (e->symtree == NULL)
+ return MATCH_NO;
name = e->symtree->n.sym->name;
- for (i = 0; inquiry_function[i]; i++)
- if (strcmp (inquiry_function[i], name) == 0)
+ functions = (gfc_option.warn_std & GFC_STD_F2003)
+ ? inquiry_func_f2003 : inquiry_func_f95;
+
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[i], name) == 0)
break;
- if (inquiry_function[i] == NULL)
- return FAILURE;
+ if (functions[i] == NULL)
+ return MATCH_ERROR;
- e = e->value.function.actual->expr;
+ /* 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 not allowed to be undefined. */
- if (e == NULL || e->expr_type != EXPR_VARIABLE)
- return FAILURE;
+ for (ap = e->value.function.actual; ap; ap = ap->next)
+ {
+ if (!ap->expr)
+ continue;
- /* 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. */
+ if (ap->expr->ts.type == BT_UNKNOWN)
+ {
+ if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
+ == FAILURE)
+ return MATCH_NO;
- 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)
- return FAILURE;
+ ap->expr->ts = ap->expr->symtree->n.sym->ts;
+ }
- 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 == 5 && not_restricted
+ && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
+ && ap->expr->symtree->n.sym->ts.cl->length == NULL)
+ {
+ gfc_error ("Assumed character length variable '%s' in constant "
+ "expression at %L", e->symtree->n.sym->name, &e->where);
+ return MATCH_ERROR;
+ }
+ else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
+ return MATCH_ERROR;
}
- return SUCCESS;
+ return MATCH_YES;
+}
+
+
+/* F95, 7.1.6.1, Initialization expressions, (5)
+ F2003, 7.1.7 Initialization expression, (5) */
+
+static match
+check_transformational (gfc_expr *e)
+{
+ static const char * const trans_func_f95[] = {
+ "repeat", "reshape", "selected_int_kind",
+ "selected_real_kind", "transfer", "trim", NULL
+ };
+
+ int i;
+ const char *name;
+
+ if (!e->value.function.isym
+ || !e->value.function.isym->transformational)
+ return MATCH_NO;
+
+ name = e->symtree->n.sym->name;
+
+ /* NULL() is dealt with below. */
+ if (strcmp ("null", name) == 0)
+ return MATCH_NO;
+
+ for (i = 0; trans_func_f95[i]; i++)
+ if (strcmp (trans_func_f95[i], name) == 0)
+ break;
+
+ /* FIXME, F2003: implement translation of initialization
+ expressions before enabling this check. For F95, error
+ out if the transformational function is not in the list. */
+#if 0
+ if (trans_func_f95[i] == NULL
+ && gfc_notify_std (GFC_STD_F2003,
+ "transformational intrinsic '%s' at %L is not permitted "
+ "in an initialization expression", name, &e->where) == FAILURE)
+ return MATCH_ERROR;
+#else
+ if (trans_func_f95[i] == NULL)
+ {
+ gfc_error("transformational intrinsic '%s' at %L is not permitted "
+ "in an initialization expression", name, &e->where);
+ return MATCH_ERROR;
+ }
+#endif
+
+ return check_init_expr_arguments (e);
+}
+
+
+/* F95, 7.1.6.1, Initialization expressions, (6)
+ F2003, 7.1.7 Initialization expression, (6) */
+
+static match
+check_null (gfc_expr *e)
+{
+ if (strcmp ("null", e->symtree->n.sym->name) != 0)
+ return MATCH_NO;
+
+ return check_init_expr_arguments (e);
+}
+
+
+static match
+check_elemental (gfc_expr *e)
+{
+ if (!e->value.function.isym
+ || !e->value.function.isym->elemental)
+ return MATCH_NO;
+
+ if (e->ts.type != BT_INTEGER
+ && e->ts.type != BT_CHARACTER
+ && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
+ "nonstandard initialization expression at %L",
+ &e->where) == FAILURE)
+ return MATCH_ERROR;
+
+ return check_init_expr_arguments (e);
+}
+
+
+static match
+check_conversion (gfc_expr *e)
+{
+ if (!e->value.function.isym
+ || !e->value.function.isym->conversion)
+ return MATCH_NO;
+
+ return check_init_expr_arguments (e);
}
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;
try t;
+ gfc_intrinsic_sym *isym;
if (e == NULL)
return SUCCESS;
break;
case EXPR_FUNCTION:
- t = SUCCESS;
-
- if (check_inquiry (e) != SUCCESS)
- {
- t = SUCCESS;
- for (ap = e->value.function.actual; ap; ap = ap->next)
- if (check_init_expr (ap->expr) == FAILURE)
- {
- t = FAILURE;
- break;
- }
- }
+ t = FAILURE;
- if (t == SUCCESS)
+ if ((m = check_specification_function (e)) != MATCH_YES)
{
- m = gfc_intrinsic_func_interface (e, 0);
+ if ((m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ {
+ gfc_error ("Function '%s' in initialization expression at %L "
+ "must be an intrinsic or a specification function",
+ e->symtree->n.sym->name, &e->where);
+ break;
+ }
- 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);
+ if ((m = check_conversion (e)) == MATCH_NO
+ && (m = check_inquiry (e, 1)) == MATCH_NO
+ && (m = check_null (e)) == MATCH_NO
+ && (m = check_transformational (e)) == MATCH_NO
+ && (m = check_elemental (e)) == MATCH_NO)
+ {
+ gfc_error ("Intrinsic function '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ m = MATCH_ERROR;
+ }
- if (m != MATCH_YES)
- t = FAILURE;
+ /* Try to scalarize an elemental intrinsic function that has an
+ array argument. */
+ isym = gfc_find_function (e->symtree->n.sym->name);
+ if (isym && isym->elemental
+ && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
+ {
+ if ((t = scalarize_intrinsic_call (e)) == SUCCESS)
+ break;
+ }
}
+ if (m == MATCH_YES)
+ t = gfc_simplify_expr (e, 0);
+
break;
case EXPR_VARIABLE:
if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
{
- t = simplify_parameter_variable (e, 0);
+ /* A PARAMETER shall not be used to define itself, i.e.
+ REAL, PARAMETER :: x = transfer(0, x)
+ is invalid. */
+ if (!e->symtree->n.sym->value)
+ {
+ gfc_error("PARAMETER '%s' is used at %L before its definition "
+ "is complete", e->symtree->n.sym->name, &e->where);
+ t = FAILURE;
+ }
+ else
+ t = simplify_parameter_variable (e, 0);
+
break;
}
- gfc_error ("Variable '%s' at %L cannot appear in an initialization "
- "expression", e->symtree->n.sym->name, &e->where);
+ if (gfc_in_match_data ())
+ break;
+
t = FAILURE;
+
+ if (e->symtree->n.sym->as)
+ {
+ switch (e->symtree->n.sym->as->type)
+ {
+ case AS_ASSUMED_SIZE:
+ gfc_error ("Assumed size array '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ break;
+
+ case AS_ASSUMED_SHAPE:
+ gfc_error ("Assumed shape array '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ break;
+
+ case AS_DEFERRED:
+ gfc_error ("Deferred array '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ break;
+
+ case AS_EXPLICIT:
+ gfc_error ("Array '%s' at %L is a variable, which does "
+ "not reduce to a constant expression",
+ e->symtree->n.sym->name, &e->where);
+ break;
+
+ default:
+ gcc_unreachable();
+ }
+ }
+ else
+ 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);
+
break;
case EXPR_CONSTANT:
break;
case EXPR_STRUCTURE:
- t = gfc_check_constructor (e, check_init_expr);
+ if (e->ts.is_iso_c)
+ t = SUCCESS;
+ else
+ t = gfc_check_constructor (e, check_init_expr);
break;
case EXPR_ARRAY:
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) != MATCH_YES
+ && !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) == MATCH_YES)
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;
case EXPR_VARIABLE:
sym = e->symtree->n.sym;
t = FAILURE;
+ /* If a dummy argument appears in a context that is valid for a
+ restricted expression in an elemental procedure, it will have
+ already been simplified away once we get here. Therefore we
+ don't need to jump through hoops to distinguish valid from
+ invalid cases. */
+ if (sym->attr.dummy && sym->ns == gfc_current_ns
+ && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
+ {
+ gfc_error ("Dummy argument '%s' not allowed in expression at %L",
+ sym->name, &e->where);
+ break;
+ }
+
if (sym->attr.optional)
{
gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
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->attr.implied_index
|| 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)
{
gfc_error ("Expression at %L must be of INTEGER type", &e->where);
return FAILURE;
}
+ if (e->expr_type == EXPR_FUNCTION
+ && !e->value.function.isym
+ && !e->value.function.esym
+ && !gfc_pure (e->symtree->n.sym))
+ {
+ gfc_error ("Function '%s' at %L must be PURE",
+ e->symtree->n.sym->name, &e->where);
+ /* Prevent repeat error messages. */
+ e->symtree->n.sym->attr.pure = 1;
+ return FAILURE;
+ }
+
if (e->rank != 0)
{
gfc_error ("Expression at %L must be scalar", &e->where);
/* Given two expressions, make sure that the arrays are conformable. */
try
-gfc_check_conformance (const char *optype_msgid,
- 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_msgid),
- &op1->where);
+ gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
+ op1->rank, op2->rank, &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_msgid), &op1->where, d + 1,
+ gfc_error ("Different shape for %s at %L on dimension %d "
+ "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
(int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
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 variable, 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;
+ }
+
+ /* (iv) Host associated and not the function symbol or the
+ parent result. This picks up sibling references, which
+ cannot be entries. */
+ if (!sym->attr.entry
+ && sym->ns == gfc_current_ns->parent
+ && sym != gfc_current_ns->proc_name
+ && sym != gfc_current_ns->parent->proc_name->result)
+ 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;
}
- if (rvalue->expr_type == EXPR_NULL)
+ if (rvalue->expr_type == EXPR_NULL)
+ {
+ if (lvalue->symtree->n.sym->attr.pointer
+ && lvalue->symtree->n.sym->attr.data)
+ return SUCCESS;
+ else
+ {
+ 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 ("NULL appears on right-hand side in assignment at %L",
- &rvalue->where);
+ 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() */
+ /* This is possibly a typo: x = f() instead of x => f(). */
if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
&& rvalue->symtree->n.sym->attr.pointer)
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
- && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
+ && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
+ return FAILURE;
+
+ if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
+ && lvalue->symtree->n.sym->attr.data
+ && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
+ "initialize non-integer variable '%s'",
+ &rvalue->where, lvalue->symtree->n.sym->name)
+ == FAILURE)
return FAILURE;
+ else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
+ && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
+ "a DATA statement and outside INT/REAL/DBLE/CMPLX",
+ &rvalue->where) == FAILURE)
+ return FAILURE;
+
+ /* Handle the case of a BOZ literal on the RHS. */
+ if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
+ {
+ int rc;
+ if (gfc_option.warn_surprising)
+ gfc_warning ("BOZ literal at %L is bitwise transferred "
+ "non-integer symbol '%s'", &rvalue->where,
+ lvalue->symtree->n.sym->name);
+ if (!gfc_convert_boz (rvalue, &lvalue->ts))
+ return FAILURE;
+ if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
+ {
+ if (rc == ARITH_UNDERFLOW)
+ gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rvalue->where);
+ else if (rc == ARITH_OVERFLOW)
+ gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rvalue->where);
+ else if (rc == ARITH_NAN)
+ gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
+ ". This check can be disabled with the option "
+ "-fno-range-check", &rvalue->where);
+ return FAILURE;
+ }
+ }
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return SUCCESS;
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
return SUCCESS;
- gfc_error ("Incompatible types in assignment at %L, %s to %s",
- &rvalue->where, gfc_typename (&rvalue->ts),
+ gfc_error ("Incompatible types in assignment at %L; attempted assignment "
+ "of %s to %s", &rvalue->where, gfc_typename (&rvalue->ts),
gfc_typename (&lvalue->ts));
return FAILURE;
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;
is_pure = gfc_pure (NULL);
- if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
+ if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
+ && lvalue->symtree->n.sym->value != rvalue)
{
- 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))
{
- gfc_error ("Different types in pointer assignment at %L",
- &lvalue->where);
+ gfc_error ("Different types in pointer assignment at %L; attempted "
+ "assignment of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
return FAILURE;
}
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 && rvalue->ts.cl
+ && 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;
+ }
+
+ if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
+ lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
+
attr = gfc_expr_attr (rvalue);
if (!attr.target && !attr.pointer)
{
"procedure at %L", &rvalue->where);
}
- if (lvalue->rank != rvalue->rank)
+ if (gfc_has_vector_index (rvalue))
{
- gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
- lvalue->rank, rvalue->rank, &rvalue->where);
+ gfc_error ("Pointer assignment with vector subscript "
+ "on rhs at %L", &rvalue->where);
+ return FAILURE;
+ }
+
+ if (attr.protected && attr.use_assoc)
+ {
+ 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;
gfc_expr *init;
gfc_component *c;
- init = NULL;
-
/* 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)
+ break;
- if (init == NULL)
+ if (!c)
return NULL;
/* Build the constructor. */
+ init = gfc_get_expr ();
init->expr_type = EXPR_STRUCTURE;
init->ts = *ts;
init->where = ts->derived->declared_at;
+
tail = 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;
}
+
+/* General expression traversal function. */
+
+bool
+gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
+ bool (*func)(gfc_expr *, gfc_symbol *, int*),
+ int f)
+{
+ gfc_array_ref ar;
+ gfc_ref *ref;
+ gfc_actual_arglist *args;
+ gfc_constructor *c;
+ int i;
+
+ if (!expr)
+ return false;
+
+ if ((*func) (expr, sym, &f))
+ return true;
+
+ if (expr->ts.type == BT_CHARACTER
+ && expr->ts.cl
+ && expr->ts.cl->length
+ && expr->ts.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ return true;
+
+ switch (expr->expr_type)
+ {
+ case EXPR_FUNCTION:
+ for (args = expr->value.function.actual; args; args = args->next)
+ {
+ if (gfc_traverse_expr (args->expr, sym, func, f))
+ return true;
+ }
+ break;
+
+ case EXPR_VARIABLE:
+ 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)
+ {
+ if (gfc_traverse_expr (c->expr, sym, func, f))
+ return true;
+ if (c->iterator)
+ {
+ if (gfc_traverse_expr (c->iterator->var, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->start, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->end, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (c->iterator->step, sym, func, f))
+ return true;
+ }
+ }
+ break;
+
+ case EXPR_OP:
+ if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
+ return true;
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ ref = expr->ref;
+ while (ref != NULL)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ ar = ref->u.ar;
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ if (gfc_traverse_expr (ar.start[i], sym, func, f))
+ return true;
+ if (gfc_traverse_expr (ar.end[i], sym, func, f))
+ return true;
+ if (gfc_traverse_expr (ar.stride[i], sym, func, f))
+ return true;
+ }
+ break;
+
+ case REF_SUBSTRING:
+ if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
+ return true;
+ if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
+ return true;
+ break;
+
+ case REF_COMPONENT:
+ if (ref->u.c.component->ts.type == BT_CHARACTER
+ && ref->u.c.component->ts.cl
+ && ref->u.c.component->ts.cl->length
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT
+ && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ sym, func, f))
+ return true;
+
+ if (ref->u.c.component->as)
+ for (i = 0; i < ref->u.c.component->as->rank; i++)
+ {
+ if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
+ sym, func, f))
+ return true;
+ if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
+ sym, func, f))
+ return true;
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ ref = ref->next;
+ }
+ return false;
+}
+
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
+
+static bool
+expr_set_symbols_referenced (gfc_expr *expr,
+ gfc_symbol *sym ATTRIBUTE_UNUSED,
+ int *f ATTRIBUTE_UNUSED)
+{
+ if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+ gfc_set_sym_referenced (expr->symtree->n.sym);
+ return false;
+}
+
+void
+gfc_expr_set_symbols_referenced (gfc_expr *expr)
+{
+ gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
+}