/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
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));
+ e = XCNEW (gfc_expr);
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
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)
+ /* Free the representation. */
+ if (e->representation.string)
gfc_free (e->representation.string);
break;
gfc_copy_expr (gfc_expr *p)
{
gfc_expr *q;
- char *s;
+ gfc_char_t *s;
+ char *c;
if (p == NULL)
return NULL;
switch (q->expr_type)
{
case EXPR_SUBSTRING:
- s = gfc_getmem (p->value.character.length + 1);
+ s = gfc_get_wide_string (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) * sizeof (gfc_char_t));
break;
case EXPR_CONSTANT:
/* Copy target representation, if it exists. */
if (p->representation.string)
{
- s = gfc_getmem (p->representation.length + 1);
- q->representation.string = s;
-
- memcpy (s, p->representation.string, p->representation.length + 1);
+ c = XCNEWVEC (char, p->representation.length + 1);
+ q->representation.string = c;
+ memcpy (c, p->representation.string, (p->representation.length + 1));
}
/* Copy the values of any pointer components of p->value. */
case BT_CHARACTER:
if (p->representation.string)
- q->value.character.string = q->representation.string;
+ q->value.character.string
+ = gfc_char_to_widechar (q->representation.string);
else
{
- s = gfc_getmem (p->value.character.length + 1);
+ s = gfc_get_wide_string (p->value.character.length + 1);
q->value.character.string = s;
/* This is the case for the C_NULL_CHAR named constant. */
}
else
memcpy (s, p->value.character.string,
- p->value.character.length + 1);
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
}
break;
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 */
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
static try
simplify_constructor (gfc_constructor *c, int type)
{
+ gfc_expr *p;
+
for (; c; c = c->next)
{
if (c->iterator
|| 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;
cons = NULL;
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))
+ /* 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))
{
- gfc_error ("index in dimension %d is out of bounds "
+ gfc_error ("Index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
cons = NULL;
t = FAILURE;
mpz_mul (span, span, tmp);
}
- if (cons)
- {
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
- {
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
- }
- }
+ 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);
{
gcc_assert (begin);
- if (begin->expr_type != EXPR_ARRAY)
+ if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
{
t = FAILURE;
goto cleanup;
cons = base;
}
- while (mpz_cmp (ptr, index) > 0)
+ while (cons && cons->next && mpz_cmp (ptr, index) > 0)
{
mpz_add_ui (index, index, one);
cons = cons->next;
{
int end;
int start;
- char *chr;
+ int length;
+ gfc_char_t *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;
+ 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;
- (*newp)->value.character.length = end - start + 1;
- strncpy ((*newp)->value.character.string, &chr[start - 1],
- (*newp)->value.character.length);
+ chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
+ (*newp)->value.character.length = length;
+ memcpy (chr, &p->value.character.string[start - 1],
+ length * sizeof (gfc_char_t));
+ chr[length] = '\0';
return SUCCESS;
}
if (gfc_is_constant_expr (p))
{
- char *s;
+ gfc_char_t *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);
+ 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_get_wide_string (end - start + 2);
+ memcpy (s, p->value.character.string + start,
+ (end - start) * sizeof (gfc_char_t));
s[end - start + 1] = '\0'; /* TODO: C-style string. */
gfc_free (p->value.character.string);
p->value.character.string = s;
gfc_actual_arglist *a, *b;
gfc_constructor *args[5], *ctor, *new_ctor;
gfc_expr *expr, *old;
- int n, i, rank[5];
+ int n, i, rank[5], array_arg;
+
+ /* Find which, if any, arguments are arrays. Assume that the old
+ expression carries the type information and that the first arg
+ that is an array expression carries all the shape information.*/
+ n = array_arg = 0;
+ a = e->value.function.actual;
+ for (; a; a = a->next)
+ {
+ n++;
+ if (a->expr->expr_type != EXPR_ARRAY)
+ continue;
+ array_arg = n;
+ expr = gfc_copy_expr (a->expr);
+ break;
+ }
+
+ if (!array_arg)
+ return FAILURE;
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->where = old->where;
expr->expr_type = EXPR_ARRAY;
/* Copy the array argument constructors into an array, with nulls
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
+ /* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[0];
+ ctor = args[array_arg - 1];
new_ctor = NULL;
for (; ctor; ctor = ctor->next)
{
b = b->next;
}
- /* Simplify the function calls. */
- if (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
- goto cleanup;
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
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)))
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
goto compliance;
}
break;
if (functions[i] == NULL)
- {
- gfc_error ("Inquiry function '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where);
- return MATCH_ERROR;
- }
+ return MATCH_ERROR;
/* 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
&& 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 "
+ gfc_error ("Assumed character length variable '%s' in constant "
"expression at %L", e->symtree->n.sym->name, &e->where);
return MATCH_ERROR;
}
|| !e->value.function.isym->elemental)
return MATCH_NO;
- if ((e->ts.type != BT_INTEGER || e->ts.type != BT_CHARACTER)
+ 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)
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;
- }
+ && (t = scalarize_intrinsic_call (e)) == SUCCESS)
+ break;
}
if (m == MATCH_YES)
- t = SUCCESS;
+ t = gfc_simplify_expr (e, 0);
break;
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;
}
switch (e->symtree->n.sym->as->type)
{
case AS_ASSUMED_SIZE:
- gfc_error ("assumed size array '%s' at %L is not permitted "
+ 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 "
+ 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 "
+ 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();
}
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:
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",
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)
if (e->ts.type != BT_INTEGER)
{
- gfc_error ("Expression at %L must be of INTEGER type", &e->where);
+ gfc_error ("Expression at %L must be of INTEGER type, found %s",
+ &e->where, gfc_basic_typename (e->ts.type));
+ 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 (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 ("different shape for %s at %L 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));
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);
/* 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;
+ /* Only DATA Statements come here. */
if (!conform)
{
/* Numeric can be converted to any other numeric. And Hollerith can be
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_typename (&lvalue->ts));
+ gfc_error ("Incompatible types in DATA statement at %L; attempted "
+ "conversion of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
return FAILURE;
}
+ /* Assignment is the only case where character variables of different
+ kind values can be converted into one another. */
+ if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
+ {
+ if (lvalue->ts.kind != rvalue->ts.kind)
+ gfc_convert_chartype (rvalue, &lvalue->ts);
+
+ return SUCCESS;
+ }
+
return gfc_convert_type (rvalue, &lvalue->ts, 1);
}
int is_pure;
int pointer, check_intent_in;
- if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+ if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("Pointer assignment target is not a POINTER at %L",
&lvalue->where);
/* 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;
+ pointer = lvalue->symtree->n.sym->attr.pointer
+ | lvalue->symtree->n.sym->attr.proc_pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
{
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);
return FAILURE;
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* TODO checks on rvalue for a procedure pointer assignment. */
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ 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 (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)
{
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer)
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
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 || c->allocatable) && 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)
{
}
-/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
+/* General expression traversal function. */
-void
-gfc_expr_set_symbols_referenced (gfc_expr *expr)
+bool
+gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
+ bool (*func)(gfc_expr *, gfc_symbol *, int*),
+ int f)
{
- gfc_actual_arglist *arg;
- gfc_constructor *c;
+ gfc_array_ref ar;
gfc_ref *ref;
+ gfc_actual_arglist *args;
+ gfc_constructor *c;
int i;
- if (!expr) return;
+ 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_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);
+ 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:
- gfc_set_sym_referenced (expr->symtree->n.sym);
- break;
-
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
case EXPR_STRUCTURE:
case EXPR_ARRAY:
for (c = expr->value.constructor; c; c = c->next)
- gfc_expr_set_symbols_referenced (c->expr);
+ {
+ 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:
break;
}
- for (ref = expr->ref; ref; ref = ref->next)
+ ref = expr->ref;
+ while (ref != NULL)
+ {
switch (ref->type)
{
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
+ case REF_ARRAY:
+ ar = ref->u.ar;
+ for (i = 0; i < GFC_MAX_DIMENSIONS; 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]);
+ 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_COMPONENT:
- break;
-
+
case REF_SUBSTRING:
- gfc_expr_set_symbols_referenced (ref->u.ss.start);
- gfc_expr_set_symbols_referenced (ref->u.ss.end);
+ 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 ();
- break;
}
+ 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);
}
OSDN Git Service
