}
+/* 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 == EXPR_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)
{
/* 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
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;
+
+ 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)
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]);
+
+ 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;
+ }
}
{
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
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')
{
gfc_charlen *cl;
gfc_data *d;
gfc_equiv *eq;
-
- gfc_current_ns = ns;
+ gfc_namespace* old_ns = gfc_current_ns;
/* Check that all IMPLICIT types are ok. */
if (!ns->seen_implicit_none)
return;
}
+ gfc_current_ns = ns;
+
resolve_entries (ns);
resolve_common_vars (ns->blank_common.head, false);
warn_unused_fortran_label (ns->st_labels);
gfc_resolve_uops (ns->uop_root);
+
+ gfc_current_ns = old_ns;
}
OSDN Git Service
