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
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;
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;
- if (c->symtree && c->symtree->n.sym
- && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+ csym = c->symtree ? c->symtree->n.sym : NULL;
+
+ 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)
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)
{
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;
tbp = e->value.compcall.tbp;
+ if (tbp->error)
+ return FAILURE;
+
po = extract_compcall_passed_object (e);
if (!po)
return FAILURE;
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. */
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_compare_actual_formal (&args, target->formal, 1,
- target->attr.elemental, NULL);
+ 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 (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. */
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);
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]);
- /* Reset the counters. */
- total_var = 0;
- nvar = 0;
+ if (nvar == 0)
+ {
+ /* We are in the outermost FORALL construct. */
+ gcc_assert (forall_save == 0);
+
+ /* VAR_EXPR is not needed any more. */
+ gfc_free (var_expr);
+ total_var = 0;
+ }
}
{
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)
{
goto error;
}
+ stree->typebound->error = 0;
return;
error:
resolve_bindings_result = FAILURE;
+ stree->typebound->error = 1;
}
static gfc_try
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
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;
}
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
