/* 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
{
if (current_interface.op == INTRINSIC_ASSIGN)
- gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+ }
else
- gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
- gfc_op2string (current_interface.op));
+ {
+ const char *s1, *s2;
+ s1 = gfc_op2string (current_interface.op);
+ s2 = gfc_op2string (op);
+
+ /* The following if-statements are used to enforce C1202
+ from F2003. */
+ if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
+ || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
+ break;
+ if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
+ || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
+ break;
+ if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
+ || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
+ break;
+ if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
+ || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
+ break;
+ if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
+ || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
+ break;
+ if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
+ || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
+ break;
- m = MATCH_ERROR;
+ m = MATCH_ERROR;
+ gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
+ "but got %s", s1, s2);
+ }
+
}
break;
/* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
- First argument an array with different rank than second,
- - Types and kinds do not conform, and
+ - First argument is a scalar and second an array,
+ - Types and kinds do not conform, or
- First argument is of derived type. */
if (sym->formal->sym->ts.type != BT_DERIVED
&& sym->formal->sym->ts.type != BT_CLASS
- && (r1 == 0 || r1 == r2)
+ && (r2 == 0 || r1 == r2)
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
|| (gfc_numeric_ts (&sym->formal->sym->ts)
&& gfc_numeric_ts (&sym->formal->next->sym->ts))))
/* Find other nonoptional arguments of the same type/rank. */
for (j = i + 1; j < n1; j++)
if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
- && compare_type_rank_if (arg[i].sym, arg[j].sym))
+ && (compare_type_rank_if (arg[i].sym, arg[j].sym)
+ || compare_type_rank_if (arg[j].sym, arg[i].sym)))
arg[j].flag = k;
k++;
ac2 = 0;
for (f = f2; f; f = f->next)
- if (compare_type_rank_if (arg[i].sym, f->sym))
+ if (compare_type_rank_if (arg[i].sym, f->sym)
+ || compare_type_rank_if (f->sym, arg[i].sym))
ac2++;
if (ac1 > ac2)
if (f1->sym->attr.optional)
goto next;
- if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
+ if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
+ || compare_type_rank (f2->sym, f1->sym)))
goto next;
/* Now search for a disambiguating keyword argument starting at
}
/* Check type and rank. */
- if (!compare_type_rank (f1->sym, f2->sym))
+ if (!compare_type_rank (f2->sym, f1->sym))
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
/* Given a pointer to an interface pointer, remove duplicate
- interfaces and make sure that all symbols are either functions or
- subroutines. Returns nonzero if something goes wrong. */
+ interfaces and make sure that all symbols are either functions
+ or subroutines, and all of the same kind. Returns nonzero if
+ something goes wrong. */
static int
check_interface0 (gfc_interface *p, const char *interface_name)
gfc_interface *psave, *q, *qlast;
psave = p;
- /* Make sure all symbols in the interface have been defined as
- functions or subroutines. */
for (; p; p = p->next)
- if ((!p->sym->attr.function && !p->sym->attr.subroutine)
- || !p->sym->attr.if_source)
- {
- if (p->sym->attr.external)
- gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
- p->sym->name, interface_name, &p->sym->declared_at);
- else
- gfc_error ("Procedure '%s' in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
- return 1;
- }
+ {
+ /* Make sure all symbols in the interface have been defined as
+ functions or subroutines. */
+ if ((!p->sym->attr.function && !p->sym->attr.subroutine)
+ || !p->sym->attr.if_source)
+ {
+ if (p->sym->attr.external)
+ gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+ p->sym->name, interface_name, &p->sym->declared_at);
+ else
+ gfc_error ("Procedure '%s' in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
+ return 1;
+ }
+
+ /* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
+ if ((psave->sym->attr.function && !p->sym->attr.function)
+ || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
+ {
+ gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
+ " or all FUNCTIONs", interface_name, &p->sym->declared_at);
+ return 1;
+ }
+ }
p = psave;
/* Remove duplicate interfaces in this interface list. */
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, 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",
{
symbol_attribute attr;
- if (formal->attr.allocatable)
+ if (formal->attr.allocatable
+ || (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
{
attr = gfc_expr_attr (actual);
if (!attr.allocatable)
if (formal->attr.pointer)
{
attr = gfc_expr_attr (actual);
+
+ /* Fortran 2008 allows non-pointer actual arguments. */
+ if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
+ return 2;
+
if (!attr.pointer)
return 0;
}
}
+/* Emit clear error messages for rank mismatch. */
+
+static void
+argument_rank_mismatch (const char *name, locus *where,
+ int rank1, int rank2)
+{
+ if (rank1 == 0)
+ {
+ gfc_error ("Rank mismatch in argument '%s' at %L "
+ "(scalar and rank-%d)", name, where, rank2);
+ }
+ else if (rank2 == 0)
+ {
+ gfc_error ("Rank mismatch in argument '%s' at %L "
+ "(rank-%d and scalar)", name, where, rank1);
+ }
+ else
+ {
+ gfc_error ("Rank mismatch in argument '%s' at %L "
+ "(rank-%d and rank-%d)", name, where, rank1, rank2);
+ }
+}
+
+
/* Given a symbol of a formal argument list and an expression, see if
the two are compatible as arguments. Returns nonzero if
compatible, zero if not compatible. */
int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
- bool rank_check;
+ bool rank_check, is_pointer;
/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
procs c_f_pointer or c_f_procpointer, and we need to accept most
&& actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
return 1;
+ if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
+ /* Make sure the vtab symbol is present when
+ the module variables are generated. */
+ gfc_find_derived_vtab (actual->ts.u.derived);
+
if (actual->ts.type == BT_PROCEDURE)
{
char err[200];
return 1;
}
+ /* F2008, C1241. */
+ if (formal->attr.pointer && formal->attr.contiguous
+ && !gfc_is_simply_contiguous (actual, true))
+ {
+ if (where)
+ gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+ "must be simply contigous", formal->name, &actual->where);
+ return 0;
+ }
+
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
+ && actual->ts.type != BT_HOLLERITH
&& !gfc_compare_types (&formal->ts, &actual->ts))
{
if (where)
gfc_typename (&formal->ts));
return 0;
}
+
+ /* F2003, 12.5.2.5. */
+ if (formal->ts.type == BT_CLASS
+ && (CLASS_DATA (formal)->attr.class_pointer
+ || CLASS_DATA (formal)->attr.allocatable))
+ {
+ if (actual->ts.type != BT_CLASS)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+ formal->name, &actual->where);
+ return 0;
+ }
+ if (CLASS_DATA (actual)->ts.u.derived
+ != CLASS_DATA (formal)->ts.u.derived)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must have the same "
+ "declared type", formal->name, &actual->where);
+ return 0;
+ }
+ }
+
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
+
+ if (actual->expr_type != EXPR_VARIABLE
+ || !gfc_expr_attr (actual).codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ if (gfc_is_coindexed (actual))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &actual->where);
+ return 0;
+ }
+
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ 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;
+ }
+
+ /* 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;
+ }
+
+ /* F2008, 12.5.2.8. */
+ if (formal->attr.dimension
+ && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+ && !gfc_is_simply_contiguous (actual, true))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be simply "
+ "contiguous", formal->name, &actual->where);
+ return 0;
+ }
+ }
+
+ /* F2008, C1239/C1240. */
+ if (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->attr.asynchronous
+ || actual->symtree->n.sym->attr.volatile_)
+ && (formal->attr.asynchronous || formal->attr.volatile_)
+ && actual->rank && !gfc_is_simply_contiguous (actual, true)
+ && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+ || formal->attr.contiguous))
+ {
+ if (where)
+ gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+ "array without CONTIGUOUS attribute - as actual argument at"
+ " %L is not simply contiguous and both are ASYNCHRONOUS "
+ "or VOLATILE", formal->name, &actual->where);
+ 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->expr_type != EXPR_NULL)
+ || (actual->rank == 0 && formal->attr.dimension
+ && gfc_is_coindexed (actual)))
{
if (where)
- gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
- formal->name, &actual->where, symbol_rank (formal),
- actual->rank);
+ argument_rank_mismatch (formal->name, &actual->where,
+ symbol_rank (formal), actual->rank);
return 0;
}
else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
return 1;
/* At this point, we are considering a scalar passed to an array. This
- is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+ is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
- if the actual argument is (a substring of) an element of a
- non-assumed-shape/non-pointer array;
- - (F2003) if the actual argument is of type character. */
+ non-assumed-shape/non-pointer/non-polymorphic array; or
+ - (F2003) if the actual argument is of type character of default/c_char
+ kind. */
+
+ is_pointer = actual->expr_type == EXPR_VARIABLE
+ ? actual->symtree->n.sym->attr.pointer : false;
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
- break;
+ {
+ if (ref->type == REF_COMPONENT)
+ is_pointer = ref->u.c.component->attr.pointer;
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0
+ && (!ref->next
+ || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+ break;
+ }
- /* Not an array element. */
- if (formal->ts.type == BT_CHARACTER
- && (ref == NULL
- || (actual->expr_type == EXPR_VARIABLE
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))))
+ if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
{
+ if (where)
+ gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+ "at %L", formal->name, &actual->where);
+ return 0;
+ }
+
+ if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+ && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+ {
+ if (where)
+ gfc_error ("Element of assumed-shaped or pointer "
+ "array passed to array dummy argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+ && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+ {
+ if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+ {
+ if (where)
+ gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+ "CHARACTER actual argument with array dummy argument "
+ "'%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
+
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
{
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
else
return 1;
}
- else if (ref == NULL)
- {
- if (where)
- gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
- formal->name, &actual->where, symbol_rank (formal),
- actual->rank);
- return 0;
- }
- if (actual->expr_type == EXPR_VARIABLE
- && actual->symtree->n.sym->as
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))
+ if (ref == NULL && actual->expr_type != EXPR_NULL)
{
if (where)
- gfc_error ("Element of assumed-shaped array passed to dummy "
- "argument '%s' at %L", formal->name, &actual->where);
+ argument_rank_mismatch (formal->name, &actual->where,
+ symbol_rank (formal), actual->rank);
return 0;
}
}
-/* Given a symbol of a formal argument list and an expression, see if
- the two are compatible as arguments. Returns nonzero if
- compatible, zero if not compatible. */
-
-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
- if (actual->expr_type != EXPR_VARIABLE)
- return 1;
-
- if (!actual->symtree->n.sym->attr.is_protected)
- return 1;
-
- if (!actual->symtree->n.sym->attr.use_assoc)
- return 1;
-
- if (formal->attr.intent == INTENT_IN
- || formal->attr.intent == INTENT_UNKNOWN)
- return 1;
-
- if (!actual->symtree->n.sym->attr.pointer)
- return 0;
-
- if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
- return 0;
-
- return 1;
-}
-
-
/* Returns the storage size of a symbol (formal argument) or
zero if it cannot be determined. */
|| 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;
else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
&& e->expr_type == EXPR_VARIABLE)
{
- if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ if (ref->u.ar.as->type == AS_ASSUMED_SHAPE
|| e->symtree->n.sym->attr.pointer)
{
elements = 1;
- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
}
}
- else
- return 0;
}
if (substrlen)
which has a vector subscript. If it has, one is returned,
otherwise zero. */
-static int
-has_vector_subscript (gfc_expr *e)
+int
+gfc_has_vector_subscript (gfc_expr *e)
{
int i;
gfc_ref *ref;
for (f = formal; f; f = f->next)
n++;
- new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
+ new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
for (i = 0; i < n; i++)
new_arg[i] = NULL;
"call at %L", where);
return 0;
}
+
+ if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
+ && (f->sym->attr.allocatable || !f->sym->attr.optional
+ || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+ {
+ if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+ gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+ where, f->sym->name);
+ else if (where)
+ gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
+ "dummy '%s'", where, f->sym->name);
+
+ return 0;
+ }
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
return 0;
}
+ if ((f->sym->attr.pointer || f->sym->attr.allocatable)
+ && f->sym->ts.deferred != a->expr->ts.deferred
+ && a->expr->ts.type == BT_CHARACTER)
+ {
+ if (where)
+ gfc_error ("Actual argument argument at %L to allocatable or "
+ "pointer dummy argument '%s' must have a deferred "
+ "length type parameter if and only if the dummy has one",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
- if (actual_size != 0
- && actual_size < formal_size
- && a->expr->ts.type != BT_PROCEDURE)
+ if (actual_size != 0 && actual_size < formal_size
+ && a->expr->ts.type != BT_PROCEDURE
+ && f->sym->attr.flavor != FL_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
gfc_warning ("Character length of actual argument shorter "
- "than of dummy argument '%s' (%lu/%lu) at %L",
- f->sym->name, actual_size, formal_size,
- &a->expr->where);
+ "than of dummy argument '%s' (%lu/%lu) at %L",
+ f->sym->name, actual_size, formal_size,
+ &a->expr->where);
else if (where)
gfc_warning ("Actual argument contains too few "
- "elements for dummy argument '%s' (%lu/%lu) at %L",
- f->sym->name, actual_size, formal_size,
- &a->expr->where);
+ "elements for dummy argument '%s' (%lu/%lu) at %L",
+ f->sym->name, actual_size, formal_size,
+ &a->expr->where);
return 0;
}
}
if (a->expr->expr_type != EXPR_NULL
- && compare_allocatable (f->sym, a->expr) == 0)
+ && (gfc_option.allow_std & GFC_STD_F2008) == 0
+ && compare_pointer (f->sym, a->expr) == 2)
{
if (where)
- gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
- f->sym->name, &a->expr->where);
+ gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+ "pointer dummy '%s'", &a->expr->where,f->sym->name);
return 0;
}
+
- /* Check intent = OUT/INOUT for definable actual argument. */
- if ((a->expr->expr_type != EXPR_VARIABLE
- || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
- && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
- && (f->sym->attr.intent == INTENT_OUT
- || f->sym->attr.intent == INTENT_INOUT))
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
{
if (where)
- gfc_error ("Actual argument at %L must be definable as "
- "the dummy argument '%s' is INTENT = OUT/INOUT",
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
&a->expr->where, f->sym->name);
return 0;
}
- if (!compare_parameter_protected(f->sym, a->expr))
+ /* 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 ("Actual argument at %L is use-associated with "
- "PROTECTED attribute and dummy argument '%s' is "
- "INTENT = OUT/INOUT",
- &a->expr->where,f->sym->name);
+ 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)
+ {
+ if (where)
+ gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
+ /* Check intent = OUT/INOUT for definable actual argument. */
+ if ((f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT))
+ {
+ const char* context = (where
+ ? _("actual argument to INTENT = OUT/INOUT")
+ : NULL);
+
+ if (f->sym->attr.pointer
+ && gfc_check_vardef_context (a->expr, true, context)
+ == FAILURE)
+ return 0;
+ if (gfc_check_vardef_context (a->expr, false, context)
+ == FAILURE)
+ return 0;
+ }
+
if ((f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT
- || f->sym->attr.volatile_)
- && has_vector_subscript (a->expr))
+ || f->sym->attr.volatile_
+ || f->sym->attr.asynchronous)
+ && gfc_has_vector_subscript (a->expr))
{
if (where)
- gfc_error ("Array-section actual argument with vector subscripts "
- "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
- "or VOLATILE attribute of the dummy argument '%s'",
+ gfc_error ("Array-section actual argument with vector "
+ "subscripts at %L is incompatible with INTENT(OUT), "
+ "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
+ "of the dummy argument '%s'",
&a->expr->where, f->sym->name);
return 0;
}
}
if (n == 0)
return t;
- p = (argpair *) alloca (n * sizeof (argpair));
+ p = XALLOCAVEC (argpair, n);
for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
{
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;
if (sym->attr.if_source == IFSRC_UNKNOWN)
{
gfc_actual_arglist *a;
+
+ if (sym->attr.pointer)
+ {
+ gfc_error("The pointer object '%s' at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
+ return;
+ }
+
+ if (sym->attr.allocatable && !sym->attr.external)
+ {
+ gfc_error("The allocatable object '%s' at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
+ return;
+ }
+
+ if (sym->attr.allocatable)
+ {
+ gfc_error("Allocatable function '%s' at %L must have an explicit "
+ "function interface", sym->name, where);
+ return;
+ }
+
for (a = *ap; a; a = a->next)
{
/* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
/* See if the arglist to an operator-call contains a derived-type argument
with a matching type-bound operator. If so, return the matching specific
procedure defined as operator-target as well as the base-object to use
- (which is the found derived-type argument with operator). */
+ (which is the found derived-type argument with operator). The generic
+ name, if any, is transmitted to the final expression via 'gname'. */
static gfc_typebound_proc*
matching_typebound_op (gfc_expr** tb_base,
gfc_actual_arglist* args,
- gfc_intrinsic_op op, const char* uop)
+ gfc_intrinsic_op op, const char* uop,
+ const char ** gname)
{
gfc_actual_arglist* base;
gfc_try result;
if (base->expr->ts.type == BT_CLASS)
- derived = base->expr->ts.u.derived->components->ts.u.derived;
+ {
+ if (!gfc_expr_attr (base->expr).class_ok)
+ continue;
+ derived = CLASS_DATA (base->expr)->ts.u.derived;
+ }
else
derived = base->expr->ts.u.derived;
if (matches)
{
*tb_base = base->expr;
+ *gname = g->specific_st->name;
return g->specific;
}
}
static void
build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
- gfc_expr* base, gfc_typebound_proc* target)
+ gfc_expr* base, gfc_typebound_proc* target,
+ const char *gname)
{
e->expr_type = EXPR_COMPCALL;
e->value.compcall.tbp = target;
- e->value.compcall.name = "operator"; /* Should not matter. */
+ e->value.compcall.name = gname ? gname : "$op";
e->value.compcall.actual = actual;
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
gfc_namespace *ns;
gfc_user_op *uop;
gfc_intrinsic_op i;
+ const char *gname;
sym = NULL;
actual->expr = e->value.op.op1;
*real_error = false;
+ gname = NULL;
if (e->value.op.op2 != NULL)
{
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
- i, e->value.op.uop->name);
+ i, e->value.op.uop->name, &gname);
else
switch (i)
{
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp, NULL); \
+ INTRINSIC_##comp, NULL, &gname); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp##_OS, NULL); \
+ INTRINSIC_##comp##_OS, NULL, &gname); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
#undef CHECK_OS_COMPARISON
default:
- tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+ tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
break;
}
gfc_try result;
gcc_assert (tb_base);
- build_compcall_for_operator (e, actual, tb_base, tbo);
+ build_compcall_for_operator (e, actual, tb_base, tbo, gname);
result = gfc_resolve_expr (e);
if (result == FAILURE)
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
gfc_symbol *sym;
+ const char *gname;
+
+ gname = NULL;
lhs = c->expr1;
rhs = c->expr2;
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
- INTRINSIC_ASSIGN, NULL);
+ INTRINSIC_ASSIGN, NULL, &gname);
/* If there is one, replace the expression with a call to it and
succeed. */
{
gcc_assert (tb_base);
c->expr1 = gfc_get_expr ();
- build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+ build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
c->expr1->value.compcall.assign = 1;
c->expr2 = NULL;
c->op = EXEC_COMPCALL;
OSDN Git Service
