/* Perform type resolution on the various structures.
- Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
sym->attr.ext_attr |= ifc->attr.ext_attr;
+ sym->attr.is_bind_c = ifc->attr.is_bind_c;
/* Copy array spec. */
sym->as = gfc_copy_array_spec (ifc->as);
if (sym->as)
continue;
}
+ if (proc->attr.implicit_pure && !gfc_pure(sym))
+ proc->attr.implicit_pure = 0;
+
if (gfc_elemental (proc))
{
gfc_error ("Dummy procedure at %L not allowed in ELEMENTAL "
&sym->declared_at);
}
+ if (proc->attr.implicit_pure && !sym->attr.pointer
+ && sym->attr.flavor != FL_PROCEDURE)
+ {
+ if (proc->attr.function && sym->attr.intent != INTENT_IN)
+ proc->attr.implicit_pure = 0;
+
+ if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN)
+ proc->attr.implicit_pure = 0;
+ }
+
if (gfc_elemental (proc))
{
/* F2008, C1289. */
!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (strcmp (comp->name, "$extends") == 0)
+ if (strcmp (comp->name, "_extends") == 0)
{
- /* Can afford to be brutal with the $extends initializer.
+ /* Can afford to be brutal with the _extends initializer.
The derived type can get lost because it is PRIVATE
but it is not usage constrained by the standard. */
cons->expr->ts = comp->ts;
comp->name, &cons->expr->where);
}
+ if (gfc_implicit_pure (NULL)
+ && cons->expr->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (cons->expr->symtree->n.sym)
+ || gfc_is_coindexed (cons->expr)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
}
return t;
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
- gfc_component *comp;
for (; arg; arg = arg->next)
{
continue;
}
- if (gfc_is_proc_ptr_comp (e, &comp))
- {
- e->ts = comp->ts;
- if (e->expr_type == EXPR_PPC)
- {
- if (comp->as != NULL)
- e->rank = comp->as->rank;
- e->expr_type = EXPR_FUNCTION;
- }
- if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
- goto argument_list;
- }
-
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.generic
&& no_formal_args
switch (ref->type)
{
case REF_SUBSTRING:
- if (ref->u.ss.length != NULL
- && ref->u.ss.length->length != NULL
- && ref->u.ss.start
- && ref->u.ss.start->expr_type == EXPR_CONSTANT
- && ref->u.ss.end
- && ref->u.ss.end->expr_type == EXPR_CONSTANT)
- {
- start = (int) mpz_get_si (ref->u.ss.start->value.integer);
- end = (int) mpz_get_si (ref->u.ss.end->value.integer);
- if (end - start + 1 != 1)
- retval = FAILURE;
- }
- else
- retval = FAILURE;
+ if (ref->u.ss.start == NULL || ref->u.ss.end == NULL
+ || gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) != 0)
+ retval = FAILURE;
break;
+
case REF_ARRAY:
if (ref->u.ar.type == AR_ELEMENT)
retval = SUCCESS;
{
/* We have constant lower and upper bounds. If the
difference between is 1, it can be considered a
- scalar. */
+ scalar.
+ FIXME: Use gfc_dep_compare_expr instead. */
start = (int) mpz_get_si
(ref->u.ar.as->lower[0]->value.integer);
end = (int) mpz_get_si
}
}
+ if (!pure_function (expr, &name) && name && gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
/* Functions without the RECURSIVE attribution are not allowed to
* call themselves. */
if (expr->value.function.esym && !expr->value.function.esym->attr.recursive)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
else
- sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
- e->value.op.uop->name, gfc_typename (&op1->ts),
- gfc_typename (&op2->ts));
+ {
+ sprintf (msg, _("Operands of user operator '%s' at %%L are %s/%s"),
+ e->value.op.uop->name, gfc_typename (&op1->ts),
+ gfc_typename (&op2->ts));
+ e->value.op.uop->op->sym->attr.referenced = 1;
+ }
goto bad_op;
{
gfc_ref *ref, *ref2 = NULL;
- if (e->ts.type == BT_CLASS)
- {
- gfc_error ("Polymorphic subobject of coindexed object at %L",
- &e->where);
- t = FAILURE;
- }
-
for (ref = e->ref; ref; ref = ref->next)
{
if (ref->type == REF_COMPONENT)
if (ref->type == REF_COMPONENT)
break;
+ /* Expression itself is not coindexed object. */
+ if (ref && e->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic subobject of coindexed object at %L",
+ &e->where);
+ t = FAILURE;
+ }
+
/* Expression itself is coindexed object. */
if (ref == NULL)
{
if (!po)
return FAILURE;
+ /* F08:R739. */
if (po->rank > 0)
{
gfc_error ("Passed-object at %L must be scalar", &e->where);
return FAILURE;
}
+ /* F08:C611. */
+ if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract)
+ {
+ gfc_error ("Base object for procedure-pointer component call at %L is of"
+ " ABSTRACT type '%s'", &e->where, po->ts.u.derived->name);
+ return FAILURE;
+ }
+
gcc_assert (tb->pass_arg_num > 0);
e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
tb->pass_arg_num,
check_typebound_baseobject (gfc_expr* e)
{
gfc_expr* base;
+ gfc_try return_value = FAILURE;
base = extract_compcall_passed_object (e);
if (!base)
gcc_assert (base->ts.type == BT_DERIVED || base->ts.type == BT_CLASS);
+ /* F08:C611. */
if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract)
{
gfc_error ("Base object for type-bound procedure call at %L is of"
" ABSTRACT type '%s'", &e->where, base->ts.u.derived->name);
- return FAILURE;
+ goto cleanup;
}
- /* If the procedure called is NOPASS, the base object must be scalar. */
+ /* F08:C1230. If the procedure called is NOPASS,
+ the base object must be scalar. */
if (e->value.compcall.tbp->nopass && base->rank > 0)
{
gfc_error ("Base object for NOPASS type-bound procedure call at %L must"
" be scalar", &e->where);
- return FAILURE;
+ goto cleanup;
}
- /* FIXME: Remove once PR 41177 (this problem) is fixed completely. */
+ /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */
if (base->rank > 0)
{
gfc_error ("Non-scalar base object at %L currently not implemented",
&e->where);
- return FAILURE;
+ goto cleanup;
}
- return SUCCESS;
+ return_value = SUCCESS;
+
+cleanup:
+ gfc_free_expr (base);
+ return return_value;
}
/* Deal with typebound operators for CLASS objects. */
expr = e->value.compcall.base_object;
- if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
- && e->value.compcall.name)
+ if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
- ts = expr->symtree->n.sym->ts;
+ ts = expr->ts;
declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
/* Use the generic name if it is there. */
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
- expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (e, "$vptr");
+ e->ref = gfc_copy_ref (expr->ref);
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
return SUCCESS;
return resolve_compcall (e, NULL);
}
- c = gfc_find_component (declared, "$data", true, true);
+ c = gfc_find_component (declared, "_data", true, true);
declared = c->ts.u.derived;
/* Treat the call as if it is a typebound procedure, in order to roll
if (new_ref)
e->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (e, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
/* Recover the typespec for the expression. This is really only
is present. */
ts = expr->symtree->n.sym->ts;
declared = ts.u.derived;
- c = gfc_find_component (declared, "$vptr", true, true);
+ c = gfc_find_component (declared, "_vptr", true, true);
if (c->ts.u.derived == NULL)
c->ts.u.derived = gfc_find_derived_vtab (declared);
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
expr->symtree->n.sym->ts.u.derived = declared;
- gfc_add_component_ref (code->expr1, "$vptr");
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
return SUCCESS;
if (new_ref)
code->expr1->ref = new_ref;
- /* '$vptr' points to the vtab, which contains the procedure pointers. */
- gfc_add_component_ref (code->expr1, "$vptr");
+ /* '_vptr' points to the vtab, which contains the procedure pointers. */
+ gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
/* Recover the typespec for the expression. This is really only
if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
return FAILURE;
- if (e->ts.type == BT_CLASS)
- {
- /* Only deallocate the DATA component. */
- gfc_add_component_ref (e, "$data");
- }
-
return SUCCESS;
}
}
success:
+ if (e->ts.deferred)
+ {
+ gfc_error ("Support for entity at %L with deferred type parameter "
+ "not yet implemented", &e->where);
+ return FAILURE;
+ }
return SUCCESS;
failure:
for (p = code->ext.alloc.list; p; p = p->next)
{
pe = p->expr;
- if ((pe->ref && pe->ref->type != REF_COMPONENT)
- && (pe->symtree->n.sym->ts.type != BT_DERIVED))
+ for (q = p->next; q; q = q->next)
{
- for (q = p->next; q; q = q->next)
+ qe = q->expr;
+ if (pe->symtree->n.sym->name == qe->symtree->n.sym->name)
{
- qe = q->expr;
- if ((qe->ref && qe->ref->type != REF_COMPONENT)
- && (qe->symtree->n.sym->ts.type != BT_DERIVED)
- && (pe->symtree->n.sym->name == qe->symtree->n.sym->name))
- gfc_error ("Allocate-object at %L also appears at %L",
- &pe->where, &qe->where);
+ /* This is a potential collision. */
+ gfc_ref *pr = pe->ref;
+ gfc_ref *qr = qe->ref;
+
+ /* Follow the references until
+ a) They start to differ, in which case there is no error;
+ you can deallocate a%b and a%c in a single statement
+ b) Both of them stop, which is an error
+ c) One of them stops, which is also an error. */
+ while (1)
+ {
+ if (pr == NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L also appears at %L",
+ &pe->where, &qe->where);
+ break;
+ }
+ else if (pr != NULL && qr == NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &pe->where, &qe->where);
+ break;
+ }
+ else if (pr == NULL && qr != NULL)
+ {
+ gfc_error ("Allocate-object at %L is subobject of"
+ " object at %L", &qe->where, &pe->where);
+ break;
+ }
+ /* Here, pr != NULL && qr != NULL */
+ gcc_assert(pr->type == qr->type);
+ if (pr->type == REF_ARRAY)
+ {
+ /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)),
+ which are legal. */
+ gcc_assert (qr->type == REF_ARRAY);
+
+ if (pr->next && qr->next)
+ {
+ gfc_array_ref *par = &(pr->u.ar);
+ gfc_array_ref *qar = &(qr->u.ar);
+ if (gfc_dep_compare_expr (par->start[0],
+ qar->start[0]) != 0)
+ break;
+ }
+ }
+ else
+ {
+ if (pr->u.c.component->name != qr->u.c.component->name)
+ break;
+ }
+
+ pr = pr->next;
+ qr = qr->next;
+ }
}
}
}
if (type == BT_INTEGER)
for (body = code->block; body; body = body->block)
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
if (cp->low
&& gfc_check_integer_range (cp->low->value.integer,
for (body = code->block; body; body = body->block)
{
/* Walk the case label list. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Intercept the DEFAULT case. It does not have a kind. */
if (cp->low == NULL && cp->high == NULL)
/* Walk the case label list, making sure that all case labels
are legal. */
- for (cp = body->ext.case_list; cp; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp; cp = cp->next)
{
/* Count the number of cases in the whole construct. */
ncases++;
if (seen_unreachable)
{
/* Advance until the first case in the list is reachable. */
- while (body->ext.case_list != NULL
- && body->ext.case_list->unreachable)
+ while (body->ext.block.case_list != NULL
+ && body->ext.block.case_list->unreachable)
{
- gfc_case *n = body->ext.case_list;
- body->ext.case_list = body->ext.case_list->next;
+ gfc_case *n = body->ext.block.case_list;
+ body->ext.block.case_list = body->ext.block.case_list->next;
n->next = NULL;
gfc_free_case_list (n);
}
/* Strip all other unreachable cases. */
- if (body->ext.case_list)
+ if (body->ext.block.case_list)
{
- for (cp = body->ext.case_list; cp->next; cp = cp->next)
+ for (cp = body->ext.block.case_list; cp->next; cp = cp->next)
{
if (cp->next->unreachable)
{
unreachable case labels for a block. */
for (body = code; body && body->block; body = body->block)
{
- if (body->block->ext.case_list == NULL)
+ if (body->block->ext.block.case_list == NULL)
{
/* Cut the unreachable block from the code chain. */
gfc_code *c = body->block;
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
/* Check F03:C815. */
if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
{
gfc_error ("The DEFAULT CASE at %L cannot be followed "
"by a second DEFAULT CASE at %L",
- &default_case->ext.case_list->where, &c->where);
+ &default_case->ext.block.case_list->where, &c->where);
error++;
continue;
}
ns->code->next = new_st;
code = new_st;
code->op = EXEC_SELECT;
- gfc_add_component_ref (code->expr1, "$vptr");
- gfc_add_component_ref (code->expr1, "$hash");
+ gfc_add_vptr_component (code->expr1);
+ gfc_add_hash_component (code->expr1);
/* Loop over TYPE IS / CLASS IS cases. */
for (body = code->block; body; body = body->block)
{
- c = body->ext.case_list;
+ c = body->ext.block.case_list;
if (c->ts.type == BT_DERIVED)
c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
'global' one). */
if (c->ts.type == BT_CLASS)
- sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
else
- sprintf (name, "tmp$type$%s", c->ts.u.derived->name);
+ sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree);
if (c->ts.type == BT_DERIVED)
- gfc_add_component_ref (st->n.sym->assoc->target, "$data");
+ gfc_add_data_component (st->n.sym->assoc->target);
new_st = gfc_get_code ();
new_st->op = EXEC_BLOCK;
body = code;
while (body && body->block)
{
- if (body->block->ext.case_list->ts.type == BT_CLASS)
+ if (body->block->ext.block.case_list->ts.type == BT_CLASS)
{
/* Add to class_is list. */
if (class_is == NULL)
tail->block = gfc_get_code ();
tail = tail->block;
tail->op = EXEC_SELECT_TYPE;
- tail->ext.case_list = gfc_get_case ();
- tail->ext.case_list->ts.type = BT_UNKNOWN;
+ tail->ext.block.case_list = gfc_get_case ();
+ tail->ext.block.case_list->ts.type = BT_UNKNOWN;
tail->next = NULL;
default_case = tail;
}
{
c2 = (*c1)->block;
/* F03:C817 (check for doubles). */
- if ((*c1)->ext.case_list->ts.u.derived->hash_value
- == c2->ext.case_list->ts.u.derived->hash_value)
+ if ((*c1)->ext.block.case_list->ts.u.derived->hash_value
+ == c2->ext.block.case_list->ts.u.derived->hash_value)
{
gfc_error ("Double CLASS IS block in SELECT TYPE "
- "statement at %L", &c2->ext.case_list->where);
+ "statement at %L",
+ &c2->ext.block.case_list->where);
return;
}
- if ((*c1)->ext.case_list->ts.u.derived->attr.extension
- < c2->ext.case_list->ts.u.derived->attr.extension)
+ if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension
+ < c2->ext.block.case_list->ts.u.derived->attr.extension)
{
/* Swap. */
(*c1)->block = c2->block;
/* Set up arguments. */
new_st->expr1->value.function.actual = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree);
- gfc_add_component_ref (new_st->expr1->value.function.actual->expr, "$vptr");
- vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived);
+ new_st->expr1->value.function.actual->expr->where = code->loc;
+ gfc_add_vptr_component (new_st->expr1->value.function.actual->expr);
+ vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived);
st = gfc_find_symtree (vtab->ns->sym_root, vtab->name);
new_st->expr1->value.function.actual->next = gfc_get_actual_arglist ();
new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st);
ts = &sym->ts;
/* Go to actual component transferred. */
- for (ref = code->expr1->ref; ref; ref = ref->next)
+ for (ref = exp->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
+ if (ts->type == BT_CLASS)
+ {
+ /* FIXME: Test for defined input/output. */
+ gfc_error ("Data transfer element at %L cannot be polymorphic unless "
+ "it is processed by a defined input/output procedure",
+ &code->loc);
+ return;
+ }
+
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
}
}
+ if (gfc_implicit_pure (NULL))
+ {
+ if (lhs->expr_type == EXPR_VARIABLE
+ && lhs->symtree->n.sym != gfc_current_ns->proc_name
+ && lhs->symtree->n.sym->ns != gfc_current_ns)
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ if (lhs->ts.type == BT_DERIVED
+ && lhs->expr_type == EXPR_VARIABLE
+ && lhs->ts.u.derived->attr.pointer_comp
+ && rhs->expr_type == EXPR_VARIABLE
+ && (gfc_impure_variable (rhs->symtree->n.sym)
+ || gfc_is_coindexed (rhs)))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ /* Fortran 2008, C1283. */
+ if (gfc_is_coindexed (lhs))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+ }
+
/* F03:7.4.1.2. */
/* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic
and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */
case EXEC_FORALL:
resolve_forall_iterators (code->ext.forall_iterator);
- if (code->expr1 != NULL && code->expr1->ts.type != BT_LOGICAL)
- gfc_error ("FORALL mask clause at %L requires a LOGICAL "
+ if (code->expr1 != NULL
+ && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank))
+ gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL "
"expression", &code->expr1->where);
break;
return SUCCESS;
}
+
/* Resolve a charlen structure. */
static gfc_try
build_init_assign (sym, init);
}
+
/* Resolution of common features of flavors variable and procedure. */
static gfc_try
return FAILURE;
}
+ /* Constraints on deferred type parameter. */
+ if (sym->ts.deferred && !(sym->attr.pointer || sym->attr.allocatable))
+ {
+ gfc_error ("Entity '%s' at %L has a deferred type parameter and "
+ "requires either the pointer or allocatable attribute",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
e = sym->ts.u.cl->length;
- if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+ if (e == NULL && !sym->attr.dummy && !sym->attr.result
+ && !sym->ts.deferred)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
for (dt_list = gfc_derived_types; dt_list; dt_list = dt_list->next)
if (derived == dt_list->derived)
- break;
+ return;
- if (dt_list == NULL)
- {
- dt_list = gfc_get_dt_list ();
- dt_list->next = gfc_derived_types;
- dt_list->derived = derived;
- gfc_derived_types = dt_list;
- }
+ dt_list = gfc_get_dt_list ();
+ dt_list->next = gfc_derived_types;
+ dt_list->derived = derived;
+ gfc_derived_types = dt_list;
}
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
- gfc_component *data = gfc_find_component (sym, "$data", true, true);
- gfc_component *vptr = gfc_find_component (sym, "$vptr", true, true);
+ gfc_component *data = gfc_find_component (sym, "_data", true, true);
+ gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true);
if (vptr->ts.u.derived == NULL)
{
gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived);
sym->name, &sym->declared_at) == FAILURE)
return FAILURE;
+ if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS)
+ {
+ gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) "
+ "type %s", c->name, &c->loc, sym->name);
+ return FAILURE;
+ }
+
if (sym->attr.sequence)
{
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
{
symtree = gfc_find_symtree (ns->sym_root, sym->name);
- if (symtree && symtree->n.sym->generic)
+ if (symtree && (symtree->n.sym->generic ||
+ (symtree->n.sym->attr.flavor == FL_PROCEDURE
+ && sym->ns->construct_entities)))
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
}
+/* Test whether a symbol is implicitly pure or not. For a NULL pointer,
+ checks if the current namespace is implicitly pure. Note that this
+ function returns false for a PURE procedure. */
+
+int
+gfc_implicit_pure (gfc_symbol *sym)
+{
+ symbol_attribute attr;
+
+ if (sym == NULL)
+ {
+ /* Check if the current namespace is implicit_pure. */
+ sym = gfc_current_ns->proc_name;
+ if (sym == NULL)
+ return 0;
+ attr = sym->attr;
+ if (attr.flavor == FL_PROCEDURE
+ && attr.implicit_pure && !attr.pure)
+ return 1;
+ return 0;
+ }
+
+ attr = sym->attr;
+
+ return attr.flavor == FL_PROCEDURE && attr.implicit_pure && !attr.pure;
+}
+
+
/* Test whether the current procedure is elemental or not. */
int
gfc_namespace *n;
bitmap_obstack old_obstack;
+ if (ns->resolved == 1)
+ return;
+
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);