{
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));
+ {
+ 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;
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. */
&& 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)
: 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)
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))
else if (ref == NULL && actual->expr_type != EXPR_NULL)
{
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;
}
}
-/* 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. */
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 (a->expr->expr_type != EXPR_NULL
+ && (gfc_option.allow_std & GFC_STD_F2008) == 0
+ && compare_pointer (f->sym, a->expr) == 2)
+ {
+ if (where)
+ gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+ "pointer dummy '%s'", &a->expr->where,f->sym->name);
+ return 0;
+ }
+
+
/* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
{
}
/* 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))
+ if ((f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT))
{
- if (where)
- gfc_error ("Actual argument at %L must be definable as "
- "the dummy argument '%s' is INTENT = OUT/INOUT",
- &a->expr->where, f->sym->name);
- return 0;
- }
+ const char* context = (where
+ ? _("actual argument to INTENT = OUT/INOUT")
+ : NULL);
- if (!compare_parameter_protected(f->sym, 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);
- return 0;
+ 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)
{
/* 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;
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
