return formal_arg_flag;
}
+
+/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is
+ an ABSTRACT derived-type. If where is not NULL, an error message with that
+ locus is printed, optionally using name. */
+
+static gfc_try
+resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name)
+{
+ if (ts->type == BT_DERIVED && ts->derived->attr.abstract)
+ {
+ if (where)
+ {
+ if (name)
+ gfc_error ("'%s' at %L is of the ABSTRACT type '%s'",
+ name, where, ts->derived->name);
+ else
+ gfc_error ("ABSTRACT type '%s' used at %L",
+ ts->derived->name, where);
+ }
+
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve types of formal argument lists. These have to be done early so that
the formal argument lists of module procedures can be copied to the
containing module before the individual procedures are resolved
for (c = der->components; c; c = c->next)
if ((c->ts.type != BT_DERIVED && c->initializer)
|| (c->ts.type == BT_DERIVED
- && (!c->pointer && has_default_initializer (c->ts.derived))))
+ && (!c->attr.pointer && has_default_initializer (c->ts.derived))))
break;
return c != NULL;
rank = comp->as ? comp->as->rank : 0;
if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank
- && (comp->allocatable || cons->expr->rank))
+ && (comp->attr.allocatable || cons->expr->rank))
{
gfc_error ("The rank of the element in the derived type "
"constructor at %L does not match that of the "
if (!gfc_compare_types (&cons->expr->ts, &comp->ts))
{
t = FAILURE;
- if (comp->pointer && cons->expr->ts.type != BT_UNKNOWN)
+ if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN)
gfc_error ("The element in the derived type constructor at %L, "
"for pointer component '%s', is %s but should be %s",
&cons->expr->where, comp->name,
}
if (cons->expr->expr_type == EXPR_NULL
- && !(comp->pointer || comp->allocatable))
+ && !(comp->attr.pointer || comp->attr.allocatable))
{
t = FAILURE;
gfc_error ("The NULL in the derived type constructor at %L is "
comp->name);
}
- if (!comp->pointer || cons->expr->expr_type == EXPR_NULL)
+ if (!comp->attr.pointer || cons->expr->expr_type == EXPR_NULL)
continue;
a = gfc_expr_attr (cons->expr);
if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE))
return false;
+ /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong.
+ What should it be? */
if ((e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL)
&& (e->ref->u.ar.as->type == AS_ASSUMED_SIZE)
- && (e->ref->u.ar.type == DIMEN_ELEMENT))
+ && (e->ref->u.ar.type == AR_FULL))
{
gfc_error ("The upper bound in the last dimension must "
"appear in the reference to the assumed size "
}
+/* Check a generic procedure, passed as an actual argument, to see if
+ there is a matching specific name. If none, it is an error, and if
+ more than one, the reference is ambiguous. */
+static int
+count_specific_procs (gfc_expr *e)
+{
+ int n;
+ gfc_interface *p;
+ gfc_symbol *sym;
+
+ n = 0;
+ sym = e->symtree->n.sym;
+
+ for (p = sym->generic; p; p = p->next)
+ if (strcmp (sym->name, p->sym->name) == 0)
+ {
+ e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
+ sym->name);
+ n++;
+ }
+
+ if (n > 1)
+ gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+ &e->where);
+
+ if (n == 0)
+ gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
+ "argument at %L", sym->name, &e->where);
+
+ return n;
+}
+
/* Resolve an actual argument list. Most of the time, this is just
resolving the expressions in the list.
The exception is that we sometimes have to decide whether arguments
references. */
static gfc_try
-resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
+resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
+ bool no_formal_args)
{
gfc_symbol *sym;
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
-
+
for (; arg; arg = arg->next)
{
e = arg->expr;
continue;
}
- if (e->expr_type == FL_VARIABLE && e->symtree->ambiguous)
- {
- gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
- &e->where);
- return FAILURE;
- }
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.generic
+ && no_formal_args
+ && count_specific_procs (e) != 1)
+ return FAILURE;
if (e->ts.type != BT_PROCEDURE)
{
save_need_full_assumed_size = need_full_assumed_size;
- if (e->expr_type != FL_VARIABLE)
+ if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
- if (sym->attr.generic)
- {
- gfc_interface *p;
- for (p = sym->generic; p; p = p->next)
- if (strcmp (sym->name, p->sym->name) == 0)
- {
- e->symtree = gfc_find_symtree
- (p->sym->ns->sym_root, sym->name);
- sym = p->sym;
- break;
- }
+ if (sym->attr.generic && count_specific_procs (e) != 1)
+ return FAILURE;
+
+ /* Just in case a specific was found for the expression. */
+ sym = e->symtree->n.sym;
- if (p == NULL || e->symtree == NULL)
- gfc_error ("GENERIC procedure '%s' is not "
- "allowed as an actual argument at %L", sym->name,
- &e->where);
+ if (sym->attr.entry && sym->ns->entries
+ && sym->ns == gfc_current_ns
+ && !sym->ns->entries->sym->attr.recursive)
+ {
+ gfc_error ("Reference to ENTRY '%s' at %L is recursive, but procedure "
+ "'%s' is not declared as RECURSIVE",
+ sym->name, &e->where, sym->ns->entries->sym->name);
}
/* If the symbol is the function that names the current (or
is a variable instead, it needs to be resolved as it was not
done at the beginning of this function. */
save_need_full_assumed_size = need_full_assumed_size;
- if (e->expr_type != FL_VARIABLE)
+ if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
return FAILURE;
else
return SUCCESS;
}
- else if (c && c->ext.actual != NULL && c->symtree->n.sym->attr.elemental)
+ else if (c && c->ext.actual != NULL)
{
arg0 = c->ext.actual;
- esym = c->symtree->n.sym;
+
+ if (c->resolved_sym)
+ esym = c->resolved_sym;
+ else
+ esym = c->symtree->n.sym;
+ gcc_assert (esym);
+
+ if (!esym->attr.elemental)
+ return SUCCESS;
}
else
return SUCCESS;
if (!(args_sym->attr.target)
&& !(args_sym->attr.pointer)
&& (parent_ref == NULL ||
- !parent_ref->u.c.component->pointer))
+ !parent_ref->u.c.component->attr.pointer))
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be either "
"a TARGET or an associated pointer",
}
else if ((args_sym->attr.pointer == 1 ||
(parent_ref != NULL
- && parent_ref->u.c.component->pointer))
+ && parent_ref->u.c.component->attr.pointer))
&& is_scalar_expr_ptr (args->expr) != SUCCESS)
{
/* Case 1c, section 15.1.2.5, J3/04-007: an associated
gfc_try t;
int temp;
procedure_type p = PROC_INTRINSIC;
+ bool no_formal_args;
sym = NULL;
if (expr->symtree)
sym = expr->symtree->n.sym;
+ if (sym && sym->attr.intrinsic
+ && !gfc_find_function (sym->name)
+ && gfc_find_subroutine (sym->name)
+ && sym->attr.function)
+ {
+ gfc_error ("Intrinsic subroutine '%s' used as "
+ "a function at %L", sym->name, &expr->where);
+ return FAILURE;
+ }
+
if (sym && sym->attr.flavor == FL_VARIABLE)
{
gfc_error ("'%s' at %L is not a function", sym->name, &expr->where);
if (expr->symtree && expr->symtree->n.sym)
p = expr->symtree->n.sym->attr.proc;
- if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
+ no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+ if (resolve_actual_arglist (expr->value.function.actual,
+ p, no_formal_args) == FAILURE)
return FAILURE;
/* Need to setup the call to the correct c_associated, depending on
assumed size array argument. UBOUND and SIZE have to be
excluded from the check if the second argument is anything
than a constant. */
- int inquiry;
- inquiry = GENERIC_ID == GFC_ISYM_UBOUND
- || GENERIC_ID == GFC_ISYM_SIZE;
for (arg = expr->value.function.actual; arg; arg = arg->next)
{
- if (inquiry && arg->next != NULL && arg->next->expr)
+ if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE)
+ && arg->next != NULL && arg->next->expr)
{
if (arg->next->expr->expr_type != EXPR_CONSTANT)
break;
+ if (arg->next->name && strncmp(arg->next->name, "kind", 4) == 0)
+ break;
+
if ((int)mpz_get_si (arg->next->expr->value.integer)
< arg->expr->rank)
break;
{
gfc_try t;
procedure_type ptype = PROC_INTRINSIC;
+ gfc_symbol *csym, *sym;
+ bool no_formal_args;
+
+ csym = c->symtree ? c->symtree->n.sym : NULL;
- if (c->symtree && c->symtree->n.sym
- && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ if (csym && csym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
- "the CALL at %L", c->symtree->n.sym->name,
- &c->symtree->n.sym->declared_at, &c->loc);
+ "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
return FAILURE;
}
+ if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns)
+ {
+ gfc_find_symbol (csym->name, gfc_current_ns, 1, &sym);
+ if (sym && csym != sym
+ && sym->ns == gfc_current_ns
+ && sym->attr.flavor == FL_PROCEDURE
+ && sym->attr.contained)
+ {
+ sym->refs++;
+ csym = sym;
+ c->symtree->n.sym = sym;
+ }
+ }
+
/* If external, check for usage. */
- if (c->symtree && is_external_proc (c->symtree->n.sym))
- resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+ if (csym && is_external_proc (csym))
+ resolve_global_procedure (csym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
- if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
+ if (csym && !csym->attr.recursive)
{
- gfc_symbol *csym, *proc;
- csym = c->symtree->n.sym;
+ gfc_symbol *proc;
proc = gfc_current_ns->proc_name;
if (csym == proc)
{
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
- if (c->symtree && c->symtree->n.sym)
- ptype = c->symtree->n.sym->attr.proc;
+ if (csym)
+ ptype = csym->attr.proc;
- if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
+ no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
+ if (resolve_actual_arglist (c->ext.actual, ptype,
+ no_formal_args) == FAILURE)
return FAILURE;
/* Resume assumed_size checking. */
t = SUCCESS;
if (c->resolved_sym == NULL)
- switch (procedure_kind (c->symtree->n.sym))
- {
- case PTYPE_GENERIC:
- t = resolve_generic_s (c);
- break;
+ {
+ c->resolved_isym = NULL;
+ switch (procedure_kind (csym))
+ {
+ case PTYPE_GENERIC:
+ t = resolve_generic_s (c);
+ break;
- case PTYPE_SPECIFIC:
- t = resolve_specific_s (c);
- break;
+ case PTYPE_SPECIFIC:
+ t = resolve_specific_s (c);
+ break;
- case PTYPE_UNKNOWN:
- t = resolve_unknown_s (c);
- break;
+ case PTYPE_UNKNOWN:
+ t = resolve_unknown_s (c);
+ break;
- default:
- gfc_internal_error ("resolve_subroutine(): bad function type");
- }
+ default:
+ gfc_internal_error ("resolve_subroutine(): bad function type");
+ }
+ }
/* Some checks of elemental subroutine actual arguments. */
if (resolve_elemental_actual (NULL, c) == FAILURE)
if (c == NULL)
gfc_internal_error ("find_array_spec(): Component not found");
- if (c->dimension)
+ if (c->attr.dimension)
{
if (as != NULL)
gfc_internal_error ("find_array_spec(): unused as(1)");
case REF_COMPONENT:
if (current_part_dimension || seen_part_dimension)
{
- if (ref->u.c.component->pointer)
+ if (ref->u.c.component->attr.pointer)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the POINTER "
"attribute at %L", &expr->where);
return FAILURE;
}
- else if (ref->u.c.component->allocatable)
+ else if (ref->u.c.component->attr.allocatable)
{
gfc_error ("Component to the right of a part reference "
"with nonzero rank must not have the ALLOCATABLE "
gfc_ref *ref;
int i, rank;
+ /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that
+ could lead to serious confusion... */
+ gcc_assert (e->expr_type != EXPR_COMPCALL);
+
if (e->ref == NULL)
{
if (e->expr_type == EXPR_ARRAY)
old_sym = e->symtree->n.sym;
- if (old_sym->attr.use_assoc)
- return retval;
-
if (gfc_current_ns->parent
&& old_sym->ns != gfc_current_ns)
{
gfc_find_symbol (old_sym->name, gfc_current_ns, 1, &sym);
if (sym && old_sym != sym
+ && sym->ts.type == old_sym->ts.type
&& sym->attr.flavor == FL_PROCEDURE
&& sym->attr.contained)
{
}
+/* Update an actual argument to include the passed-object for type-bound
+ procedures at the right position. */
+
+static gfc_actual_arglist*
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
+{
+ gcc_assert (argpos > 0);
+
+ if (argpos == 1)
+ {
+ gfc_actual_arglist* result;
+
+ result = gfc_get_actual_arglist ();
+ result->expr = po;
+ result->next = lst;
+
+ return result;
+ }
+
+ gcc_assert (lst);
+ gcc_assert (argpos > 1);
+
+ lst->next = update_arglist_pass (lst->next, po, argpos - 1);
+ return lst;
+}
+
+
+/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */
+
+static gfc_expr*
+extract_compcall_passed_object (gfc_expr* e)
+{
+ gfc_expr* po;
+
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+ po = gfc_get_expr ();
+ po->expr_type = EXPR_VARIABLE;
+ po->symtree = e->symtree;
+ po->ref = gfc_copy_ref (e->ref);
+
+ if (gfc_resolve_expr (po) == FAILURE)
+ return NULL;
+
+ return po;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+ passed-object. */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+ gfc_expr* po;
+ gfc_typebound_proc* tbp;
+
+ tbp = e->value.compcall.tbp;
+
+ if (tbp->error)
+ return FAILURE;
+
+ po = extract_compcall_passed_object (e);
+ if (!po)
+ return FAILURE;
+
+ if (po->rank > 0)
+ {
+ gfc_error ("Passed-object at %L must be scalar", &e->where);
+ return FAILURE;
+ }
+
+ if (tbp->nopass)
+ {
+ gfc_free_expr (po);
+ return SUCCESS;
+ }
+
+ gcc_assert (tbp->pass_arg_num > 0);
+ e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+ tbp->pass_arg_num);
+
+ return SUCCESS;
+}
+
+
+/* Resolve a call to a type-bound procedure, either function or subroutine,
+ statically from the data in an EXPR_COMPCALL expression. The adapted
+ arglist and the target-procedure symtree are returned. */
+
+static gfc_try
+resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
+ gfc_actual_arglist** actual)
+{
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+ gcc_assert (!e->value.compcall.tbp->is_generic);
+
+ /* Update the actual arglist for PASS. */
+ if (update_compcall_arglist (e) == FAILURE)
+ return FAILURE;
+
+ *actual = e->value.compcall.actual;
+ *target = e->value.compcall.tbp->u.specific;
+
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ e->value.compcall.actual = NULL;
+
+ return SUCCESS;
+}
+
+
+/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
+ which of the specific bindings (if any) matches the arglist and transform
+ the expression into a call of that binding. */
+
+static gfc_try
+resolve_typebound_generic_call (gfc_expr* e)
+{
+ gfc_typebound_proc* genproc;
+ const char* genname;
+
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+ genname = e->value.compcall.name;
+ genproc = e->value.compcall.tbp;
+
+ if (!genproc->is_generic)
+ return SUCCESS;
+
+ /* Try the bindings on this type and in the inheritance hierarchy. */
+ for (; genproc; genproc = genproc->overridden)
+ {
+ gfc_tbp_generic* g;
+
+ gcc_assert (genproc->is_generic);
+ for (g = genproc->u.generic; g; g = g->next)
+ {
+ gfc_symbol* target;
+ gfc_actual_arglist* args;
+ bool matches;
+
+ gcc_assert (g->specific);
+
+ if (g->specific->error)
+ continue;
+
+ target = g->specific->u.specific->n.sym;
+
+ /* Get the right arglist by handling PASS/NOPASS. */
+ args = gfc_copy_actual_arglist (e->value.compcall.actual);
+ if (!g->specific->nopass)
+ {
+ gfc_expr* po;
+ po = extract_compcall_passed_object (e);
+ if (!po)
+ return FAILURE;
+
+ gcc_assert (g->specific->pass_arg_num > 0);
+ gcc_assert (!g->specific->error);
+ args = update_arglist_pass (args, po, g->specific->pass_arg_num);
+ }
+ resolve_actual_arglist (args, target->attr.proc,
+ is_external_proc (target) && !target->formal);
+
+ /* Check if this arglist matches the formal. */
+ matches = gfc_arglist_matches_symbol (&args, target);
+
+ /* Clean up and break out of the loop if we've found it. */
+ gfc_free_actual_arglist (args);
+ if (matches)
+ {
+ e->value.compcall.tbp = g->specific;
+ goto success;
+ }
+ }
+ }
+
+ /* Nothing matching found! */
+ gfc_error ("Found no matching specific binding for the call to the GENERIC"
+ " '%s' at %L", genname, &e->where);
+ return FAILURE;
+
+success:
+ return SUCCESS;
+}
+
+
+/* Resolve a call to a type-bound subroutine. */
+
+static gfc_try
+resolve_typebound_call (gfc_code* c)
+{
+ gfc_actual_arglist* newactual;
+ gfc_symtree* target;
+
+ /* Check that's really a SUBROUTINE. */
+ if (!c->expr->value.compcall.tbp->subroutine)
+ {
+ gfc_error ("'%s' at %L should be a SUBROUTINE",
+ c->expr->value.compcall.name, &c->loc);
+ return FAILURE;
+ }
+
+ if (resolve_typebound_generic_call (c->expr) == FAILURE)
+ return FAILURE;
+
+ /* Transform into an ordinary EXEC_CALL for now. */
+
+ if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
+ return FAILURE;
+
+ c->ext.actual = newactual;
+ c->symtree = target;
+ c->op = EXEC_CALL;
+
+ gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
+ gfc_free_expr (c->expr);
+ c->expr = NULL;
+
+ return resolve_call (c);
+}
+
+
+/* Resolve a component-call expression. */
+
+static gfc_try
+resolve_compcall (gfc_expr* e)
+{
+ gfc_actual_arglist* newactual;
+ gfc_symtree* target;
+
+ /* Check that's really a FUNCTION. */
+ if (!e->value.compcall.tbp->function)
+ {
+ gfc_error ("'%s' at %L should be a FUNCTION",
+ e->value.compcall.name, &e->where);
+ return FAILURE;
+ }
+
+ if (resolve_typebound_generic_call (e) == FAILURE)
+ return FAILURE;
+ gcc_assert (!e->value.compcall.tbp->is_generic);
+
+ /* Take the rank from the function's symbol. */
+ if (e->value.compcall.tbp->u.specific->n.sym->as)
+ e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank;
+
+ /* For now, we simply transform it into an EXPR_FUNCTION call with the same
+ arglist to the TBP's binding target. */
+
+ if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
+ return FAILURE;
+
+ e->value.function.actual = newactual;
+ e->value.function.name = e->value.compcall.name;
+ e->value.function.isym = NULL;
+ e->value.function.esym = NULL;
+ e->symtree = target;
+ e->ts = target->n.sym->ts;
+ e->expr_type = EXPR_FUNCTION;
+
+ return gfc_resolve_expr (e);
+}
+
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
break;
+ case EXPR_COMPCALL:
+ t = resolve_compcall (e);
+ break;
+
case EXPR_SUBSTRING:
t = resolve_ref (e);
break;
case REF_COMPONENT:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
+ pointer = ref->u.c.component->attr.pointer;
break;
case REF_SUBSTRING:
allocatable = (ref->u.c.component->as != NULL
&& ref->u.c.component->as->type == AS_DEFERRED);
- pointer = ref->u.c.component->pointer;
- dimension = ref->u.c.component->dimension;
+ pointer = ref->u.c.component->attr.pointer;
+ dimension = ref->u.c.component->attr.dimension;
break;
case REF_SUBSTRING:
pointer = 0;
break;
}
- }
+ }
}
if (allocatable == 0 && pointer == 0)
else
{
/* If one of the FORALL index variables doesn't appear in the
- assignment target, then there will be a many-to-one
- assignment. */
+ assignment variable, then there could be a many-to-one
+ assignment. Emit a warning rather than an error because the
+ mask could be resolving this problem. */
if (find_forall_index (code->expr, forall_index, 0) == FAILURE)
- gfc_error ("The FORALL with index '%s' cause more than one "
- "assignment to this object at %L",
- var_expr[n]->symtree->name, &code->expr->where);
+ gfc_warning ("The FORALL with index '%s' is not used on the "
+ "left side of the assignment at %L and so might "
+ "cause multiple assignment to this object",
+ var_expr[n]->symtree->name, &code->expr->where);
}
}
}
}
+/* Counts the number of iterators needed inside a forall construct, including
+ nested forall constructs. This is used to allocate the needed memory
+ in gfc_resolve_forall. */
+
+static int
+gfc_count_forall_iterators (gfc_code *code)
+{
+ int max_iters, sub_iters, current_iters;
+ gfc_forall_iterator *fa;
+
+ gcc_assert(code->op == EXEC_FORALL);
+ max_iters = 0;
+ current_iters = 0;
+
+ for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+ current_iters ++;
+
+ code = code->block->next;
+
+ while (code)
+ {
+ if (code->op == EXEC_FORALL)
+ {
+ sub_iters = gfc_count_forall_iterators (code);
+ if (sub_iters > max_iters)
+ max_iters = sub_iters;
+ }
+ code = code->next;
+ }
+
+ return current_iters + max_iters;
+}
+
+
/* Given a FORALL construct, first resolve the FORALL iterator, then call
gfc_resolve_forall_body to resolve the FORALL body. */
static gfc_expr **var_expr;
static int total_var = 0;
static int nvar = 0;
+ int old_nvar, tmp;
gfc_forall_iterator *fa;
- gfc_code *next;
int i;
+ old_nvar = nvar;
+
/* Start to resolve a FORALL construct */
if (forall_save == 0)
{
/* Count the total number of FORALL index in the nested FORALL
- construct in order to allocate the VAR_EXPR with proper size. */
- next = code;
- while ((next != NULL) && (next->op == EXEC_FORALL))
- {
- for (fa = next->ext.forall_iterator; fa; fa = fa->next)
- total_var ++;
- next = next->block->next;
- }
+ construct in order to allocate the VAR_EXPR with proper size. */
+ total_var = gfc_count_forall_iterators (code);
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
var_expr = (gfc_expr **) gfc_getmem (total_var * sizeof (gfc_expr *));
var_expr[nvar] = gfc_copy_expr (fa->var);
nvar++;
+
+ /* No memory leak. */
+ gcc_assert (nvar <= total_var);
}
/* Resolve the FORALL body. */
/* May call gfc_resolve_forall to resolve the inner FORALL loop. */
gfc_resolve_blocks (code->block, ns);
- /* Free VAR_EXPR after the whole FORALL construct resolved. */
- for (i = 0; i < total_var; i++)
- gfc_free_expr (var_expr[i]);
+ tmp = nvar;
+ nvar = old_nvar;
+ /* Free only the VAR_EXPRs allocated in this frame. */
+ for (i = nvar; i < tmp; i++)
+ gfc_free_expr (var_expr[i]);
+
+ if (nvar == 0)
+ {
+ /* We are in the outermost FORALL construct. */
+ gcc_assert (forall_save == 0);
- /* Reset the counters. */
- total_var = 0;
- nvar = 0;
+ /* VAR_EXPR is not needed any more. */
+ gfc_free (var_expr);
+ total_var = 0;
+ }
}
omp_workshare_flag = omp_workshare_save;
}
- t = gfc_resolve_expr (code->expr);
+ t = SUCCESS;
+ if (code->op != EXEC_COMPCALL)
+ t = gfc_resolve_expr (code->expr);
forall_flag = forall_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
resolve_call (code);
break;
+ case EXEC_COMPCALL:
+ resolve_typebound_call (code);
+ break;
+
case EXEC_SELECT:
/* Select is complicated. Also, a SELECT construct could be
a transformed computed GOTO. */
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.derived->name, sym->ns, 0, &s);
- if (s && (s->attr.flavor != FL_DERIVED
- || !gfc_compare_derived_types (s, sym->ts.derived)))
+ if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
"because it is blocked by an incompatible object "
}
}
+ /* Ensure that any initializer is simplified. */
+ if (sym->value)
+ gfc_simplify_expr (sym->value, 1);
+
/* Reject illegal initializers. */
if (!sym->mark && sym->value)
{
}
+/* Check that it is ok for the typebound procedure proc to override the
+ procedure old. */
+
+static gfc_try
+check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
+{
+ locus where;
+ const gfc_symbol* proc_target;
+ const gfc_symbol* old_target;
+ unsigned proc_pass_arg, old_pass_arg, argpos;
+ gfc_formal_arglist* proc_formal;
+ gfc_formal_arglist* old_formal;
+
+ /* This procedure should only be called for non-GENERIC proc. */
+ gcc_assert (!proc->typebound->is_generic);
+
+ /* If the overwritten procedure is GENERIC, this is an error. */
+ if (old->typebound->is_generic)
+ {
+ gfc_error ("Can't overwrite GENERIC '%s' at %L",
+ old->name, &proc->typebound->where);
+ return FAILURE;
+ }
+
+ where = proc->typebound->where;
+ proc_target = proc->typebound->u.specific->n.sym;
+ old_target = old->typebound->u.specific->n.sym;
+
+ /* Check that overridden binding is not NON_OVERRIDABLE. */
+ if (old->typebound->non_overridable)
+ {
+ gfc_error ("'%s' at %L overrides a procedure binding declared"
+ " NON_OVERRIDABLE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is PURE, the overriding must be, too. */
+ if (old_target->attr.pure && !proc_target->attr.pure)
+ {
+ gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+ proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it
+ is not, the overriding must not be either. */
+ if (old_target->attr.elemental && !proc_target->attr.elemental)
+ {
+ gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+ " ELEMENTAL", proc->name, &where);
+ return FAILURE;
+ }
+ if (!old_target->attr.elemental && proc_target->attr.elemental)
+ {
+ gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+ " be ELEMENTAL, either", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is a SUBROUTINE, the overriding must also be a
+ SUBROUTINE. */
+ if (old_target->attr.subroutine && !proc_target->attr.subroutine)
+ {
+ gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+ " SUBROUTINE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is a FUNCTION, the overriding must also be a
+ FUNCTION and have the same characteristics. */
+ if (old_target->attr.function)
+ {
+ if (!proc_target->attr.function)
+ {
+ gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+ " FUNCTION", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* FIXME: Do more comprehensive checking (including, for instance, the
+ rank and array-shape). */
+ gcc_assert (proc_target->result && old_target->result);
+ if (!gfc_compare_types (&proc_target->result->ts,
+ &old_target->result->ts))
+ {
+ gfc_error ("'%s' at %L and the overridden FUNCTION should have"
+ " matching result types", proc->name, &where);
+ return FAILURE;
+ }
+ }
+
+ /* If the overridden binding is PUBLIC, the overriding one must not be
+ PRIVATE. */
+ if (old->typebound->access == ACCESS_PUBLIC
+ && proc->typebound->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+ " PRIVATE", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* Compare the formal argument lists of both procedures. This is also abused
+ to find the position of the passed-object dummy arguments of both
+ bindings as at least the overridden one might not yet be resolved and we
+ need those positions in the check below. */
+ proc_pass_arg = old_pass_arg = 0;
+ if (!proc->typebound->nopass && !proc->typebound->pass_arg)
+ proc_pass_arg = 1;
+ if (!old->typebound->nopass && !old->typebound->pass_arg)
+ old_pass_arg = 1;
+ argpos = 1;
+ for (proc_formal = proc_target->formal, old_formal = old_target->formal;
+ proc_formal && old_formal;
+ proc_formal = proc_formal->next, old_formal = old_formal->next)
+ {
+ if (proc->typebound->pass_arg
+ && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name))
+ proc_pass_arg = argpos;
+ if (old->typebound->pass_arg
+ && !strcmp (old->typebound->pass_arg, old_formal->sym->name))
+ old_pass_arg = argpos;
+
+ /* Check that the names correspond. */
+ if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+ {
+ gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+ " to match the corresponding argument of the overridden"
+ " procedure", proc_formal->sym->name, proc->name, &where,
+ old_formal->sym->name);
+ return FAILURE;
+ }
+
+ /* Check that the types correspond if neither is the passed-object
+ argument. */
+ /* FIXME: Do more comprehensive testing here. */
+ if (proc_pass_arg != argpos && old_pass_arg != argpos
+ && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+ {
+ gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in"
+ " in respect to the overridden procedure",
+ proc_formal->sym->name, proc->name, &where);
+ return FAILURE;
+ }
+
+ ++argpos;
+ }
+ if (proc_formal || old_formal)
+ {
+ gfc_error ("'%s' at %L must have the same number of formal arguments as"
+ " the overridden procedure", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is NOPASS, the overriding one must also be
+ NOPASS. */
+ if (old->typebound->nopass && !proc->typebound->nopass)
+ {
+ gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+ " NOPASS", proc->name, &where);
+ return FAILURE;
+ }
+
+ /* If the overridden binding is PASS(x), the overriding one must also be
+ PASS and the passed-object dummy arguments must correspond. */
+ if (!old->typebound->nopass)
+ {
+ if (proc->typebound->nopass)
+ {
+ gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+ " PASS", proc->name, &where);
+ return FAILURE;
+ }
+
+ if (proc_pass_arg != old_pass_arg)
+ {
+ gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+ " the same position as the passed-object dummy argument of"
+ " the overridden procedure", proc->name, &where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+
+/* Check if two GENERIC targets are ambiguous and emit an error is they are. */
+
+static gfc_try
+check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
+ const char* generic_name, locus where)
+{
+ gfc_symbol* sym1;
+ gfc_symbol* sym2;
+
+ gcc_assert (t1->specific && t2->specific);
+ gcc_assert (!t1->specific->is_generic);
+ gcc_assert (!t2->specific->is_generic);
+
+ sym1 = t1->specific->u.specific->n.sym;
+ sym2 = t2->specific->u.specific->n.sym;
+
+ /* Both must be SUBROUTINEs or both must be FUNCTIONs. */
+ if (sym1->attr.subroutine != sym2->attr.subroutine
+ || sym1->attr.function != sym2->attr.function)
+ {
+ gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
+ " GENERIC '%s' at %L",
+ sym1->name, sym2->name, generic_name, &where);
+ return FAILURE;
+ }
+
+ /* Compare the interfaces. */
+ if (gfc_compare_interfaces (sym1, sym2, 1))
+ {
+ gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
+ sym1->name, sym2->name, generic_name, &where);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+/* Resolve a GENERIC procedure binding for a derived type. */
+
+static gfc_try
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+ gfc_tbp_generic* target;
+ gfc_symtree* first_target;
+ gfc_symbol* super_type;
+ gfc_symtree* inherited;
+ locus where;
+
+ gcc_assert (st->typebound);
+ gcc_assert (st->typebound->is_generic);
+
+ where = st->typebound->where;
+ super_type = gfc_get_derived_super_type (derived);
+
+ /* Find the overridden binding if any. */
+ st->typebound->overridden = NULL;
+ if (super_type)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+
+ if (overridden && overridden->typebound)
+ st->typebound->overridden = overridden->typebound;
+ }
+
+ /* Try to find the specific bindings for the symtrees in our target-list. */
+ gcc_assert (st->typebound->u.generic);
+ for (target = st->typebound->u.generic; target; target = target->next)
+ if (!target->specific)
+ {
+ gfc_typebound_proc* overridden_tbp;
+ gfc_tbp_generic* g;
+ const char* target_name;
+
+ target_name = target->specific_st->name;
+
+ /* Defined for this type directly. */
+ if (target->specific_st->typebound)
+ {
+ target->specific = target->specific_st->typebound;
+ goto specific_found;
+ }
+
+ /* Look for an inherited specific binding. */
+ if (super_type)
+ {
+ inherited = gfc_find_typebound_proc (super_type, NULL,
+ target_name, true);
+
+ if (inherited)
+ {
+ gcc_assert (inherited->typebound);
+ target->specific = inherited->typebound;
+ goto specific_found;
+ }
+ }
+
+ gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
+ " at %L", target_name, st->name, &where);
+ return FAILURE;
+
+ /* Once we've found the specific binding, check it is not ambiguous with
+ other specifics already found or inherited for the same GENERIC. */
+specific_found:
+ gcc_assert (target->specific);
+
+ /* This must really be a specific binding! */
+ if (target->specific->is_generic)
+ {
+ gfc_error ("GENERIC '%s' at %L must target a specific binding,"
+ " '%s' is GENERIC, too", st->name, &where, target_name);
+ return FAILURE;
+ }
+
+ /* Check those already resolved on this type directly. */
+ for (g = st->typebound->u.generic; g; g = g->next)
+ if (g != target && g->specific
+ && check_generic_tbp_ambiguity (target, g, st->name, where)
+ == FAILURE)
+ return FAILURE;
+
+ /* Check for ambiguity with inherited specific targets. */
+ for (overridden_tbp = st->typebound->overridden; overridden_tbp;
+ overridden_tbp = overridden_tbp->overridden)
+ if (overridden_tbp->is_generic)
+ {
+ for (g = overridden_tbp->u.generic; g; g = g->next)
+ {
+ gcc_assert (g->specific);
+ if (check_generic_tbp_ambiguity (target, g,
+ st->name, where) == FAILURE)
+ return FAILURE;
+ }
+ }
+ }
+
+ /* If we attempt to "overwrite" a specific binding, this is an error. */
+ if (st->typebound->overridden && !st->typebound->overridden->is_generic)
+ {
+ gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
+ " the same name", st->name, &where);
+ return FAILURE;
+ }
+
+ /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
+ all must have the same attributes here. */
+ first_target = st->typebound->u.generic->specific->u.specific;
+ st->typebound->subroutine = first_target->n.sym->attr.subroutine;
+ st->typebound->function = first_target->n.sym->attr.function;
+
+ return SUCCESS;
+}
+
+
+/* Resolve the type-bound procedures for a derived type. */
+
+static gfc_symbol* resolve_bindings_derived;
+static gfc_try resolve_bindings_result;
+
+static void
+resolve_typebound_procedure (gfc_symtree* stree)
+{
+ gfc_symbol* proc;
+ locus where;
+ gfc_symbol* me_arg;
+ gfc_symbol* super_type;
+ gfc_component* comp;
+
+ /* If this is no type-bound procedure, just return. */
+ if (!stree->typebound)
+ return;
+
+ /* If this is a GENERIC binding, use that routine. */
+ if (stree->typebound->is_generic)
+ {
+ if (resolve_typebound_generic (resolve_bindings_derived, stree)
+ == FAILURE)
+ goto error;
+ return;
+ }
+
+ /* Get the target-procedure to check it. */
+ gcc_assert (!stree->typebound->is_generic);
+ gcc_assert (stree->typebound->u.specific);
+ proc = stree->typebound->u.specific->n.sym;
+ where = stree->typebound->where;
+
+ /* Default access should already be resolved from the parser. */
+ gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
+
+ /* It should be a module procedure or an external procedure with explicit
+ interface. */
+ if ((!proc->attr.subroutine && !proc->attr.function)
+ || (proc->attr.proc != PROC_MODULE
+ && proc->attr.if_source != IFSRC_IFBODY)
+ || proc->attr.abstract)
+ {
+ gfc_error ("'%s' must be a module procedure or an external procedure with"
+ " an explicit interface at %L", proc->name, &where);
+ goto error;
+ }
+ stree->typebound->subroutine = proc->attr.subroutine;
+ stree->typebound->function = proc->attr.function;
+
+ /* Find the super-type of the current derived type. We could do this once and
+ store in a global if speed is needed, but as long as not I believe this is
+ more readable and clearer. */
+ super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+
+ /* If PASS, resolve and check arguments if not already resolved / loaded
+ from a .mod file. */
+ if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
+ {
+ if (stree->typebound->pass_arg)
+ {
+ gfc_formal_arglist* i;
+
+ /* If an explicit passing argument name is given, walk the arg-list
+ and look for it. */
+
+ me_arg = NULL;
+ stree->typebound->pass_arg_num = 1;
+ for (i = proc->formal; i; i = i->next)
+ {
+ if (!strcmp (i->sym->name, stree->typebound->pass_arg))
+ {
+ me_arg = i->sym;
+ break;
+ }
+ ++stree->typebound->pass_arg_num;
+ }
+
+ if (!me_arg)
+ {
+ gfc_error ("Procedure '%s' with PASS(%s) at %L has no"
+ " argument '%s'",
+ proc->name, stree->typebound->pass_arg, &where,
+ stree->typebound->pass_arg);
+ goto error;
+ }
+ }
+ else
+ {
+ /* Otherwise, take the first one; there should in fact be at least
+ one. */
+ stree->typebound->pass_arg_num = 1;
+ if (!proc->formal)
+ {
+ gfc_error ("Procedure '%s' with PASS at %L must have at"
+ " least one argument", proc->name, &where);
+ goto error;
+ }
+ me_arg = proc->formal->sym;
+ }
+
+ /* Now check that the argument-type matches. */
+ gcc_assert (me_arg);
+ if (me_arg->ts.type != BT_DERIVED
+ || me_arg->ts.derived != resolve_bindings_derived)
+ {
+ gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of"
+ " the derived-type '%s'", me_arg->name, proc->name,
+ me_arg->name, &where, resolve_bindings_derived->name);
+ goto error;
+ }
+
+ gfc_warning ("Polymorphic entities are not yet implemented,"
+ " non-polymorphic passed-object dummy argument of '%s'"
+ " at %L accepted", proc->name, &where);
+ }
+
+ /* If we are extending some type, check that we don't override a procedure
+ flagged NON_OVERRIDABLE. */
+ stree->typebound->overridden = NULL;
+ if (super_type)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_proc (super_type, NULL,
+ stree->name, true);
+
+ if (overridden && overridden->typebound)
+ stree->typebound->overridden = overridden->typebound;
+
+ if (overridden && check_typebound_override (stree, overridden) == FAILURE)
+ goto error;
+ }
+
+ /* See if there's a name collision with a component directly in this type. */
+ for (comp = resolve_bindings_derived->components; comp; comp = comp->next)
+ if (!strcmp (comp->name, stree->name))
+ {
+ gfc_error ("Procedure '%s' at %L has the same name as a component of"
+ " '%s'",
+ stree->name, &where, resolve_bindings_derived->name);
+ goto error;
+ }
+
+ /* Try to find a name collision with an inherited component. */
+ if (super_type && gfc_find_component (super_type, stree->name, true, true))
+ {
+ gfc_error ("Procedure '%s' at %L has the same name as an inherited"
+ " component of '%s'",
+ stree->name, &where, resolve_bindings_derived->name);
+ goto error;
+ }
+
+ stree->typebound->error = 0;
+ return;
+
+error:
+ resolve_bindings_result = FAILURE;
+ stree->typebound->error = 1;
+}
+
+static gfc_try
+resolve_typebound_procedures (gfc_symbol* derived)
+{
+ if (!derived->f2k_derived || !derived->f2k_derived->sym_root)
+ return SUCCESS;
+
+ resolve_bindings_derived = derived;
+ resolve_bindings_result = SUCCESS;
+ gfc_traverse_symtree (derived->f2k_derived->sym_root,
+ &resolve_typebound_procedure);
+
+ return resolve_bindings_result;
+}
+
+
/* Add a derived type to the dt_list. The dt_list is used in trans-types.c
to give all identical derived types the same backend_decl. */
static void
static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
+ gfc_symbol* super_type;
gfc_component *c;
int i;
+ super_type = gfc_get_derived_super_type (sym);
+
+ /* Ensure the extended type gets resolved before we do. */
+ if (super_type && resolve_fl_derived (super_type) == FAILURE)
+ return FAILURE;
+
+ /* An ABSTRACT type must be extensible. */
+ if (sym->attr.abstract && (sym->attr.is_bind_c || sym->attr.sequence))
+ {
+ gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT",
+ sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+
for (c = sym->components; c != NULL; c = c->next)
{
+ /* Check type-spec if this is not the parent-type component. */
+ if ((!sym->attr.extension || c != sym->components)
+ && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
+ return FAILURE;
+
+ /* If this type is an extension, see if this component has the same name
+ as an inherited type-bound procedure. */
+ if (super_type
+ && gfc_find_typebound_proc (super_type, NULL, c->name, true))
+ {
+ gfc_error ("Component '%s' of '%s' at %L has the same name as an"
+ " inherited type-bound procedure",
+ c->name, sym->name, &c->loc);
+ return FAILURE;
+ }
+
if (c->ts.type == BT_CHARACTER)
{
if (c->ts.cl->length == NULL
}
}
- if (c->ts.type == BT_DERIVED && c->pointer
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
&& c->ts.derived->components == NULL
&& !c->ts.derived->attr.zero_comp)
{
if (c->ts.type == BT_DERIVED
&& c->ts.derived
&& c->ts.derived->components
- && c->pointer
+ && c->attr.pointer
&& sym != c->ts.derived)
add_dt_to_dt_list (c->ts.derived);
- if (c->pointer || c->allocatable || c->as == NULL)
+ if (c->attr.pointer || c->attr.allocatable || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
}
}
+ /* Resolve the type-bound procedures. */
+ if (resolve_typebound_procedures (sym) == FAILURE)
+ return FAILURE;
+
/* Resolve the finalizer procedures. */
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
sym->attr.dimension = ifc->attr.dimension;
sym->attr.recursive = ifc->attr.recursive;
sym->attr.always_explicit = ifc->attr.always_explicit;
- sym->as = gfc_copy_array_spec (ifc->as);
copy_formal_args (sym, ifc);
+ /* Copy array spec. */
+ sym->as = gfc_copy_array_spec (ifc->as);
+ if (sym->as)
+ {
+ int i;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ gfc_expr_replace_symbols (sym->as->lower[i], sym);
+ gfc_expr_replace_symbols (sym->as->upper[i], sym);
+ }
+ }
+ /* Copy char length. */
+ if (ifc->ts.cl)
+ {
+ sym->ts.cl = gfc_get_charlen();
+ sym->ts.cl->resolved = ifc->ts.cl->resolved;
+ sym->ts.cl->length = gfc_copy_expr (ifc->ts.cl->length);
+ gfc_expr_replace_symbols (sym->ts.cl->length, sym);
+ /* Add charlen to namespace. */
+ if (sym->formal_ns)
+ {
+ sym->ts.cl->next = sym->formal_ns->cl_list;
+ sym->formal_ns->cl_list = sym->ts.cl;
+ }
+ }
}
else if (sym->ts.interface->name[0] != '\0')
{
|| (a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym);
}
+
+ /* If this symbol has a type-spec, check it. */
+ if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER
+ || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
+ if (resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)
+ == FAILURE)
+ return;
}
/* Shall not be an object of sequence derived type containing a pointer
in the structure. */
- if (c->pointer)
+ if (c->attr.pointer)
{
gfc_error ("Derived type variable '%s' at %L with pointer "
"component(s) cannot be an EQUIVALENCE object",
gfc_charlen *cl;
gfc_data *d;
gfc_equiv *eq;
+ gfc_namespace* old_ns = gfc_current_ns;
+
+ /* Check that all IMPLICIT types are ok. */
+ if (!ns->seen_implicit_none)
+ {
+ unsigned letter;
+ for (letter = 0; letter != GFC_LETTERS; ++letter)
+ if (ns->set_flag[letter]
+ && resolve_typespec_used (&ns->default_type[letter],
+ &ns->implicit_loc[letter],
+ NULL) == FAILURE)
+ return;
+ }
gfc_current_ns = ns;
warn_unused_fortran_label (ns->st_labels);
gfc_resolve_uops (ns->uop_root);
+
+ gfc_current_ns = old_ns;
}
OSDN Git Service
