/* Deal with interfaces.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
{
gfc_formal_arglist *f1, *f2;
+ gcc_assert (name2 != NULL);
+
if (s1->attr.function && (s2->attr.subroutine
|| (!s2->attr.function && s2->ts.type == BT_UNKNOWN
&& gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, NULL, generic_flag, 0,
- NULL, 0))
+ if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
+ 0, NULL, 0))
{
if (referenced)
- {
- gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
- p->sym->name, q->sym->name, interface_name,
- &p->where);
- }
-
- if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
+ gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
+ p->sym->name, q->sym->name, interface_name,
+ &p->where);
+ else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
p->sym->name, q->sym->name, interface_name,
&p->where);
+ else
+ gfc_warning ("Although not referenced, '%s' has ambiguous "
+ "interfaces at %L", interface_name, &p->where);
return 1;
}
}
check_sym_interfaces (gfc_symbol *sym)
{
char interface_name[100];
- bool k;
gfc_interface *p;
if (sym->ns != gfc_current_ns)
/* Originally, this test was applied to host interfaces too;
this is incorrect since host associated symbols, from any
source, cannot be ambiguous with local symbols. */
- k = sym->attr.referenced || !sym->attr.use_assoc;
- if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
- sym->attr.ambiguous_interfaces = 1;
+ check_interface1 (sym->generic, sym->generic, 1, interface_name,
+ sym->attr.referenced || !sym->attr.use_assoc);
}
}
return 0;
}
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
+
+ if (actual->expr_type != EXPR_VARIABLE
+ || (actual->ref == NULL
+ && !actual->symtree->n.sym->attr.codimension))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+ && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and thus shall not have an array designator",
+ formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+ }
+
+ if (last && !last->u.c.component->attr.codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
+ }
+
if (symbol_rank (formal) == actual->rank)
return 1;
rank_check = where != NULL && !is_elemental && formal->as
&& (formal->as->type == AS_ASSUMED_SHAPE
- || formal->as->type == AS_DEFERRED);
+ || formal->as->type == AS_DEFERRED)
+ && actual->expr_type != EXPR_NULL;
- if (rank_check || ranks_must_agree || formal->attr.pointer
+ /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
+ if (rank_check || ranks_must_agree
+ || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|| (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
- || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+ || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+ || (actual->rank == 0 && formal->attr.dimension
+ && gfc_is_coindexed (actual)))
{
if (where)
gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
- (F2003) if the actual argument is of type character. */
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0)
break;
/* Not an array element. */
else
return 1;
}
- else if (ref == NULL)
+ else if (ref == NULL && actual->expr_type != EXPR_NULL)
{
if (where)
gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT)
return 0;
- elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
- - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
+ elements *= mpz_get_si (sym->as->upper[i]->value.integer)
+ - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
}
return strlen*elements;
return 0;
}
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.5 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN
+ && f->sym->attr.allocatable
+ && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to allocatable "
+ "dummy '%s' requires INTENT(IN)",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, C1237. */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+ && gfc_is_coindexed (a->expr)
+ && (a->expr->symtree->n.sym->attr.volatile_
+ || a->expr->symtree->n.sym->attr.asynchronous))
+ {
+ if (where)
+ gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+ "at %L requires that dummy %s' has neither "
+ "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+ f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.4 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+ && gfc_is_coindexed (a->expr)
+ && gfc_has_ultimate_allocatable (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L with allocatable "
+ "ultimate component to dummy '%s' requires either VALUE "
+ "or INTENT(IN)", &a->expr->where, f->sym->name);
+ return 0;
+ }
+
if (a->expr->expr_type != EXPR_NULL
&& compare_allocatable (f->sym, a->expr) == 0)
{
return FAILURE;
}
}
+
+ /* Fortran 2008, C1283. */
+ if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+ {
+ if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to an INTENT(%s) argument",
+ &a->expr->where, gfc_intent_string (f_intent));
+ return FAILURE;
+ }
+
+ if (f->sym->attr.pointer)
+ {
+ gfc_error ("Coindexed actual argument at %L in PURE procedure "
+ "is passed to a POINTER dummy argument",
+ &a->expr->where);
+ return FAILURE;
+ }
+ }
+
+ /* F2008, Section 12.5.2.4. */
+ if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+ && gfc_is_coindexed (a->expr))
+ {
+ gfc_error ("Coindexed polymorphic actual argument at %L is passed "
+ "polymorphic dummy argument '%s'",
+ &a->expr->where, f->sym->name);
+ return FAILURE;
+ }
}
return SUCCESS;
gfc_try result;
if (base->expr->ts.type == BT_CLASS)
- derived = base->expr->ts.u.derived->components->ts.u.derived;
+ derived = CLASS_DATA (base->expr)->ts.u.derived;
else
derived = base->expr->ts.u.derived;