/* Deal with interfaces.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
minus respectively, leaving the rest unchanged. */
static gfc_intrinsic_op
-fold_unary (gfc_intrinsic_op operator)
+fold_unary_intrinsic (gfc_intrinsic_op op)
{
- switch (operator)
+ switch (op)
{
case INTRINSIC_UPLUS:
- operator = INTRINSIC_PLUS;
+ op = INTRINSIC_PLUS;
break;
case INTRINSIC_UMINUS:
- operator = INTRINSIC_MINUS;
+ op = INTRINSIC_MINUS;
break;
default:
break;
}
- return operator;
+ return op;
}
/* Match a generic specification. Depending on which type of
- interface is found, the 'name' or 'operator' pointers may be set.
+ interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */
match
gfc_match_generic_spec (interface_type *type,
char *name,
- gfc_intrinsic_op *operator)
+ gfc_intrinsic_op *op)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
if (gfc_match (" assignment ( = )") == MATCH_YES)
{
*type = INTERFACE_INTRINSIC_OP;
- *operator = INTRINSIC_ASSIGN;
+ *op = INTRINSIC_ASSIGN;
return MATCH_YES;
}
if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
{ /* Operator i/f */
*type = INTERFACE_INTRINSIC_OP;
- *operator = fold_unary (i);
+ *op = fold_unary_intrinsic (i);
return MATCH_YES;
}
+ *op = INTRINSIC_NONE;
if (gfc_match (" operator ( ") == MATCH_YES)
{
m = gfc_match_defined_op_name (buffer, 1);
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_symbol *sym;
- gfc_intrinsic_op operator;
+ gfc_intrinsic_op op;
match m;
m = gfc_match_space ();
- if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
+ if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
return MATCH_ERROR;
/* If we're not looking at the end of the statement now, or if this
break;
case INTERFACE_INTRINSIC_OP:
- current_interface.op = operator;
+ current_interface.op = op;
break;
case INTERFACE_NAMELESS:
{
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
- gfc_intrinsic_op operator;
+ gfc_intrinsic_op op;
match m;
m = gfc_match_space ();
- if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
+ if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
return MATCH_ERROR;
/* If we're not looking at the end of the statement now, or if this
break;
case INTERFACE_INTRINSIC_OP:
- if (type != current_interface.type || operator != current_interface.op)
+ if (type != current_interface.type || op != current_interface.op)
{
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;
{
gfc_component *dt1, *dt2;
+ if (derived1 == derived2)
+ return 1;
+
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
nonnull, then they are equal. */
if (strcmp (dt1->name, dt2->name) != 0)
return 0;
- if (dt1->access != dt2->access)
+ if (dt1->attr.access != dt2->attr.access)
+ return 0;
+
+ if (dt1->attr.pointer != dt2->attr.pointer)
return 0;
- if (dt1->pointer != dt2->pointer)
+ if (dt1->attr.dimension != dt2->attr.dimension)
return 0;
- if (dt1->dimension != dt2->dimension)
+ if (dt1->attr.allocatable != dt2->attr.allocatable)
return 0;
- if (dt1->allocatable != dt2->allocatable)
+ if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
- if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
+ /* Make sure that link lists do not put this function into an
+ endless recursive loop! */
+ if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
return 0;
- if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
+ else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
+ return 0;
+
+ else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
+ && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
return 0;
dt1 = dt1->next;
if (ts1->type == BT_VOID || ts2->type == BT_VOID)
return 1;
- if (ts1->type != ts2->type)
+ if (ts1->type != ts2->type
+ && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
+ || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
return 0;
- if (ts1->type != BT_DERIVED)
+ if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
return (ts1->kind == ts2->kind);
/* Compare derived types. */
- if (ts1->derived == ts2->derived)
+ if (gfc_type_compatible (ts1, ts2))
return 1;
- return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+ return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
}
}
-static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
-
/* Given two symbols that are formal arguments, compare their types
and rank and their formal interfaces if they are both dummy
procedures. Returns nonzero if the same, zero if different. */
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? 1 : 0;
+ if (s1 == s2)
+ return 1;
+
if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
return compare_type_rank (s1, s2);
if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
return 0;
- /* At this point, both symbols are procedures. */
- if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
- || (s2->attr.function == 0 && s2->attr.subroutine == 0))
- return 0;
+ /* At this point, both symbols are procedures. It can happen that
+ external procedures are compared, where one is identified by usage
+ to be a function or subroutine but the other is not. Check TKR
+ nonetheless for these cases. */
+ if (s1->attr.function == 0 && s1->attr.subroutine == 0)
+ return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+ if (s2->attr.function == 0 && s2->attr.subroutine == 0)
+ return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+
+ /* Now the type of procedure has been identified. */
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
return 0;
/* Given an operator interface and the operator, make sure that all
interfaces for that operator are legal. */
-static void
-check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+ locus opwhere)
{
gfc_formal_arglist *formal;
sym_intent i1, i2;
- gfc_symbol *sym;
bt t1, t2;
int args, r1, r2, k1, k2;
- if (intr == NULL)
- return;
+ gcc_assert (sym);
args = 0;
t1 = t2 = BT_UNKNOWN;
r1 = r2 = -1;
k1 = k2 = -1;
- for (formal = intr->sym->formal; formal; formal = formal->next)
+ for (formal = sym->formal; formal; formal = formal->next)
{
- sym = formal->sym;
- if (sym == NULL)
+ gfc_symbol *fsym = formal->sym;
+ if (fsym == NULL)
{
gfc_error ("Alternate return cannot appear in operator "
- "interface at %L", &intr->where);
- return;
+ "interface at %L", &sym->declared_at);
+ return false;
}
if (args == 0)
{
- t1 = sym->ts.type;
- i1 = sym->attr.intent;
- r1 = (sym->as != NULL) ? sym->as->rank : 0;
- k1 = sym->ts.kind;
+ t1 = fsym->ts.type;
+ i1 = fsym->attr.intent;
+ r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+ k1 = fsym->ts.kind;
}
if (args == 1)
{
- t2 = sym->ts.type;
- i2 = sym->attr.intent;
- r2 = (sym->as != NULL) ? sym->as->rank : 0;
- k2 = sym->ts.kind;
+ t2 = fsym->ts.type;
+ i2 = fsym->attr.intent;
+ r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+ k2 = fsym->ts.kind;
}
args++;
}
- sym = intr->sym;
-
/* Only +, - and .not. can be unary operators.
.not. cannot be a binary operator. */
- if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
- && operator != INTRINSIC_MINUS
- && operator != INTRINSIC_NOT)
- || (args == 2 && operator == INTRINSIC_NOT))
+ if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
+ && op != INTRINSIC_MINUS
+ && op != INTRINSIC_NOT)
+ || (args == 2 && op == INTRINSIC_NOT))
{
gfc_error ("Operator interface at %L has the wrong number of arguments",
- &intr->where);
- return;
+ &sym->declared_at);
+ return false;
}
/* Check that intrinsics are mapped to functions, except
INTRINSIC_ASSIGN which should map to a subroutine. */
- if (operator == INTRINSIC_ASSIGN)
+ if (op == INTRINSIC_ASSIGN)
{
if (!sym->attr.subroutine)
{
gfc_error ("Assignment operator interface at %L must be "
- "a SUBROUTINE", &intr->where);
- return;
+ "a SUBROUTINE", &sym->declared_at);
+ return false;
}
if (args != 2)
{
gfc_error ("Assignment operator interface at %L must have "
- "two arguments", &intr->where);
- return;
+ "two arguments", &sym->declared_at);
+ return false;
}
+
+ /* 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 of derived type. */
if (sym->formal->sym->ts.type != BT_DERIVED
- && sym->formal->next->sym->ts.type != BT_DERIVED
+ && sym->formal->sym->ts.type != BT_CLASS
+ && (r1 == 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))))
{
gfc_error ("Assignment operator interface at %L must not redefine "
- "an INTRINSIC type assignment", &intr->where);
- return;
+ "an INTRINSIC type assignment", &sym->declared_at);
+ return false;
}
}
else
if (!sym->attr.function)
{
gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
- &intr->where);
- return;
+ &sym->declared_at);
+ return false;
}
}
/* Check intents on operator interfaces. */
- if (operator == INTRINSIC_ASSIGN)
+ if (op == INTRINSIC_ASSIGN)
{
if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
- gfc_error ("First argument of defined assignment at %L must be "
- "INTENT(IN) or INTENT(INOUT)", &intr->where);
+ {
+ gfc_error ("First argument of defined assignment at %L must be "
+ "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+ return false;
+ }
if (i2 != INTENT_IN)
- gfc_error ("Second argument of defined assignment at %L must be "
- "INTENT(IN)", &intr->where);
+ {
+ gfc_error ("Second argument of defined assignment at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
}
else
{
if (i1 != INTENT_IN)
- gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
+ {
+ gfc_error ("First argument of operator interface at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
if (args == 2 && i2 != INTENT_IN)
- gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
+ {
+ gfc_error ("Second argument of operator interface at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
}
/* From now on, all we have to do is check that the operator definition
((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
/* Unary ops are easy, do them first. */
- if (operator == INTRINSIC_NOT)
+ if (op == INTRINSIC_NOT)
{
if (t1 == BT_LOGICAL)
goto bad_repl;
else
- return;
+ return true;
}
- if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
+ if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
{
if (IS_NUMERIC_TYPE (t1))
goto bad_repl;
else
- return;
+ return true;
}
/* Character intrinsic operators have same character kind, thus
operator definitions with operands of different character kinds
are always safe. */
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
- return;
+ return true;
/* Intrinsic operators always perform on arguments of same rank,
so different ranks is also always safe. (rank == 0) is an exception
to that, because all intrinsic operators are elemental. */
if (r1 != r2 && r1 != 0 && r2 != 0)
- return;
+ return true;
- switch (operator)
+ switch (op)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
break;
}
- return;
+ return true;
#undef IS_NUMERIC_TYPE
bad_repl:
gfc_error ("Operator interface at %L conflicts with intrinsic interface",
- &intr->where);
- return;
+ &opwhere);
+ return false;
}
Since this test is asymmetric, it has to be called twice to make it
symmetric. Returns nonzero if the argument lists are incompatible
by this test. This subroutine implements rule 1 of section
- 14.1.2.3. */
+ 14.1.2.3 in the Fortran 95 standard. */
static int
count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
/* Build an array of integers that gives the same integer to
arguments of the same type/rank. */
- arg = gfc_getmem (n1 * sizeof (arginfo));
+ arg = XCNEWVEC (arginfo, n1);
f = f1;
for (i = 0; i < n1; i++, f = f->next)
}
-/* Perform the abbreviated correspondence test for operators. The
- arguments cannot be optional and are always ordered correctly,
- which makes this test much easier than that for generic tests.
-
- This subroutine is also used when comparing a formal and actual
- argument list when an actual parameter is a dummy procedure. At
- that point, two formal interfaces must be compared for equality
- which is what happens here. */
-
-static int
-operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
-{
- for (;;)
- {
- if (f1 == NULL && f2 == NULL)
- break;
- if (f1 == NULL || f2 == NULL)
- return 1;
-
- if (!compare_type_rank (f1->sym, f2->sym))
- return 1;
-
- f1 = f1->next;
- f2 = f2->next;
- }
-
- return 0;
-}
-
-
/* Perform the correspondence test in rule 2 of section 14.1.2.3.
Returns zero if no argument is found that satisfies rule 2, nonzero
otherwise.
/* 'Compare' two formal interfaces associated with a pair of symbols.
We return nonzero if there exists an actual argument list that
- would be ambiguous between the two interfaces, zero otherwise. */
+ would be ambiguous between the two interfaces, zero otherwise.
+ 'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
+ required to match, which is not the case for ambiguity checks.*/
-static int
-compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+int
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
+ int generic_flag, int intent_flag,
+ char *errmsg, int err_len)
{
gfc_formal_arglist *f1, *f2;
- if (s1->attr.function != s2->attr.function
- && s1->attr.subroutine != s2->attr.subroutine)
- return 0; /* Disagreement between function/subroutine. */
+ 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 (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' is not a function", name2);
+ return 0;
+ }
+
+ if (s1->attr.subroutine && s2->attr.function)
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
+ return 0;
+ }
+
+ /* If the arguments are functions, check type and kind
+ (only for dummy procedures and procedure pointer assignments). */
+ if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
+ {
+ if (s1->ts.type == BT_UNKNOWN)
+ return 1;
+ if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Type/kind mismatch in return value "
+ "of '%s'", name2);
+ return 0;
+ }
+ }
+
+ if (s1->attr.if_source == IFSRC_UNKNOWN
+ || s2->attr.if_source == IFSRC_UNKNOWN)
+ return 1;
f1 = s1->formal;
f2 = s2->formal;
if (f1 == NULL && f2 == NULL)
- return 1; /* Special case. */
-
- if (count_types_test (f1, f2))
- return 0;
- if (count_types_test (f2, f1))
- return 0;
+ return 1; /* Special case: No arguments. */
if (generic_flag)
{
- if (generic_correspondence (f1, f2))
+ if (count_types_test (f1, f2) || count_types_test (f2, f1))
return 0;
- if (generic_correspondence (f2, f1))
+ if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
return 0;
}
else
- {
- if (operator_correspondence (f1, f2))
- return 0;
- }
+ /* Perform the abbreviated correspondence test for operators (the
+ arguments cannot be optional and are always ordered correctly).
+ This is also done when comparing interfaces for dummy procedures and in
+ procedure pointer assignments. */
+
+ for (;;)
+ {
+ /* Check existence. */
+ if (f1 == NULL && f2 == NULL)
+ break;
+ if (f1 == NULL || f2 == NULL)
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "'%s' has the wrong number of "
+ "arguments", name2);
+ return 0;
+ }
+
+ /* Check type and rank. */
+ if (!compare_type_rank (f1->sym, f2->sym))
+ {
+ if (errmsg != NULL)
+ snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ /* Check INTENT. */
+ if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
+ {
+ snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ /* Check OPTIONAL. */
+ if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
+ {
+ snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+ f1->sym->name);
+ return 0;
+ }
+
+ f1 = f1->next;
+ f2 = f2->next;
+ }
return 1;
}
/* 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)
+ if ((!p->sym->attr.function && !p->sym->attr.subroutine)
+ || !p->sym->attr.if_source)
{
- gfc_error ("Procedure '%s' in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ 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;
}
p = psave;
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (compare_interfaces (p->sym, q->sym, generic_flag))
+ 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)
for (p = sym->generic; p; p = p->next)
{
- if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
- && p->sym->attr.if_source != IFSRC_DECL)
+ if (p->sym->attr.mod_proc
+ && (p->sym->attr.if_source != IFSRC_DECL
+ || p->sym->attr.procedure))
{
- gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
- "from a module", p->sym->name, &p->where);
+ gfc_error ("'%s' at %L is not a module procedure",
+ p->sym->name, &p->where);
return;
}
}
/* 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);
}
}
gfc_namespace *ns;
sprintf (interface_name, "operator interface '%s'", uop->name);
- if (check_interface0 (uop->operator, interface_name))
+ if (check_interface0 (uop->op, interface_name))
return;
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (uop2 == NULL)
continue;
- check_interface1 (uop->operator, uop2->operator, 0,
+ check_interface1 (uop->op, uop2->op, 0,
interface_name, true);
}
}
{
gfc_namespace *old_ns, *ns2;
char interface_name[100];
- gfc_intrinsic_op i;
+ int i;
old_ns = gfc_current_ns;
gfc_current_ns = ns;
strcpy (interface_name, "intrinsic assignment operator");
else
sprintf (interface_name, "intrinsic '%s' operator",
- gfc_op2string (i));
+ gfc_op2string ((gfc_intrinsic_op) i));
- if (check_interface0 (ns->operator[i], interface_name))
+ if (check_interface0 (ns->op[i], interface_name))
continue;
- check_operator_interface (ns->operator[i], i);
+ if (ns->op[i])
+ gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+ ns->op[i]->where);
for (ns2 = ns; ns2; ns2 = ns2->parent)
{
- if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
+ if (check_interface1 (ns->op[i], ns2->op[i], 0,
interface_name, true))
goto done;
switch (i)
{
case INTRINSIC_EQ:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_EQ_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
0, interface_name, true)) goto done;
break;
case INTRINSIC_NE:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_NE_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GT:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GT_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GE:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_GE_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LT:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LT_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LE:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
0, interface_name, true)) goto done;
break;
case INTRINSIC_LE_OS:
- if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
+ if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
0, interface_name, true)) goto done;
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. */
static int
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
- int ranks_must_agree, int is_elemental)
+ int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
+ bool rank_check;
/* 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
return 1;
if (formal->ts.type == BT_DERIVED
- && formal->ts.derived && formal->ts.derived->ts.is_iso_c
+ && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
&& actual->ts.type == BT_DERIVED
- && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
+ && 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];
+ gfc_symbol *act_sym = actual->symtree->n.sym;
+
if (formal->attr.flavor != FL_PROCEDURE)
- return 0;
+ {
+ if (where)
+ gfc_error ("Invalid procedure argument at %L", &actual->where);
+ return 0;
+ }
- if (formal->attr.function
- && !compare_type_rank (formal, actual->symtree->n.sym))
- return 0;
+ if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
+ sizeof(err)))
+ {
+ if (where)
+ gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
+ formal->name, &actual->where, err);
+ return 0;
+ }
- if (formal->attr.if_source == IFSRC_UNKNOWN
- || actual->symtree->n.sym->attr.external)
- return 1; /* Assume match. */
+ if (formal->attr.function && !act_sym->attr.function)
+ {
+ gfc_add_function (&act_sym->attr, act_sym->name,
+ &act_sym->declared_at);
+ if (act_sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
+ return 0;
+ }
+ else if (formal->attr.subroutine && !act_sym->attr.subroutine)
+ gfc_add_subroutine (&act_sym->attr, act_sym->name,
+ &act_sym->declared_at);
- return compare_interfaces (formal, actual->symtree->n.sym, 0);
+ 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))
- return 0;
-
- if (symbol_rank (formal) == actual->rank)
- return 1;
-
- /* At this point the ranks didn't agree. */
- if (ranks_must_agree || formal->attr.pointer)
- return 0;
-
- if (actual->rank != 0)
- return is_elemental || formal->attr.dimension;
+ {
+ if (where)
+ gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
+ formal->name, &actual->where, gfc_typename (&actual->ts),
+ gfc_typename (&formal->ts));
+ return 0;
+ }
- /* At this point, we are considering a scalar passed to an array.
- This is legal if the scalar is an array element of the right sort. */
- if (formal->as->type == AS_ASSUMED_SHAPE)
- return 0;
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
- for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_SUBSTRING)
- return 0;
+ 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.type == AR_ELEMENT)
- break;
+ 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 (ref == NULL)
- return 0; /* Not an array element. */
+ 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;
+ }
- return 1;
-}
+ /* 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;
+ }
+ }
-/* 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. */
+ /* 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;
+ }
-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
- if (actual->expr_type != EXPR_VARIABLE)
+ if (symbol_rank (formal) == actual->rank)
return 1;
- if (!actual->symtree->n.sym->attr.protected)
+ rank_check = where != NULL && !is_elemental && formal->as
+ && (formal->as->type == AS_ASSUMED_SHAPE
+ || formal->as->type == AS_DEFERRED)
+ && actual->expr_type != EXPR_NULL;
+
+ /* 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->expr_type != EXPR_NULL)
+ || (actual->rank == 0 && formal->attr.dimension
+ && gfc_is_coindexed (actual)))
+ {
+ if (where)
+ 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;
- if (!actual->symtree->n.sym->attr.use_assoc)
- 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),
+ - 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. */
- if (formal->attr.intent == INTENT_IN
- || formal->attr.intent == INTENT_UNKNOWN)
- return 1;
+ for (ref = actual->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0)
+ break;
- if (!actual->symtree->n.sym->attr.pointer)
- return 0;
+ /* 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 (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+ {
+ gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
+ "array dummy argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
+ }
+ else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+ return 0;
+ else
+ return 1;
+ }
+ else if (ref == NULL && actual->expr_type != EXPR_NULL)
+ {
+ if (where)
+ argument_rank_mismatch (formal->name, &actual->where,
+ symbol_rank (formal), actual->rank);
+ return 0;
+ }
- if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
- 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 (where)
+ gfc_error ("Element of assumed-shaped array passed to dummy "
+ "argument '%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
return 1;
}
if (sym->ts.type == BT_CHARACTER)
{
- if (sym->ts.cl && sym->ts.cl->length
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
- strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
+ if (sym->ts.u.cl && sym->ts.u.cl->length
+ && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
else
return 0;
}
|| 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;
{
int i;
long int strlen, elements;
+ long int substrlen = 0;
+ bool is_str_storage = false;
gfc_ref *ref;
if (e == NULL)
if (e->ts.type == BT_CHARACTER)
{
- if (e->ts.cl && e->ts.cl->length
- && e->ts.cl->length->expr_type == EXPR_CONSTANT)
- strlen = mpz_get_si (e->ts.cl->length->value.integer);
+ if (e->ts.u.cl && e->ts.u.cl->length
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+ strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
else if (e->expr_type == EXPR_CONSTANT
- && (e->ts.cl == NULL || e->ts.cl->length == NULL))
+ && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
strlen = e->value.character.length;
else
return 0;
for (ref = e->ref; ref; ref = ref->next)
{
+ if (ref->type == REF_SUBSTRING && ref->u.ss.start
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT)
+ {
+ if (is_str_storage)
+ {
+ /* The string length is the substring length.
+ Set now to full string length. */
+ if (ref->u.ss.length == NULL
+ || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+ }
+ substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+ continue;
+ }
+
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
&& ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
&& ref->u.ar.as->upper)
if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
- elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
- - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
+ elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ 1L;
else
return 0;
}
+ 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
+ || e->symtree->n.sym->attr.pointer)
+ {
+ elements = 1;
+ continue;
+ }
+
+ /* Determine the number of remaining elements in the element
+ sequence for array element designators. */
+ is_str_storage = true;
+ for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+ {
+ if (ref->u.ar.start[i] == NULL
+ || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->upper[i] == NULL
+ || ref->u.ar.as->lower[i] == NULL
+ || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ elements
+ = elements
+ * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ + 1L)
+ - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+ }
+ }
else
- /* TODO: Determine the number of remaining elements in the element
- sequence for array element designators.
- See also get_array_index in data.c. */
return 0;
}
- return elements*strlen;
+ if (substrlen)
+ return (is_str_storage) ? substrlen + (elements-1)*strlen
+ : elements*strlen;
+ else
+ return elements*strlen;
}
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;
static int
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
- int ranks_must_agree, int is_elemental, locus *where)
+ int ranks_must_agree, int is_elemental, locus *where)
{
- gfc_actual_arglist **new, *a, *actual, temp;
+ gfc_actual_arglist **new_arg, *a, *actual, temp;
gfc_formal_arglist *f;
int i, n, na;
- bool rank_check;
unsigned long actual_size, formal_size;
actual = *ap;
for (f = formal; f; f = f->next)
n++;
- new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
+ new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
for (i = 0; i < n; i++)
- new[i] = NULL;
+ new_arg[i] = NULL;
na = 0;
f = formal;
return 0;
}
- if (new[i] != NULL)
+ if (new_arg[i] != NULL)
{
if (where)
gfc_error ("Keyword argument '%s' at %L is already associated "
return 0;
}
- rank_check = where != NULL && !is_elemental && f->sym->as
- && (f->sym->as->type == AS_ASSUMED_SHAPE
- || f->sym->as->type == AS_DEFERRED);
-
- if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
- && a->expr->rank == 0
- && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
+ 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 && (gfc_option.allow_std & GFC_STD_F2003) == 0)
- {
- gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
- "with array dummy argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
- else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
- return 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);
- }
- else if (!compare_parameter (f->sym, a->expr,
- ranks_must_agree || rank_check, is_elemental))
- {
- if (where)
- gfc_error ("Type/rank mismatch in argument '%s' at %L",
- f->sym->name, &a->expr->where);
return 0;
}
+
+ if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+ is_elemental, where))
+ return 0;
+ /* Special case for character arguments. For allocatable, pointer
+ and assumed-shape dummies, the string length needs to match
+ exactly. */
if (a->expr->ts.type == BT_CHARACTER
- && a->expr->ts.cl && a->expr->ts.cl->length
- && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
- && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
- && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+ && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
+ && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && (f->sym->attr.pointer || f->sym->attr.allocatable
+ || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+ && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
+ f->sym->ts.u.cl->length->value.integer) != 0))
{
- if ((f->sym->attr.pointer || f->sym->attr.allocatable)
- && (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) != 0))
- {
- if (where)
- gfc_warning ("Character length mismatch between actual "
- "argument and pointer or allocatable dummy "
- "argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
+ if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+ gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+ "argument and pointer or allocatable dummy argument "
+ "'%s' at %L",
+ mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+ f->sym->name, &a->expr->where);
+ else if (where)
+ gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+ "argument and assumed-shape dummy argument '%s' "
+ "at %L",
+ mpz_get_si (a->expr->ts.u.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.u.cl->length->value.integer),
+ f->sym->name, &a->expr->where);
+ 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)
+ if (actual_size != 0
+ && actual_size < formal_size
+ && a->expr->ts.type != BT_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
gfc_warning ("Character length of actual argument shorter "
return 0;
}
+ /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+ is provided for a procedure pointer formal argument. */
+ if (f->sym->attr.proc_pointer
+ && !((a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym->attr.proc_pointer)
+ || (a->expr->expr_type == EXPR_FUNCTION
+ && a->expr->symtree->n.sym->result->attr.proc_pointer)
+ || gfc_is_proc_ptr_comp (a->expr, NULL)))
+ {
+ if (where)
+ gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
- if (a->expr->ts.type != BT_PROCEDURE
+ if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
&& a->expr->expr_type == EXPR_VARIABLE
&& f->sym->attr.flavor == FL_PROCEDURE)
{
}
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
- && (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 to "
- "match dummy INTENT = OUT/INOUT", &a->expr->where);
+ 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(IN), 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 (a == actual)
na = i;
- new[i++] = a;
+ new_arg[i++] = a;
}
/* Make sure missing actual arguments are optional. */
i = 0;
for (f = formal; f; f = f->next, i++)
{
- if (new[i] != NULL)
+ if (new_arg[i] != NULL)
continue;
if (f->sym == NULL)
{
argument list with null arguments in the right places. The head
of the list remains the head. */
for (i = 0; i < n; i++)
- if (new[i] == NULL)
- new[i] = gfc_get_actual_arglist ();
+ if (new_arg[i] == NULL)
+ new_arg[i] = gfc_get_actual_arglist ();
if (na != 0)
{
- temp = *new[0];
- *new[0] = *actual;
+ temp = *new_arg[0];
+ *new_arg[0] = *actual;
*actual = temp;
- a = new[0];
- new[0] = new[na];
- new[na] = a;
+ a = new_arg[0];
+ new_arg[0] = new_arg[na];
+ new_arg[na] = a;
}
for (i = 0; i < n - 1; i++)
- new[i]->next = new[i + 1];
+ new_arg[i]->next = new_arg[i + 1];
- new[i]->next = NULL;
+ new_arg[i]->next = NULL;
if (*ap == NULL && n > 0)
- *ap = new[0];
+ *ap = new_arg[0];
/* Note the types of omitted optional arguments. */
- for (a = actual, f = formal; a; a = a->next, f = f->next)
+ for (a = *ap, f = formal; a; a = a->next, f = f->next)
if (a->expr == NULL && a->label == NULL)
a->missing_arg_type = f->sym->ts.type;
refer to the same expression. The analysis is conservative.
Returning FAILURE will produce no warning. */
-static try
+static gfc_try
compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
-static try
+static gfc_try
check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
gfc_actual_arglist *a1;
size_t n, i, j;
argpair *p;
- try t = SUCCESS;
+ gfc_try t = SUCCESS;
n = 0;
for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
}
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)
{
another, check that they are compatible in the sense that intents
are not mismatched. */
-static try
+static gfc_try
check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f_intent;
return FAILURE;
}
- if (a->expr->symtree->n.sym->attr.pointer)
+ if (f->sym->attr.pointer)
{
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
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_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
- /* Warn about calls with an implicit interface. */
- if (gfc_option.warn_implicit_interface
- && sym->attr.if_source == IFSRC_UNKNOWN)
- gfc_warning ("Procedure '%s' called with an implicit interface at %L",
- sym->name, where);
+ /* Warn about calls with an implicit interface. Special case
+ for calling a ISO_C_BINDING becase c_loc and c_funloc
+ are pseudo-unknown. Additionally, warn about procedures not
+ explicitly declared at all if requested. */
+ if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
+ {
+ if (gfc_option.warn_implicit_interface)
+ gfc_warning ("Procedure '%s' called with an implicit interface at %L",
+ sym->name, where);
+ else if (gfc_option.warn_implicit_procedure
+ && sym->attr.proc == PROC_UNKNOWN)
+ gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
+ sym->name, where);
+ }
+
+ if (sym->attr.if_source == IFSRC_UNKNOWN)
+ {
+ gfc_actual_arglist *a;
+ for (a = *ap; a; a = a->next)
+ {
+ /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
+ if (a->name != NULL && a->name[0] != '%')
+ {
+ gfc_error("Keyword argument requires explicit interface "
+ "for procedure '%s' at %L", sym->name, &a->expr->where);
+ break;
+ }
+ }
+
+ return;
+ }
- if (sym->attr.if_source == IFSRC_UNKNOWN
- || !compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, where))
+ if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
return;
check_intents (sym->formal, *ap);
}
+/* Check how a procedure pointer component is used against its interface.
+ If all goes well, the actual argument list will also end up being properly
+ sorted. Completely analogous to gfc_procedure_use. */
+
+void
+gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
+{
+
+ /* Warn about calls with an implicit interface. Special case
+ for calling a ISO_C_BINDING becase c_loc and c_funloc
+ are pseudo-unknown. */
+ if (gfc_option.warn_implicit_interface
+ && comp->attr.if_source == IFSRC_UNKNOWN
+ && !comp->attr.is_iso_c)
+ gfc_warning ("Procedure pointer component '%s' called with an implicit "
+ "interface at %L", comp->name, where);
+
+ if (comp->attr.if_source == IFSRC_UNKNOWN)
+ {
+ gfc_actual_arglist *a;
+ for (a = *ap; a; a = a->next)
+ {
+ /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
+ if (a->name != NULL && a->name[0] != '%')
+ {
+ gfc_error("Keyword argument requires explicit interface "
+ "for procedure pointer component '%s' at %L",
+ comp->name, &a->expr->where);
+ break;
+ }
+ }
+
+ return;
+ }
+
+ if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
+ return;
+
+ check_intents (comp->formal, *ap);
+ if (gfc_option.warn_aliasing)
+ check_some_aliasing (comp->formal, *ap);
+}
+
+
+/* Try if an actual argument list matches the formal list of a symbol,
+ respecting the symbol's attributes like ELEMENTAL. This is used for
+ GENERIC resolution. */
+
+bool
+gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
+{
+ bool r;
+
+ gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+
+ r = !sym->attr.elemental;
+ if (compare_actual_formal (args, sym->formal, r, !r, NULL))
+ {
+ check_intents (sym->formal, *args);
+ if (gfc_option.warn_aliasing)
+ check_some_aliasing (sym->formal, *args);
+ return true;
+ }
+
+ return false;
+}
+
+
/* Given an interface pointer and an actual argument list, search for
a formal argument list that matches the actual. If found, returns
a pointer to the symbol of the correct interface. Returns NULL if
gfc_search_interface (gfc_interface *intr, int sub_flag,
gfc_actual_arglist **ap)
{
- int r;
-
+ gfc_symbol *elem_sym = NULL;
for (; intr; intr = intr->next)
{
if (sub_flag && intr->sym->attr.function)
if (!sub_flag && intr->sym->attr.subroutine)
continue;
- r = !intr->sym->attr.elemental;
-
- if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
+ if (gfc_arglist_matches_symbol (ap, intr->sym))
{
- check_intents (intr->sym->formal, *ap);
- if (gfc_option.warn_aliasing)
- check_some_aliasing (intr->sym->formal, *ap);
+ /* Satisfy 12.4.4.1 such that an elemental match has lower
+ weight than a non-elemental match. */
+ if (intr->sym->attr.elemental)
+ {
+ elem_sym = intr->sym;
+ continue;
+ }
return intr->sym;
}
}
- return NULL;
+ return elem_sym ? elem_sym : NULL;
}
/* Find a symtree for a symbol. */
-static gfc_symtree *
-find_sym_in_symtree (gfc_symbol *sym)
+gfc_symtree *
+gfc_find_sym_in_symtree (gfc_symbol *sym)
{
gfc_symtree *st;
gfc_namespace *ns;
}
+/* 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). 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,
+ const char ** gname)
+{
+ gfc_actual_arglist* base;
+
+ for (base = args; base; base = base->next)
+ if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
+ {
+ gfc_typebound_proc* tb;
+ gfc_symbol* derived;
+ gfc_try result;
+
+ if (base->expr->ts.type == BT_CLASS)
+ derived = CLASS_DATA (base->expr)->ts.u.derived;
+ else
+ derived = base->expr->ts.u.derived;
+
+ if (op == INTRINSIC_USER)
+ {
+ gfc_symtree* tb_uop;
+
+ gcc_assert (uop);
+ tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
+ false, NULL);
+
+ if (tb_uop)
+ tb = tb_uop->n.tb;
+ else
+ tb = NULL;
+ }
+ else
+ tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
+ false, NULL);
+
+ /* This means we hit a PRIVATE operator which is use-associated and
+ should thus not be seen. */
+ if (result == FAILURE)
+ tb = NULL;
+
+ /* Look through the super-type hierarchy for a matching specific
+ binding. */
+ for (; tb; tb = tb->overridden)
+ {
+ gfc_tbp_generic* g;
+
+ gcc_assert (tb->is_generic);
+ for (g = tb->u.generic; g; g = g->next)
+ {
+ gfc_symbol* target;
+ gfc_actual_arglist* argcopy;
+ bool matches;
+
+ gcc_assert (g->specific);
+ if (g->specific->error)
+ continue;
+
+ target = g->specific->u.specific->n.sym;
+
+ /* Check if this arglist matches the formal. */
+ argcopy = gfc_copy_actual_arglist (args);
+ matches = gfc_arglist_matches_symbol (&argcopy, target);
+ gfc_free_actual_arglist (argcopy);
+
+ /* Return if we found a match. */
+ if (matches)
+ {
+ *tb_base = base->expr;
+ *gname = g->specific_st->name;
+ return g->specific;
+ }
+ }
+ }
+ }
+
+ return NULL;
+}
+
+
+/* For the 'actual arglist' of an operator call and a specific typebound
+ procedure that has been found the target of a type-bound operator, build the
+ appropriate EXPR_COMPCALL and resolve it. We take this indirection over
+ type-bound procedures rather than resolving type-bound operators 'directly'
+ so that we can reuse the existing logic. */
+
+static void
+build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
+ gfc_expr* base, gfc_typebound_proc* target,
+ const char *gname)
+{
+ e->expr_type = EXPR_COMPCALL;
+ e->value.compcall.tbp = target;
+ e->value.compcall.name = gname ? gname : "$op";
+ e->value.compcall.actual = actual;
+ e->value.compcall.base_object = base;
+ e->value.compcall.ignore_pass = 1;
+ e->value.compcall.assign = 0;
+}
+
+
/* This subroutine is called when an expression is being resolved.
The expression node in question is either a user defined operator
or an intrinsic operator with arguments that aren't compatible
with the operator. This subroutine builds an actual argument list
corresponding to the operands, then searches for a compatible
interface. If one is found, the expression node is replaced with
- the appropriate function call. */
+ the appropriate function call.
+ real_error is an additional output argument that specifies if FAILURE
+ is because of some real error and not because no match was found. */
-try
-gfc_extend_expr (gfc_expr *e)
+gfc_try
+gfc_extend_expr (gfc_expr *e, bool *real_error)
{
gfc_actual_arglist *actual;
gfc_symbol *sym;
gfc_namespace *ns;
gfc_user_op *uop;
gfc_intrinsic_op i;
+ const char *gname;
sym = NULL;
actual = gfc_get_actual_arglist ();
actual->expr = e->value.op.op1;
+ *real_error = false;
+ gname = NULL;
+
if (e->value.op.op2 != NULL)
{
actual->next = gfc_get_actual_arglist ();
actual->next->expr = e->value.op.op2;
}
- i = fold_unary (e->value.op.operator);
+ i = fold_unary_intrinsic (e->value.op.op);
if (i == INTRINSIC_USER)
{
if (uop == NULL)
continue;
- sym = gfc_search_interface (uop->operator, 0, &actual);
+ sym = gfc_search_interface (uop->op, 0, &actual);
if (sym != NULL)
break;
}
to check if either is defined. */
switch (i)
{
- case INTRINSIC_EQ:
- case INTRINSIC_EQ_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
- break;
-
- case INTRINSIC_NE:
- case INTRINSIC_NE_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
- break;
-
- case INTRINSIC_GT:
- case INTRINSIC_GT_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
- break;
-
- case INTRINSIC_GE:
- case INTRINSIC_GE_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
- break;
-
- case INTRINSIC_LT:
- case INTRINSIC_LT_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
- break;
-
- case INTRINSIC_LE:
- case INTRINSIC_LE_OS:
- sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
- if (sym == NULL)
- sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
- break;
+#define CHECK_OS_COMPARISON(comp) \
+ case INTRINSIC_##comp: \
+ case INTRINSIC_##comp##_OS: \
+ sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
+ if (!sym) \
+ sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
+ break;
+ CHECK_OS_COMPARISON(EQ)
+ CHECK_OS_COMPARISON(NE)
+ CHECK_OS_COMPARISON(GT)
+ CHECK_OS_COMPARISON(GE)
+ CHECK_OS_COMPARISON(LT)
+ CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
default:
- sym = gfc_search_interface (ns->operator[i], 0, &actual);
+ sym = gfc_search_interface (ns->op[i], 0, &actual);
}
if (sym != NULL)
}
}
+ /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
+ found rather than just taking the first one and not checking further. */
+
if (sym == NULL)
{
+ gfc_typebound_proc* tbo;
+ gfc_expr* tb_base;
+
+ /* 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, &gname);
+ else
+ switch (i)
+ {
+#define CHECK_OS_COMPARISON(comp) \
+ case INTRINSIC_##comp: \
+ case INTRINSIC_##comp##_OS: \
+ tbo = matching_typebound_op (&tb_base, actual, \
+ INTRINSIC_##comp, NULL, &gname); \
+ if (!tbo) \
+ tbo = matching_typebound_op (&tb_base, actual, \
+ INTRINSIC_##comp##_OS, NULL, &gname); \
+ break;
+ CHECK_OS_COMPARISON(EQ)
+ CHECK_OS_COMPARISON(NE)
+ CHECK_OS_COMPARISON(GT)
+ CHECK_OS_COMPARISON(GE)
+ CHECK_OS_COMPARISON(LT)
+ CHECK_OS_COMPARISON(LE)
+#undef CHECK_OS_COMPARISON
+
+ default:
+ tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
+ break;
+ }
+
+ /* If there is a matching typebound-operator, replace the expression with
+ a call to it and succeed. */
+ if (tbo)
+ {
+ gfc_try result;
+
+ gcc_assert (tb_base);
+ build_compcall_for_operator (e, actual, tb_base, tbo, gname);
+
+ result = gfc_resolve_expr (e);
+ if (result == FAILURE)
+ *real_error = true;
+
+ return result;
+ }
+
/* Don't use gfc_free_actual_arglist(). */
if (actual->next != NULL)
gfc_free (actual->next);
/* Change the expression node to a function call. */
e->expr_type = EXPR_FUNCTION;
- e->symtree = find_sym_in_symtree (sym);
+ e->symtree = gfc_find_sym_in_symtree (sym);
e->value.function.actual = actual;
e->value.function.esym = NULL;
e->value.function.isym = NULL;
e->value.function.name = NULL;
+ e->user_operator = 1;
- if (gfc_pure (NULL) && !gfc_pure (sym))
+ if (gfc_resolve_expr (e) == FAILURE)
{
- gfc_error ("Function '%s' called in lieu of an operator at %L must "
- "be PURE", sym->name, &e->where);
+ *real_error = true;
return FAILURE;
}
- if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
-
return SUCCESS;
}
SUCCESS if the node was replaced. On FAILURE, no error is
generated. */
-try
+gfc_try
gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
gfc_symbol *sym;
+ const char *gname;
- lhs = c->expr;
+ gname = NULL;
+
+ lhs = c->expr1;
rhs = c->expr2;
/* Don't allow an intrinsic assignment to be replaced. */
- if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
+ if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
+ && (rhs->rank == 0 || rhs->rank == lhs->rank)
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
for (; ns; ns = ns->parent)
{
- sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
+ sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
if (sym != NULL)
break;
}
+ /* TODO: Ambiguity-check, see above for gfc_extend_expr. */
+
if (sym == NULL)
{
+ gfc_typebound_proc* tbo;
+ gfc_expr* tb_base;
+
+ /* See if we find a matching type-bound assignment. */
+ tbo = matching_typebound_op (&tb_base, actual,
+ INTRINSIC_ASSIGN, NULL, &gname);
+
+ /* If there is one, replace the expression with a call to it and
+ succeed. */
+ if (tbo)
+ {
+ gcc_assert (tb_base);
+ c->expr1 = gfc_get_expr ();
+ build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
+ c->expr1->value.compcall.assign = 1;
+ c->expr2 = NULL;
+ c->op = EXEC_COMPCALL;
+
+ /* c is resolved from the caller, so no need to do it here. */
+
+ return SUCCESS;
+ }
+
gfc_free (actual->next);
gfc_free (actual);
return FAILURE;
/* Replace the assignment with the call. */
c->op = EXEC_ASSIGN_CALL;
- c->symtree = find_sym_in_symtree (sym);
- c->expr = NULL;
+ c->symtree = gfc_find_sym_in_symtree (sym);
+ c->expr1 = NULL;
c->expr2 = NULL;
c->ext.actual = actual;
the given interface list. Ambiguity isn't checked yet since module
procedures can be present without interfaces. */
-static try
-check_new_interface (gfc_interface *base, gfc_symbol *new)
+static gfc_try
+check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
{
gfc_interface *ip;
for (ip = base; ip; ip = ip->next)
{
- if (ip->sym == new)
+ if (ip->sym == new_sym)
{
gfc_error ("Entity '%s' at %C is already present in the interface",
- new->name);
+ new_sym->name);
return FAILURE;
}
}
/* Add a symbol to the current interface. */
-try
-gfc_add_interface (gfc_symbol *new)
+gfc_try
+gfc_add_interface (gfc_symbol *new_sym)
{
gfc_interface **head, *intr;
gfc_namespace *ns;
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
return FAILURE;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
return FAILURE;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
- if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
return FAILURE;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
- if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
return FAILURE;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
return FAILURE;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
- check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
+ if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
+ check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
return FAILURE;
break;
default:
- if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
+ if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
return FAILURE;
}
- head = ¤t_interface.ns->operator[current_interface.op];
+ head = ¤t_interface.ns->op[current_interface.op];
break;
case INTERFACE_GENERIC:
if (sym == NULL)
continue;
- if (check_new_interface (sym->generic, new) == FAILURE)
+ if (check_new_interface (sym->generic, new_sym) == FAILURE)
return FAILURE;
}
break;
case INTERFACE_USER_OP:
- if (check_new_interface (current_interface.uop->operator, new)
+ if (check_new_interface (current_interface.uop->op, new_sym)
== FAILURE)
return FAILURE;
- head = ¤t_interface.uop->operator;
+ head = ¤t_interface.uop->op;
break;
default:
}
intr = gfc_get_interface ();
- intr->sym = new;
+ intr->sym = new_sym;
intr->where = gfc_current_locus;
intr->next = *head;
}
+gfc_interface *
+gfc_current_interface_head (void)
+{
+ switch (current_interface.type)
+ {
+ case INTERFACE_INTRINSIC_OP:
+ return current_interface.ns->op[current_interface.op];
+ break;
+
+ case INTERFACE_GENERIC:
+ return current_interface.sym->generic;
+ break;
+
+ case INTERFACE_USER_OP:
+ return current_interface.uop->op;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+void
+gfc_set_current_interface_head (gfc_interface *i)
+{
+ switch (current_interface.type)
+ {
+ case INTERFACE_INTRINSIC_OP:
+ current_interface.ns->op[current_interface.op] = i;
+ break;
+
+ case INTERFACE_GENERIC:
+ current_interface.sym->generic = i;
+ break;
+
+ case INTERFACE_USER_OP:
+ current_interface.uop->op = i;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
/* Gets rid of a formal argument list. We do not free symbols.
Symbols are freed when a namespace is freed. */