/* 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, 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
{
gfc_expr *e;
- e = gfc_getmem (sizeof (gfc_expr));
+ e = XCNEW (gfc_expr);
gfc_clear_ts (&e->ts);
e->shape = NULL;
e->ref = NULL;
gfc_actual_arglist *
gfc_copy_actual_arglist (gfc_actual_arglist *p)
{
- gfc_actual_arglist *head, *tail, *new;
+ gfc_actual_arglist *head, *tail, *new_arg;
head = tail = NULL;
for (; p; p = p->next)
{
- new = gfc_get_actual_arglist ();
- *new = *p;
+ new_arg = gfc_get_actual_arglist ();
+ *new_arg = *p;
- new->expr = gfc_copy_expr (p->expr);
- new->next = NULL;
+ new_arg->expr = gfc_copy_expr (p->expr);
+ new_arg->next = NULL;
if (head == NULL)
- head = new;
+ head = new_arg;
else
- tail->next = new;
+ tail->next = new_arg;
- tail = new;
+ tail = new_arg;
}
return head;
break;
case BT_COMPLEX:
+#ifdef HAVE_mpc
+ mpc_clear (e->value.complex);
+#else
mpfr_clear (e->value.complex.r);
mpfr_clear (e->value.complex.i);
+#endif
break;
default:
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_free_actual_arglist (e->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gfc_free_actual_arglist (e->value.compcall.actual);
+ break;
+
case EXPR_VARIABLE:
break;
/* Recursively copy a list of reference structures. */
-static gfc_ref *
-copy_ref (gfc_ref *src)
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
break;
}
- dest->next = copy_ref (src->next);
+ dest->next = gfc_copy_ref (src->next);
return dest;
}
}
+/* Insert a reference to the component of the given name.
+ Only to be used with CLASS containers. */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+ gfc_ref **tail = &(e->ref);
+ gfc_ref *next = NULL;
+ gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+ while (*tail != NULL)
+ {
+ if ((*tail)->type == REF_COMPONENT)
+ derived = (*tail)->u.c.component->ts.u.derived;
+ if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+ break;
+ tail = &((*tail)->next);
+ }
+ if (*tail != NULL && strcmp (name, "$data") == 0)
+ next = *tail;
+ (*tail) = gfc_get_ref();
+ (*tail)->next = next;
+ (*tail)->type = REF_COMPONENT;
+ (*tail)->u.c.sym = derived;
+ (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+ gcc_assert((*tail)->u.c.component);
+ if (!next)
+ e->ts = (*tail)->u.c.component->ts;
+}
+
+
/* Copy a shape array. */
mpz_t *
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_COMPLEX:
gfc_set_model_kind (q->ts.kind);
+#ifdef HAVE_mpc
+ mpc_init2 (q->value.complex, mpfr_get_default_prec());
+ mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+#else
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);
+#endif
break;
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;
case BT_HOLLERITH:
case BT_LOGICAL:
case BT_DERIVED:
+ case BT_CLASS:
break; /* Already done. */
case BT_PROCEDURE:
break;
case EXPR_OP:
- switch (q->value.op.operator)
+ switch (q->value.op.op)
{
case INTRINSIC_NOT:
case INTRINSIC_PARENTHESES:
gfc_copy_actual_arglist (p->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ q->value.compcall.actual =
+ gfc_copy_actual_arglist (p->value.compcall.actual);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
case EXPR_STRUCTURE:
case EXPR_ARRAY:
q->value.constructor = gfc_copy_constructor (p->value.constructor);
q->shape = gfc_copy_shape (p->shape, p->rank);
- q->ref = copy_ref (p->ref);
+ q->ref = gfc_copy_ref (p->ref);
return q;
}
e->ts = op1->ts;
/* Special case for ** operator. */
- if (e->value.op.operator == INTRINSIC_POWER)
+ if (e->value.op.op == INTRINSIC_POWER)
goto done;
gfc_convert_type (e->value.op.op2, &e->ts, 2);
/* Try to collapse intrinsic expressions. */
-static try
+static gfc_try
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_intrinsic_op op;
gfc_expr *op1, *op2, *result;
- if (p->value.op.operator == INTRINSIC_USER)
+ if (p->value.op.op == INTRINSIC_USER)
return SUCCESS;
op1 = p->value.op.op1;
op2 = p->value.op.op2;
- op = p->value.op.operator;
+ op = p->value.op.op;
if (gfc_simplify_expr (op1, type) == FAILURE)
return FAILURE;
/* Subroutine to simplify constructor expressions. Mutually recursive
with gfc_simplify_expr(). */
-static try
+static gfc_try
simplify_constructor (gfc_constructor *c, int type)
{
gfc_expr *p;
/* Pull a single array element out of an array constructor. */
-static try
+static gfc_try
find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
gfc_constructor **rval)
{
mpz_t span;
mpz_t tmp;
gfc_expr *e;
- try t;
+ gfc_try t;
t = SUCCESS;
e = NULL;
mpz_init_set_ui (span, 1);
for (i = 0; i < ar->dimen; i++)
{
+ if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
+ || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
+ {
+ t = FAILURE;
+ cons = NULL;
+ goto depart;
+ }
+
e = gfc_copy_expr (ar->start[i]);
if (e->expr_type != EXPR_CONSTANT)
{
cons = NULL;
goto depart;
}
- /* Check the bounds. */
+
+ gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
+
+ /* 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))
+ && 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]);
mpz_mul (span, span, tmp);
}
- if (cons)
+ for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
{
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ if (cons)
{
if (cons->iterator)
{
/* Pull an array section out of an array constructor. */
-static try
+static gfc_try
find_array_section (gfc_expr *expr, gfc_ref *ref)
{
int idx;
gfc_expr *upper;
gfc_expr *lower;
gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
- try t;
+ gfc_try t;
t = SUCCESS;
}
gcc_assert (begin->rank == 1);
- gcc_assert (begin->shape);
+ /* Zero-sized arrays have no shape and no elements, stop early. */
+ if (!begin->shape)
+ {
+ mpz_init_set_ui (nelts, 0);
+ break;
+ }
vecsub[d] = begin->value.constructor;
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
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;
/* Pull a substring out of an expression. */
-static try
+static gfc_try
find_substring_ref (gfc_expr *p, gfc_expr **newp)
{
int end;
int start;
int length;
- char *chr;
+ gfc_char_t *chr;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
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);
+ 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);
+ memcpy (chr, &p->value.character.string[start - 1],
+ length * sizeof (gfc_char_t));
chr[length] = '\0';
return SUCCESS;
}
/* Simplify a subobject reference of a constructor. This occurs when
parameter variable values are substituted. */
-static try
+static gfc_try
simplify_const_ref (gfc_expr *p)
{
gfc_constructor *cons;
cons = p->value.constructor;
for (; cons; cons = cons->next)
{
- cons->expr->ref = copy_ref (p->ref->next);
- simplify_const_ref (cons->expr);
+ cons->expr->ref = gfc_copy_ref (p->ref->next);
+ if (simplify_const_ref (cons->expr) == FAILURE)
+ return FAILURE;
+ }
+
+ /* If this is a CHARACTER array and we possibly took a
+ substring out of it, update the type-spec's character
+ length according to the first element (as all should have
+ the same length). */
+ if (p->ts.type == BT_CHARACTER)
+ {
+ int string_len;
+
+ gcc_assert (p->ref->next);
+ gcc_assert (!p->ref->next->next);
+ gcc_assert (p->ref->next->type == REF_SUBSTRING);
+
+ if (p->value.constructor)
+ {
+ const gfc_expr* first = p->value.constructor->expr;
+ gcc_assert (first->expr_type == EXPR_CONSTANT);
+ gcc_assert (first->ts.type == BT_CHARACTER);
+ string_len = first->value.character.length;
+ }
+ else
+ string_len = 0;
+
+ if (!p->ts.u.cl)
+ p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+ NULL);
+ else
+ gfc_free_expr (p->ts.u.cl->length);
+
+ p->ts.u.cl->length = gfc_int_expr (string_len);
}
}
gfc_free_ref_list (p->ref);
/* Simplify a chain of references. */
-static try
+static gfc_try
simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
/* Try to substitute the value of a parameter variable. */
-static try
+static gfc_try
simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
- try t;
+ gfc_try t;
e = gfc_copy_expr (p->symtree->n.sym->value);
if (e == NULL)
/* Do not copy subobject refs for constant. */
if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
- e->ref = copy_ref (p->ref);
+ e->ref = gfc_copy_ref (p->ref);
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject references. */
Returns FAILURE on error, SUCCESS otherwise.
NOTE: Will return SUCCESS even if the expression can not be simplified. */
-try
+gfc_try
gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
if (gfc_is_constant_expr (p))
{
- char *s;
+ gfc_char_t *s;
int start, end;
+ start = 0;
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;
+ end = p->value.character.length;
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 = 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;
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);
+ p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
gfc_free_ref_list (p->ref);
p->ref = NULL;
p->expr_type = EXPR_CONSTANT;
return FAILURE;
break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gcc_unreachable ();
+ break;
}
return SUCCESS;
/* Check an intrinsic arithmetic operation to see if it is consistent
with some type of expression. */
-static try check_init_expr (gfc_expr *);
+static gfc_try check_init_expr (gfc_expr *);
/* Scalarize an expression for an elemental intrinsic call. */
-static try
+static gfc_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];
+ 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;
}
}
-static try
-check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
+static gfc_try
+check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
if ((*check_function) (op1) == FAILURE)
return FAILURE;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
goto not_numeric;
- if (e->value.op.operator == INTRINSIC_POWER
- && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
- {
- if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
- "exponent in an initialization "
- "expression at %L", &op2->where)
- == FAILURE)
- return FAILURE;
- }
-
break;
case INTRINSIC_CONCAT:
return MATCH_YES;
}
+static gfc_try check_restricted (gfc_expr *);
+
/* F95, 7.1.6.1, Initialization expressions, (7)
F2003, 7.1.7 Initialization expression, (8) */
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)
+ && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length variable '%s' in constant "
"expression at %L", e->symtree->n.sym->name, &e->where);
}
else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
return MATCH_ERROR;
+
+ if (not_restricted == 0
+ && ap->expr->expr_type != EXPR_VARIABLE
+ && check_restricted (ap->expr) == FAILURE)
+ return MATCH_ERROR;
}
return MATCH_YES;
"selected_real_kind", "transfer", "trim", NULL
};
+ static const char * const trans_func_f2003[] = {
+ "all", "any", "count", "dot_product", "matmul", "null", "pack",
+ "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+ "selected_real_kind", "spread", "sum", "transfer", "transpose",
+ "trim", "unpack", NULL
+ };
+
int i;
const char *name;
+ const char *const *functions;
if (!e->value.function.isym
|| !e->value.function.isym->transformational)
name = e->symtree->n.sym->name;
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
+ ? trans_func_f2003 : trans_func_f95;
+
/* 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;
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[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)
+ if (functions[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);
}
intrinsics in the context of initialization expressions. If
FAILURE is returned an error message has been generated. */
-static try
+static gfc_try
check_init_expr (gfc_expr *e)
{
match m;
- try t;
- gfc_intrinsic_sym *isym;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
if ((m = check_specification_function (e)) != MATCH_YES)
{
- if ((m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ gfc_intrinsic_sym* isym;
+ gfc_symbol* sym;
+
+ sym = e->symtree->n.sym;
+ if (!gfc_is_intrinsic (sym, 0, e->where)
+ || (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",
/* Try to scalarize an elemental intrinsic function that has an
array argument. */
- isym = gfc_find_function (e->symtree->n.sym->name);
+ 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)
return t;
}
+/* Reduces a general expression to an initialization expression (a constant).
+ This used to be part of gfc_match_init_expr.
+ Note that this function doesn't free the given expression on FAILURE. */
-/* Match an initialization expression. We work by first matching an
- expression, then reducing it to a constant. */
-
-match
-gfc_match_init_expr (gfc_expr **result)
+gfc_try
+gfc_reduce_init_expr (gfc_expr *expr)
{
- gfc_expr *expr;
- match m;
- try t;
-
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- return m;
+ gfc_try t;
gfc_init_expr = 1;
t = gfc_resolve_expr (expr);
gfc_init_expr = 0;
if (t == FAILURE)
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
+ return FAILURE;
if (expr->expr_type == EXPR_ARRAY
&& (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
- {
- gfc_free_expr (expr);
- return MATCH_ERROR;
- }
+ || gfc_expand_constructor (expr) == FAILURE))
+ return FAILURE;
/* Not all inquiry functions are simplified to constant expressions
so it is necessary to call check_inquiry again. */
&& !gfc_in_match_data ())
{
gfc_error ("Initialization expression didn't reduce %C");
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Match an initialization expression. We work by first matching an
+ expression, then reducing it to a constant. The reducing it to
+ constant part requires a global variable to flag the prohibition
+ of a non-integer exponent in -std=f95 mode. */
+
+bool init_flag = false;
+
+match
+gfc_match_init_expr (gfc_expr **result)
+{
+ gfc_expr *expr;
+ match m;
+ gfc_try t;
+
+ expr = NULL;
+
+ init_flag = true;
+
+ m = gfc_match_expr (&expr);
+ if (m != MATCH_YES)
+ {
+ init_flag = false;
+ return m;
+ }
+
+ t = gfc_reduce_init_expr (expr);
+ if (t != SUCCESS)
+ {
+ gfc_free_expr (expr);
+ init_flag = false;
return MATCH_ERROR;
}
*result = expr;
+ init_flag = false;
return MATCH_YES;
}
-static try check_restricted (gfc_expr *);
-
/* Given an actual argument list, test to see that each argument is a
restricted expression and optionally if the expression type is
integer or character. */
-static try
+static gfc_try
restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
/* Make sure a non-intrinsic function is a specification function. */
-static try
+static gfc_try
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
/* Check to see that a function reference to an intrinsic is a
restricted expression. */
-static try
+static gfc_try
restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
}
+/* Check the expressions of an actual arglist. Used by check_restricted. */
+
+static gfc_try
+check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
+{
+ for (; arg; arg = arg->next)
+ if (checker (arg->expr) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* Check the subscription expressions of a reference chain with a checking
+ function; used by check_restricted. */
+
+static gfc_try
+check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
+{
+ int dim;
+
+ if (!ref)
+ return SUCCESS;
+
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (dim = 0; dim != ref->u.ar.dimen; ++dim)
+ {
+ if (checker (ref->u.ar.start[dim]) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ar.end[dim]) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ar.stride[dim]) == FAILURE)
+ return FAILURE;
+ }
+ break;
+
+ case REF_COMPONENT:
+ /* Nothing needed, just proceed to next reference. */
+ break;
+
+ case REF_SUBSTRING:
+ if (checker (ref->u.ss.start) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ss.end) == FAILURE)
+ return FAILURE;
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ return check_references (ref->next, checker);
+}
+
+
/* Verify that an expression is a restricted expression. Like its
cousin check_init_expr(), an error message is generated if we
return FAILURE. */
-static try
+static gfc_try
check_restricted (gfc_expr *e)
{
- gfc_symbol *sym;
- try t;
+ gfc_symbol* sym;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
break;
case EXPR_FUNCTION:
- t = e->value.function.esym ? external_spec_function (e)
- : restricted_intrinsic (e);
+ if (e->value.function.esym)
+ {
+ t = check_arglist (e->value.function.actual, &check_restricted);
+ if (t == SUCCESS)
+ t = external_spec_function (e);
+ }
+ else
+ {
+ if (e->value.function.isym && e->value.function.isym->inquiry)
+ t = SUCCESS;
+ else
+ t = check_arglist (e->value.function.actual, &check_restricted);
+
+ if (t == SUCCESS)
+ t = restricted_intrinsic (e);
+ }
break;
case EXPR_VARIABLE:
break;
}
+ /* Check reference chain if any. */
+ if (check_references (e->ref, &check_restricted) == FAILURE)
+ 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)
- || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
+ if (e->error
+ || sym->attr.in_common
+ || sym->attr.use_assoc
+ || sym->attr.dummy
+ || sym->attr.implied_index
+ || sym->attr.flavor == FL_PARAMETER
+ || (sym->ns && sym->ns == gfc_current_ns->parent)
+ || (sym->ns && gfc_current_ns->parent
+ && sym->ns == gfc_current_ns->parent->parent)
+ || (sym->ns->proc_name != NULL
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
{
t = SUCCESS;
break;
gfc_error ("Variable '%s' cannot appear in the expression at %L",
sym->name, &e->where);
-
+ /* Prevent a repetition of the error. */
+ e->error = 1;
break;
case EXPR_NULL:
/* Check to see that an expression is a specification expression. If
we return FAILURE, an error has been generated. */
-try
+gfc_try
gfc_specification_expr (gfc_expr *e)
{
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;
}
/* 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_try
+gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
- try t;
+ gfc_try t;
+
+ va_list argp;
+ char buffer[240];
if (op1->rank == 0 || op2->rank == 0)
return SUCCESS;
+ va_start (argp, optype_msgid);
+ vsnprintf (buffer, 240, optype_msgid, argp);
+ va_end (argp);
+
if (op1->rank != op2->rank)
{
- gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
+ gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
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 and %d)", _(optype_msgid), &op1->where, d + 1,
+ "(%d and %d)", _(buffer), &op1->where, d + 1,
(int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
/* Given an assignable expression and an arbitrary expression, make
sure that the assignment can take place. */
-try
+gfc_try
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
has_pointer = sym->attr.pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
{
has_pointer = 1;
break;
if (rvalue->expr_type == EXPR_NULL)
{
- if (lvalue->symtree->n.sym->attr.pointer
+ if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return SUCCESS;
else
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
- && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
+ && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
return FAILURE;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
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);
}
we only check rvalue if it's not an assignment to NULL() or a
NULLIFY statement. */
-try
+gfc_try
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
gfc_ref *ref;
int is_pure;
- int pointer, check_intent_in;
+ int pointer, check_intent_in, proc_pointer;
- 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);
}
if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && lvalue->symtree->n.sym->attr.use_assoc)
+ && lvalue->symtree->n.sym->attr.use_assoc
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
sub-component of a pointer. */
check_intent_in = 1;
pointer = lvalue->symtree->n.sym->attr.pointer;
+ proc_pointer = lvalue->symtree->n.sym->attr.proc_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 (ref->type == REF_COMPONENT)
+ {
+ pointer = ref->u.c.component->attr.pointer;
+ proc_pointer = ref->u.c.component->attr.proc_pointer;
+ }
+
+ if (ref->type == REF_ARRAY && ref->next == NULL)
+ {
+ if (ref->u.ar.type == AR_FULL)
+ break;
+
+ if (ref->u.ar.type != AR_SECTION)
+ {
+ gfc_error ("Expected bounds specification for '%s' at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where);
+ return FAILURE;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
+ "specification for '%s' in pointer assignment "
+ "at %L", lvalue->symtree->n.sym->name,
+ &lvalue->where) == FAILURE)
+ return FAILURE;
+
+ gfc_error ("Pointer bounds remapping at %L is not yet implemented "
+ "in gfortran", &lvalue->where);
+ /* TODO: See PR 29785. Add checks that all lbounds are specified and
+ either never or always the upper-bound; strides shall not be
+ present. */
+ return FAILURE;
+ }
}
if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
return FAILURE;
}
- if (!pointer)
+ if (!pointer && !proc_pointer
+ && !(lvalue->ts.type == BT_CLASS
+ && lvalue->ts.u.derived->components->attr.pointer))
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* Checks on rvalue for procedure pointer assignments. */
+ if (proc_pointer)
+ {
+ char err[200];
+ gfc_symbol *s1,*s2;
+ gfc_component *comp;
+ const char *name;
+
+ attr = gfc_expr_attr (rvalue);
+ if (!((rvalue->expr_type == EXPR_NULL)
+ || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE
+ && attr.flavor == FL_PROCEDURE)))
+ {
+ gfc_error ("Invalid procedure pointer assignment at %L",
+ &rvalue->where);
+ return FAILURE;
+ }
+ if (attr.abstract)
+ {
+ gfc_error ("Abstract interface '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
+ }
+ /* Check for C727. */
+ if (attr.flavor == FL_PROCEDURE)
+ {
+ if (attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Statement function '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
+ }
+ if (attr.proc == PROC_INTERNAL &&
+ gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
+ "invalid in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where) == FAILURE)
+ return FAILURE;
+ }
+
+ /* Ensure that the calling convention is the same. As other attributes
+ such as DLLEXPORT may differ, one explicitly only tests for the
+ calling conventions. */
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && lvalue->symtree->n.sym->attr.ext_attr
+ != rvalue->symtree->n.sym->attr.ext_attr)
+ {
+ symbol_attribute calls;
+
+ calls.ext_attr = 0;
+ gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
+
+ if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
+ != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
+ {
+ gfc_error ("Mismatch in the procedure pointer assignment "
+ "at %L: mismatch in the calling convention",
+ &rvalue->where);
+ return FAILURE;
+ }
+ }
+
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
+ else
+ s1 = lvalue->symtree->n.sym;
+
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
+
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: %s", &rvalue->where, err);
+ return FAILURE;
+ }
+
+ 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;
}
- if (lvalue->ts.kind != rvalue->ts.kind)
+ if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
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)
+ if (lvalue->ts.type == BT_CHARACTER)
{
- gfc_error ("Different character lengths in pointer "
- "assignment at %L", &lvalue->where);
- return FAILURE;
+ gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+ if (t == FAILURE)
+ return FAILURE;
}
if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
return FAILURE;
}
- if (attr.protected && attr.use_assoc)
+ if (attr.is_protected && attr.use_assoc
+ && !(attr.pointer || attr.proc_pointer))
{
- gfc_error ("Pointer assigment target has PROTECTED "
+ gfc_error ("Pointer assignment target has PROTECTED "
"attribute at %L", &rvalue->where);
return FAILURE;
}
/* Relative of gfc_check_assign() except that the lvalue is a single
symbol. Used for initialization assignments. */
-try
+gfc_try
gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
gfc_expr lvalue;
- try r;
+ gfc_try r;
memset (&lvalue, '\0', sizeof (gfc_expr));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.pointer
+ && rvalue->expr_type == EXPR_NULL))
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
gfc_component *c;
/* See if we have a default initializer. */
- for (c = ts->derived->components; c; c = c->next)
- if (c->initializer || c->allocatable)
+ for (c = ts->u.derived->components; c; c = c->next)
+ if (c->initializer || c->attr.allocatable)
break;
if (!c)
init = gfc_get_expr ();
init->expr_type = EXPR_STRUCTURE;
init->ts = *ts;
- init->where = ts->derived->declared_at;
+ init->where = ts->u.derived->declared_at;
tail = NULL;
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
if (tail == NULL)
init->value.constructor = tail = gfc_get_constructor ();
if (c->initializer)
tail->expr = gfc_copy_expr (c->initializer);
- if (c->allocatable)
+ if (c->attr.allocatable)
{
tail->expr = gfc_get_expr ();
tail->expr->expr_type = EXPR_NULL;
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))
+ && expr->ts.u.cl
+ && expr->ts.u.cl->length
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
return true;
switch (expr->expr_type)
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
+ && ref->u.c.component->ts.u.cl
+ && ref->u.c.component->ts.u.cl->length
+ && ref->u.c.component->ts.u.cl->length->expr_type
!= EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
sym, func, f))
return true;
{
gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
}
+
+
+/* Determine if an expression is a procedure pointer component. If yes, the
+ argument 'comp' will point to the component (provided that 'comp' was
+ provided). */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+ gfc_ref *ref;
+ bool ppc = false;
+
+ if (!expr || !expr->ref)
+ return false;
+
+ ref = expr->ref;
+ while (ref->next)
+ ref = ref->next;
+
+ if (ref->type == REF_COMPONENT)
+ {
+ ppc = ref->u.c.component->attr.proc_pointer;
+ if (ppc && comp)
+ *comp = ref->u.c.component;
+ }
+
+ return ppc;
+}
+
+
+/* Walk an expression tree and check each variable encountered for being typed.
+ If strict is not set, a top-level variable is tolerated untyped in -std=gnu
+ mode as is a basic arithmetic expression using those; this is for things in
+ legacy-code like:
+
+ INTEGER :: arr(n), n
+ INTEGER :: arr(n + 1), n
+
+ The namespace is needed for IMPLICIT typing. */
+
+static gfc_namespace* check_typed_ns;
+
+static bool
+expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f ATTRIBUTE_UNUSED)
+{
+ gfc_try t;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
+ true, e->where);
+
+ return (t == FAILURE);
+}
+
+gfc_try
+gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
+{
+ bool error_found;
+
+ /* If this is a top-level variable or EXPR_OP, do the check with strict given
+ to us. */
+ if (!strict)
+ {
+ if (e->expr_type == EXPR_VARIABLE && !e->ref)
+ return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
+
+ if (e->expr_type == EXPR_OP)
+ {
+ gfc_try t = SUCCESS;
+
+ gcc_assert (e->value.op.op1);
+ t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
+
+ if (t == SUCCESS && e->value.op.op2)
+ t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
+
+ return t;
+ }
+ }
+
+ /* Otherwise, walk the expression and do it strictly. */
+ check_typed_ns = ns;
+ error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
+
+ return error_found ? FAILURE : SUCCESS;
+}
+
+/* Walk an expression tree and replace all symbols with a corresponding symbol
+ in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
+ statements. The boolean return value is required by gfc_traverse_expr. */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
+ {
+ gfc_symtree *stree;
+ gfc_namespace *ns = sym->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+ gfc_traverse_expr (expr, dest, &replace_symbol, 0);
+}
+
+/* The following is analogous to 'replace_symbol', and needed for copying
+ interfaces for procedure pointer components. The argument 'sym' must formally
+ be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+ However, it gets actually passed a gfc_component (i.e. the procedure pointer
+ component in whose formal_ns the arguments have to be). */
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ gfc_component *comp;
+ comp = (gfc_component *)sym;
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+ {
+ gfc_symtree *stree;
+ gfc_namespace *ns = comp->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
+{
+ gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
+}
+
OSDN Git Service
