/* Deal with interfaces.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
- Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* Deal with interfaces. An explicit interface is represented as a
#include "gfortran.h"
#include "match.h"
-
/* The current_interface structure holds information about the
interface currently being parsed. This structure is saved and
restored during recursive interfaces. */
/* Free a singly linked list of gfc_interface structures. */
void
-gfc_free_interface (gfc_interface * intr)
+gfc_free_interface (gfc_interface *intr)
{
gfc_interface *next;
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,
+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);
}
-/* Match one of the five forms of an interface statement. */
+/* Match one of the five F95 forms of an interface statement. The
+ matcher for the abstract interface follows. */
match
gfc_match_interface (void)
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
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
- || (type != INTERFACE_NAMELESS
- && m != MATCH_YES))
+ || (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
- gfc_error
- ("Syntax error: Trailing garbage in INTERFACE statement at %C");
+ gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
+ "at %C");
return MATCH_ERROR;
}
break;
case INTERFACE_INTRINSIC_OP:
- current_interface.op = operator;
+ current_interface.op = op;
break;
case INTERFACE_NAMELESS:
+ case INTERFACE_ABSTRACT:
break;
}
}
+
+/* Match a F2003 abstract interface. */
+
+match
+gfc_match_abstract_interface (void)
+{
+ match m;
+
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ m = gfc_match_eos ();
+
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
+ return MATCH_ERROR;
+ }
+
+ current_interface.type = INTERFACE_ABSTRACT;
+
+ return m;
+}
+
+
/* Match the different sort of generic-specs that can be present after
the END INTERFACE itself. */
{
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
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
- || (type != INTERFACE_NAMELESS
- && m != MATCH_YES))
+ || (type != INTERFACE_NAMELESS && m != MATCH_YES))
{
- gfc_error
- ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
+ gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
+ "statement at %C");
return MATCH_ERROR;
}
switch (current_interface.type)
{
case INTERFACE_NAMELESS:
- if (type != current_interface.type)
+ case INTERFACE_ABSTRACT:
+ if (type != INTERFACE_NAMELESS)
{
gfc_error ("Expected a nameless interface at %C");
m = MATCH_ERROR;
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)
case INTERFACE_USER_OP:
/* Comparing the symbol node names is OK because only use-associated
- symbols can be renamed. */
+ symbols can be renamed. */
if (type != current_interface.type
|| strcmp (current_interface.uop->name, name) != 0)
{
recursing through gfc_compare_types for the components. */
int
-gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
+gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
{
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 (derived1->name, derived2->name) == 0
- && derived1 != NULL && derived2 != NULL
- && derived1->module != NULL && derived2->module != NULL
- && strcmp (derived1->module, derived2->module) == 0)
+ if (derived1 != NULL && derived2 != NULL
+ && strcmp (derived1->name, derived2->name) == 0
+ && derived1->module != NULL && derived2->module != NULL
+ && strcmp (derived1->module, derived2->module) == 0)
return 1;
/* Compare type via the rules of the standard. Both types must have
return 0;
if (derived1->component_access == ACCESS_PRIVATE
- || derived2->component_access == ACCESS_PRIVATE)
+ || derived2->component_access == ACCESS_PRIVATE)
return 0;
if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
if (strcmp (dt1->name, dt2->name) != 0)
return 0;
- if (dt1->pointer != dt2->pointer)
+ if (dt1->attr.access != dt2->attr.access)
+ return 0;
+
+ if (dt1->attr.pointer != dt2->attr.pointer)
+ return 0;
+
+ if (dt1->attr.dimension != dt2->attr.dimension)
+ return 0;
+
+ if (dt1->attr.allocatable != dt2->attr.allocatable)
return 0;
- if (dt1->dimension != dt2->dimension)
+ if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
- if (dt1->allocatable != dt2->allocatable)
+ /* 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 (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 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;
- 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;
dt1 = dt1->next;
return 1;
}
+
/* Compare two typespecs, recursively if necessary. */
int
-gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
-
- if (ts1->type != ts2->type)
+ /* See if one of the typespecs is a BT_VOID, which is what is being used
+ to allow the funcs like c_f_pointer to accept any pointer type.
+ TODO: Possibly should narrow this to just the one typespec coming in
+ that is for the formal arg, but oh well. */
+ if (ts1->type == BT_VOID || ts2->type == BT_VOID)
+ return 1;
+
+ 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);
}
zero otherwise. */
static int
-compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
+compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
{
int r1, r2;
r2 = (s2->as != NULL) ? s2->as->rank : 0;
if (r1 != r2)
- return 0; /* Ranks differ */
+ return 0; /* Ranks differ. */
return gfc_compare_types (&s1->ts, &s2->ts);
}
-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. */
static int
-compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
+compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
{
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;
if not found. */
static gfc_symbol *
-find_keyword_arg (const char *name, gfc_formal_arglist * f)
+find_keyword_arg (const char *name, gfc_formal_arglist *f)
{
-
for (; f; f = f->next)
if (strcmp (f->sym->name, name) == 0)
return f->sym;
/* 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;
+ int args, r1, r2, k1, k2;
- if (intr == NULL)
- return;
+ gcc_assert (sym);
args = 0;
t1 = t2 = BT_UNKNOWN;
i1 = i2 = INTENT_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;
+ 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;
+ t2 = fsym->ts.type;
+ i2 = fsym->attr.intent;
+ r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+ k2 = fsym->ts.kind;
}
args++;
}
- if (args == 0 || args > 2)
- goto num_args;
-
- sym = intr->sym;
+ /* Only +, - and .not. can be unary operators.
+ .not. cannot be a binary operator. */
+ 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",
+ &sym->declared_at);
+ return false;
+ }
- if (operator == INTRINSIC_ASSIGN)
+ /* Check that intrinsics are mapped to functions, except
+ INTRINSIC_ASSIGN which should map to a subroutine. */
+ if (op == INTRINSIC_ASSIGN)
{
if (!sym->attr.subroutine)
{
- gfc_error
- ("Assignment operator interface at %L must be a SUBROUTINE",
- &intr->where);
- return;
+ gfc_error ("Assignment operator interface at %L must be "
+ "a SUBROUTINE", &sym->declared_at);
+ return false;
}
if (args != 2)
{
- gfc_error
- ("Assignment operator interface at %L must have two arguments",
- &intr->where);
- return;
+ gfc_error ("Assignment operator interface at %L must have "
+ "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 == sym->formal->next->sym->ts.type
- || (gfc_numeric_ts (&sym->formal->sym->ts)
- && gfc_numeric_ts (&sym->formal->next->sym->ts))))
+ && 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;
+ gfc_error ("Assignment operator interface at %L must not redefine "
+ "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;
}
}
- switch (operator)
+ /* Check intents on operator interfaces. */
+ if (op == INTRINSIC_ASSIGN)
{
- case INTRINSIC_PLUS: /* Numeric unary or binary */
- case INTRINSIC_MINUS:
- if ((args == 1)
- && (t1 == BT_INTEGER
- || t1 == BT_REAL
- || t1 == BT_COMPLEX))
+ if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
+ {
+ 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)", &sym->declared_at);
+ return false;
+ }
+ }
+ else
+ {
+ if (i1 != INTENT_IN)
+ {
+ 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)", &sym->declared_at);
+ return false;
+ }
+ }
+
+ /* From now on, all we have to do is check that the operator definition
+ doesn't conflict with an intrinsic operator. The rules for this
+ game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
+ as well as 12.3.2.1.1 of Fortran 2003:
+
+ "If the operator is an intrinsic-operator (R310), the number of
+ function arguments shall be consistent with the intrinsic uses of
+ that operator, and the types, kind type parameters, or ranks of the
+ dummy arguments shall differ from those required for the intrinsic
+ operation (7.1.2)." */
+
+#define IS_NUMERIC_TYPE(t) \
+ ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
+
+ /* Unary ops are easy, do them first. */
+ if (op == INTRINSIC_NOT)
+ {
+ if (t1 == BT_LOGICAL)
goto bad_repl;
+ else
+ return true;
+ }
- if ((args == 2)
- && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
- && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
+ if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
+ {
+ if (IS_NUMERIC_TYPE (t1))
goto bad_repl;
+ else
+ return true;
+ }
- break;
+ /* 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 true;
- case INTRINSIC_POWER: /* Binary numeric */
- case INTRINSIC_TIMES:
- case INTRINSIC_DIVIDE:
+ /* 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 true;
+ switch (op)
+ {
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
- if (args == 1)
- goto num_args;
-
- if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
- && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
+ case INTRINSIC_NE_OS:
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
+ /* Fall through. */
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_POWER:
+ if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
+ goto bad_repl;
break;
- case INTRINSIC_GE: /* Binary numeric operators that do not support */
- case INTRINSIC_LE: /* complex numbers */
- case INTRINSIC_LT:
case INTRINSIC_GT:
- if (args == 1)
- goto num_args;
-
+ case INTRINSIC_GT_OS:
+ case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
+ case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
+ case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+ goto bad_repl;
if ((t1 == BT_INTEGER || t1 == BT_REAL)
&& (t2 == BT_INTEGER || t2 == BT_REAL))
goto bad_repl;
+ break;
+ case INTRINSIC_CONCAT:
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+ goto bad_repl;
break;
- case INTRINSIC_OR: /* Binary logical */
case INTRINSIC_AND:
+ case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
- if (args == 1)
- goto num_args;
if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
goto bad_repl;
break;
- case INTRINSIC_NOT: /* Unary logical */
- if (args != 1)
- goto num_args;
- if (t1 == BT_LOGICAL)
- goto bad_repl;
- break;
-
- case INTRINSIC_CONCAT: /* Binary string */
- if (args != 2)
- goto num_args;
- if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
- goto bad_repl;
- break;
-
- case INTRINSIC_ASSIGN: /* Class by itself */
- if (args != 2)
- goto num_args;
- break;
default:
- gfc_internal_error ("check_operator_interface(): Bad operator");
- }
-
- /* Check intents on operator interfaces. */
- if (operator == 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);
-
- if (i2 != INTENT_IN)
- gfc_error ("Second argument of defined assignment at %L must be "
- "INTENT(IN)", &intr->where);
- }
- else
- {
- if (i1 != INTENT_IN)
- gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
+ break;
+ }
- if (args == 2 && i2 != INTENT_IN)
- gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
- }
+ return true;
- return;
+#undef IS_NUMERIC_TYPE
bad_repl:
gfc_error ("Operator interface at %L conflicts with intrinsic interface",
- &intr->where);
- return;
-
-num_args:
- gfc_error ("Operator interface at %L has the wrong number of arguments",
- &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)
+count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
int rc, ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
/* 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)
continue;
if (arg[i].sym && arg[i].sym->attr.optional)
- continue; /* Skip optional arguments */
+ continue; /* Skip optional arguments. */
arg[i].flag = k;
ac1++;
/* Count the number of arguments in f2 with that type, including
- those that are optional. */
+ those that are optional. */
ac2 = 0;
for (f = f2; f; 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.
INTERFACE FOO
SUBROUTINE F1(A, B)
- INTEGER :: A ; REAL :: B
+ INTEGER :: A ; REAL :: B
END SUBROUTINE F1
SUBROUTINE F2(B, A)
- INTEGER :: A ; REAL :: B
+ INTEGER :: A ; REAL :: B
END SUBROUTINE F1
END INTERFACE FOO
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
static int
-generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
+generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
{
-
gfc_formal_arglist *f2_save, *g;
gfc_symbol *sym;
goto next;
/* Now search for a disambiguating keyword argument starting at
- the current non-match. */
+ the current non-match. */
for (g = f1; g; g = g->next)
{
if (g->sym->attr.optional)
/* '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;
}
subroutines. Returns nonzero if something goes wrong. */
static int
-check_interface0 (gfc_interface * p, const char *interface_name)
+check_interface0 (gfc_interface *p, const char *interface_name)
{
gfc_interface *psave, *q, *qlast;
/* 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;
{
qlast = q;
q = q->next;
-
}
else
{
- /* Duplicate interface */
+ /* Duplicate interface. */
qlast->next = q->next;
gfc_free (q);
q = qlast->next;
/* Check lists of interfaces to make sure that no two interfaces are
- ambiguous. Duplicate interfaces (from the same symbol) are OK
- here. */
+ ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
static int
-check_interface1 (gfc_interface * p, gfc_interface * q0,
+check_interface1 (gfc_interface *p, gfc_interface *q0,
int generic_flag, const char *interface_name,
bool referenced)
{
- gfc_interface * q;
+ gfc_interface *q;
for (; p; p = p->next)
for (q = q0; q; q = q->next)
{
if (p->sym == q->sym)
- continue; /* Duplicates OK here */
+ continue; /* Duplicates OK here. */
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;
}
}
after all of the symbols are actually loaded. */
static void
-check_sym_interfaces (gfc_symbol * sym)
+check_sym_interfaces (gfc_symbol *sym)
{
char interface_name[100];
- bool k;
+ gfc_interface *p;
if (sym->ns != gfc_current_ns)
return;
if (check_interface0 (sym->generic, interface_name))
return;
- /* Originally, this test was aplied to host interfaces too;
+ for (p = sym->generic; p; p = p->next)
+ {
+ if (p->sym->attr.mod_proc
+ && (p->sym->attr.if_source != IFSRC_DECL
+ || p->sym->attr.procedure))
+ {
+ 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);
}
}
static void
-check_uop_interfaces (gfc_user_op * uop)
+check_uop_interfaces (gfc_user_op *uop)
{
char interface_name[100];
gfc_user_op *uop2;
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);
}
}
that most symbols will not have generic or operator interfaces. */
void
-gfc_check_interfaces (gfc_namespace * ns)
+gfc_check_interfaces (gfc_namespace *ns)
{
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->parent; ns2; ns2 = ns2->parent)
- if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
- interface_name, true))
- break;
+ for (ns2 = ns; ns2; ns2 = ns2->parent)
+ {
+ if (check_interface1 (ns->op[i], ns2->op[i], 0,
+ interface_name, true))
+ goto done;
+
+ switch (i)
+ {
+ case INTRINSIC_EQ:
+ 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->op[i], ns2->op[INTRINSIC_EQ],
+ 0, interface_name, true)) goto done;
+ break;
+
+ case INTRINSIC_NE:
+ 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->op[i], ns2->op[INTRINSIC_NE],
+ 0, interface_name, true)) goto done;
+ break;
+
+ case INTRINSIC_GT:
+ 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->op[i], ns2->op[INTRINSIC_GT],
+ 0, interface_name, true)) goto done;
+ break;
+
+ case INTRINSIC_GE:
+ 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->op[i], ns2->op[INTRINSIC_GE],
+ 0, interface_name, true)) goto done;
+ break;
+
+ case INTRINSIC_LT:
+ 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->op[i], ns2->op[INTRINSIC_LT],
+ 0, interface_name, true)) goto done;
+ break;
+
+ case INTRINSIC_LE:
+ 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->op[i], ns2->op[INTRINSIC_LE],
+ 0, interface_name, true)) goto done;
+ break;
+
+ default:
+ break;
+ }
+ }
}
+done:
gfc_current_ns = old_ns;
}
static int
-symbol_rank (gfc_symbol * sym)
+symbol_rank (gfc_symbol *sym)
{
-
return (sym->as == NULL) ? 0 : sym->as->rank;
}
allocatable. Returns nonzero if compatible, zero if not compatible. */
static int
-compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
+compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
pointer. Returns nonzero if compatible, zero if not compatible. */
static int
-compare_pointer (gfc_symbol * formal, gfc_expr * actual)
+compare_pointer (gfc_symbol *formal, gfc_expr *actual)
{
symbol_attribute attr;
compatible, zero if not compatible. */
static int
-compare_parameter (gfc_symbol * formal, gfc_expr * actual,
- int ranks_must_agree, int is_elemental)
+compare_parameter (gfc_symbol *formal, gfc_expr *actual,
+ 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
+ pointers the user could give us. This should allow that. */
+ if (formal->ts.type == BT_VOID)
+ return 1;
+
+ if (formal->ts.type == BT_DERIVED
+ && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
+ && actual->ts.type == BT_DERIVED
+ && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
+ return 1;
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;
}
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& !gfc_compare_types (&formal->ts, &actual->ts))
- return 0;
-
- if (symbol_rank (formal) == actual->rank)
- return 1;
+ {
+ 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 the ranks didn't agree. */
- if (ranks_must_agree || formal->attr.pointer)
- return 0;
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
- if (actual->rank != 0)
- return is_elemental || formal->attr.dimension;
+ 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;
+ }
- /* 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;
+ 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;
+ }
- for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_SUBSTRING)
+ if (last && !last->u.c.component->attr.codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
+ }
+
+ if (symbol_rank (formal) == actual->rank)
+ return 1;
+
+ rank_check = where != NULL && !is_elemental && formal->as
+ && (formal->as->type == AS_ASSUMED_SHAPE
+ || formal->as->type == AS_DEFERRED)
+ && 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->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);
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),
+ - 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. */
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0)
break;
- if (ref == NULL)
- return 0; /* Not an array element */
+ /* 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)
+ 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 (where)
+ gfc_error ("Element of assumed-shaped array passed to dummy "
+ "argument '%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
return 1;
}
compatible, zero if not compatible. */
static int
-compare_parameter_protected (gfc_symbol * formal, gfc_expr * actual)
+compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
{
if (actual->expr_type != EXPR_VARIABLE)
return 1;
- if (!actual->symtree->n.sym->attr.protected)
+ if (!actual->symtree->n.sym->attr.is_protected)
return 1;
if (!actual->symtree->n.sym->attr.use_assoc)
}
+/* Returns the storage size of a symbol (formal argument) or
+ zero if it cannot be determined. */
+
+static unsigned long
+get_sym_storage_size (gfc_symbol *sym)
+{
+ int i;
+ unsigned long strlen, elements;
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ 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;
+ }
+ else
+ strlen = 1;
+
+ if (symbol_rank (sym) == 0)
+ return strlen;
+
+ elements = 1;
+ if (sym->as->type != AS_EXPLICIT)
+ return 0;
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
+ || 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;
+ }
+
+ return strlen*elements;
+}
+
+
+/* Returns the storage size of an expression (actual argument) or
+ zero if it cannot be determined. For an array element, it returns
+ the remaining size as the element sequence consists of all storage
+ units of the actual argument up to the end of the array. */
+
+static unsigned long
+get_expr_storage_size (gfc_expr *e)
+{
+ int i;
+ long int strlen, elements;
+ long int substrlen = 0;
+ bool is_str_storage = false;
+ gfc_ref *ref;
+
+ if (e == NULL)
+ return 0;
+
+ if (e->ts.type == BT_CHARACTER)
+ {
+ 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.u.cl == NULL || e->ts.u.cl->length == NULL))
+ strlen = e->value.character.length;
+ else
+ return 0;
+ }
+ else
+ strlen = 1; /* Length per element. */
+
+ if (e->rank == 0 && !e->ref)
+ return strlen;
+
+ elements = 1;
+ if (!e->ref)
+ {
+ if (!e->shape)
+ return 0;
+ for (i = 0; i < e->rank; i++)
+ elements *= mpz_get_si (e->shape[i]);
+ return elements*strlen;
+ }
+
+ 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)
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ long int start, end, stride;
+ stride = 1;
+
+ if (ref->u.ar.stride[i])
+ {
+ if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
+ stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
+ else
+ return 0;
+ }
+
+ if (ref->u.ar.start[i])
+ {
+ if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
+ start = mpz_get_si (ref->u.ar.start[i]->value.integer);
+ else
+ return 0;
+ }
+ else if (ref->u.ar.as->lower[i]
+ && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
+ start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
+ else
+ return 0;
+
+ if (ref->u.ar.end[i])
+ {
+ if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
+ end = mpz_get_si (ref->u.ar.end[i]->value.integer);
+ else
+ return 0;
+ }
+ else if (ref->u.ar.as->upper[i]
+ && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
+ end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
+ else
+ return 0;
+
+ elements *= (end - start)/stride + 1L;
+ }
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
+ && ref->u.ar.as->lower && ref->u.ar.as->upper)
+ for (i = 0; i < ref->u.ar.as->rank; i++)
+ {
+ 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_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
+ return 0;
+ }
+
+ if (substrlen)
+ return (is_str_storage) ? substrlen + (elements-1)*strlen
+ : elements*strlen;
+ else
+ return elements*strlen;
+}
+
+
+/* Given an expression, check whether it is an array section
+ which has a vector subscript. If it has, one is returned,
+ otherwise zero. */
+
+static int
+has_vector_subscript (gfc_expr *e)
+{
+ int i;
+ gfc_ref *ref;
+
+ if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ return 1;
+
+ return 0;
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
code. */
static int
-compare_actual_formal (gfc_actual_arglist ** ap,
- gfc_formal_arglist * formal,
- int ranks_must_agree, int is_elemental, locus * where)
+compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+ 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;
- gfc_gsymbol *gsym;
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 = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
for (i = 0; i < n; i++)
- new[i] = NULL;
+ new_arg[i] = NULL;
na = 0;
f = formal;
for (a = actual; a; a = a->next, f = f->next)
{
- if (a->name != NULL)
+ /* Look for keywords but ignore g77 extensions like %VAL. */
+ if (a->name != NULL && a->name[0] != '%')
{
i = 0;
for (f = formal; f; f = f->next, i++)
if (f == NULL)
{
if (where)
- gfc_error
- ("Keyword argument '%s' at %L is not in the procedure",
- a->name, &a->expr->where);
+ gfc_error ("Keyword argument '%s' at %L is not in "
+ "the procedure", a->name, &a->expr->where);
return 0;
}
- if (new[i] != NULL)
+ if (new_arg[i] != NULL)
{
if (where)
- gfc_error
- ("Keyword argument '%s' at %L is already associated "
- "with another actual argument", a->name, &a->expr->where);
+ gfc_error ("Keyword argument '%s' at %L is already associated "
+ "with another actual argument", a->name,
+ &a->expr->where);
return 0;
}
}
if (f == NULL)
{
if (where)
- gfc_error
- ("More actual than formal arguments in procedure call at %L",
- where);
+ gfc_error ("More actual than formal arguments in procedure "
+ "call at %L", where);
return 0;
}
if (f->sym == NULL)
{
if (where)
- gfc_error
- ("Missing alternate return spec in subroutine call at %L",
- where);
+ gfc_error ("Missing alternate return spec in subroutine call "
+ "at %L", where);
return 0;
}
if (a->expr == NULL)
{
if (where)
- gfc_error
- ("Unexpected alternate return spec in subroutine call at %L",
- where);
+ gfc_error ("Unexpected alternate return spec in subroutine "
+ "call at %L", where);
return 0;
}
+
+ if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+ is_elemental, where))
+ return 0;
- rank_check = where != NULL
- && !is_elemental
- && f->sym->as
- && (f->sym->as->type == AS_ASSUMED_SHAPE
- || f->sym->as->type == AS_DEFERRED);
+ /* 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.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 (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
+ && 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 "
+ "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);
+ return 0;
+ }
- if (!compare_parameter
- (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
+ /* 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 ("Type/rank mismatch in argument '%s' at %L",
+ 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)
{
- gsym = gfc_find_gsymbol (gfc_gsym_root,
- a->expr->symtree->n.sym->name);
- if (gsym == NULL || (gsym->type != GSYM_FUNCTION
- && gsym->type != GSYM_SUBROUTINE))
- {
- if (where)
- gfc_error ("Expected a procedure for argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
+ if (where)
+ gfc_error ("Expected a procedure for argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
}
- if (f->sym->attr.flavor == FL_PROCEDURE
- && f->sym->attr.pure
- && a->expr->ts.type == BT_PROCEDURE
- && !a->expr->symtree->n.sym->attr.pure)
+ if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
+ && a->expr->ts.type == BT_PROCEDURE
+ && !a->expr->symtree->n.sym->attr.pure)
{
if (where)
gfc_error ("Expected a PURE procedure for argument '%s' at %L",
return 0;
}
- if (f->sym->as
- && f->sym->as->type == AS_ASSUMED_SHAPE
+ if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym->as
&& a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
return 0;
}
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to pointer "
+ "dummy '%s'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.5 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN
+ && f->sym->attr.allocatable
+ && gfc_is_coindexed (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L to allocatable "
+ "dummy '%s' requires INTENT(IN)",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, C1237. */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
+ && gfc_is_coindexed (a->expr)
+ && (a->expr->symtree->n.sym->attr.volatile_
+ || a->expr->symtree->n.sym->attr.asynchronous))
+ {
+ if (where)
+ gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
+ "at %L requires that dummy %s' has neither "
+ "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
+ f->sym->name);
+ return 0;
+ }
+
+ /* Fortran 2008, 12.5.2.4 (no constraint). */
+ if (a->expr->expr_type == EXPR_VARIABLE
+ && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
+ && gfc_is_coindexed (a->expr)
+ && gfc_has_ultimate_allocatable (a->expr))
+ {
+ if (where)
+ gfc_error ("Coindexed actual argument at %L with allocatable "
+ "ultimate component to dummy '%s' requires either VALUE "
+ "or INTENT(IN)", &a->expr->where, f->sym->name);
+ return 0;
+ }
+
if (a->expr->expr_type != EXPR_NULL
&& compare_allocatable (f->sym, a->expr) == 0)
{
}
/* 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))
+ 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 (where)
- gfc_error ("Actual argument at %L must be definable to "
- "match dummy INTENT = OUT/INOUT", &a->expr->where);
- return 0;
- }
+ 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;
+ }
if (!compare_parameter_protected(f->sym, a->expr))
{
"PROTECTED attribute and dummy argument '%s' is "
"INTENT = OUT/INOUT",
&a->expr->where,f->sym->name);
- return 0;
+ return 0;
+ }
+
+ if ((f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT
+ || f->sym->attr.volatile_)
+ && 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'",
+ &a->expr->where, f->sym->name);
+ return 0;
+ }
+
+ /* C1232 (R1221) For an actual argument which is an array section or
+ an assumed-shape array, the dummy argument shall be an assumed-
+ shape array, if the dummy argument has the VOLATILE attribute. */
+
+ if (f->sym->attr.volatile_
+ && a->expr->symtree->n.sym->as
+ && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+ {
+ if (where)
+ gfc_error ("Assumed-shape actual argument at %L is "
+ "incompatible with the non-assumed-shape "
+ "dummy argument '%s' due to VOLATILE attribute",
+ &a->expr->where,f->sym->name);
+ return 0;
+ }
+
+ if (f->sym->attr.volatile_
+ && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
+ && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
+ {
+ if (where)
+ gfc_error ("Array-section actual argument at %L is "
+ "incompatible with the non-assumed-shape "
+ "dummy argument '%s' due to VOLATILE attribute",
+ &a->expr->where,f->sym->name);
+ return 0;
+ }
+
+ /* C1233 (R1221) For an actual argument which is a pointer array, the
+ dummy argument shall be an assumed-shape or pointer array, if the
+ dummy argument has the VOLATILE attribute. */
+
+ if (f->sym->attr.volatile_
+ && a->expr->symtree->n.sym->attr.pointer
+ && a->expr->symtree->n.sym->as
+ && !(f->sym->as
+ && (f->sym->as->type == AS_ASSUMED_SHAPE
+ || f->sym->attr.pointer)))
+ {
+ if (where)
+ gfc_error ("Pointer-array actual argument at %L requires "
+ "an assumed-shape or pointer-array dummy "
+ "argument '%s' due to VOLATILE attribute",
+ &a->expr->where,f->sym->name);
+ return 0;
}
match:
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)
+ {
+ if (where)
+ gfc_error ("Missing alternate return spec in subroutine call "
+ "at %L", where);
+ return 0;
+ }
if (!f->sym->attr.optional)
{
if (where)
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
-compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
+static gfc_try
+compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
{
const gfc_ref *r1, *r2;
return FAILURE;
}
+
/* Given formal and actual argument lists that correspond to one
another, check that identical actual arguments aren't not
associated with some incompatible INTENTs. */
-static try
-check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
+static gfc_try
+check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
sym_intent f1_intent, f2_intent;
gfc_formal_arglist *f1;
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)
}
+/* Given a symbol of a formal argument list and an expression,
+ return nonzero if their intents are compatible, zero otherwise. */
+
+static int
+compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
+{
+ if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
+ return 1;
+
+ if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+ return 1;
+
+ if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
+ return 0;
+
+ return 1;
+}
+
+
/* Given formal and actual argument lists that correspond to one
another, check that they are compatible in the sense that intents
are not mismatched. */
-static try
-check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
+static gfc_try
+check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
{
- sym_intent a_intent, f_intent;
+ sym_intent f_intent;
for (;; f = f->next, a = a->next)
{
if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
continue;
- a_intent = a->expr->symtree->n.sym->attr.intent;
f_intent = f->sym->attr.intent;
- if (a_intent == INTENT_IN
- && (f_intent == INTENT_INOUT
- || f_intent == INTENT_OUT))
+ if (!compare_parameter_intent(f->sym, a->expr))
{
-
gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
"specifies INTENT(%s)", &a->expr->where,
gfc_intent_string (f_intent));
{
if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
{
- gfc_error
- ("Procedure argument at %L is local to a PURE procedure and "
- "is passed to an INTENT(%s) argument", &a->expr->where,
- gfc_intent_string (f_intent));
+ gfc_error ("Procedure argument at %L is local to a PURE "
+ "procedure and is passed to an INTENT(%s) argument",
+ &a->expr->where, gfc_intent_string (f_intent));
+ return FAILURE;
+ }
+
+ if (f->sym->attr.pointer)
+ {
+ gfc_error ("Procedure argument at %L is local to a PURE "
+ "procedure and has the POINTER attribute",
+ &a->expr->where);
+ 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 (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", &a->expr->where);
+ 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;
sorted. */
void
-gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
+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
- || !compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, 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 (!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
not found. */
gfc_symbol *
-gfc_search_interface (gfc_interface * intr, int sub_flag,
- gfc_actual_arglist ** ap)
+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;
}
/* Do a brute force recursive search for a symbol. */
static gfc_symtree *
-find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
+find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
{
gfc_symtree * st;
/* 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;
if (st && st->n.sym == sym)
return st;
- /* if it's been renamed, resort to a brute-force search. */
+ /* If it's been renamed, resort to a brute-force search. */
/* TODO: avoid having to do this search. If the symbol doesn't exist
in the symtree for the current namespace, it should probably be added. */
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
st = find_symtree0 (ns->sym_root, sym);
if (st)
- return st;
+ return st;
}
gfc_internal_error ("Unable to find symbol %s", sym->name);
- /* Not reached */
+ /* Not reached. */
+}
+
+
+/* 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). */
+
+static gfc_typebound_proc*
+matching_typebound_op (gfc_expr** tb_base,
+ gfc_actual_arglist* args,
+ gfc_intrinsic_op op, const char* uop)
+{
+ 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 = base->expr->ts.u.derived->components->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;
+ 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)
+{
+ e->expr_type = EXPR_COMPCALL;
+ e->value.compcall.tbp = target;
+ e->value.compcall.name = "operator"; /* Should not matter. */
+ e->value.compcall.actual = actual;
+ e->value.compcall.base_object = base;
+ e->value.compcall.ignore_pass = 1;
+ e->value.compcall.assign = 0;
}
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;
actual = gfc_get_actual_arglist ();
actual->expr = e->value.op.op1;
+ *real_error = false;
+
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;
}
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
- sym = gfc_search_interface (ns->operator[i], 0, &actual);
+ /* Due to the distinction between '==' and '.eq.' and friends, one has
+ to check if either is defined. */
+ switch (i)
+ {
+#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->op[i], 0, &actual);
+ }
+
if (sym != NULL)
break;
}
}
+ /* 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)
{
- /* Don't use gfc_free_actual_arglist() */
+ 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);
+ 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); \
+ if (!tbo) \
+ tbo = matching_typebound_op (&tb_base, actual, \
+ INTRINSIC_##comp##_OS, NULL); \
+ 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);
+ 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);
+
+ 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);
gfc_free (actual);
/* 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_extend_assign (gfc_code * c, gfc_namespace * ns)
+gfc_try
+gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
{
gfc_actual_arglist *actual;
gfc_expr *lhs, *rhs;
gfc_symbol *sym;
- lhs = c->expr;
+ 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))))
+ || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
actual = gfc_get_actual_arglist ();
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);
+
+ /* 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);
+ 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;
switch (current_interface.type)
{
case INTERFACE_NAMELESS:
+ case INTERFACE_ABSTRACT:
return SUCCESS;
case INTERFACE_INTRINSIC_OP:
for (ns = current_interface.ns; ns; ns = ns->parent)
- if (check_new_interface (ns->operator[current_interface.op], new)
- == FAILURE)
- return FAILURE;
+ switch (current_interface.op)
+ {
+ case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
+ 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->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->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->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->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->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->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) ==
- FAILURE)
+ 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. */
void
-gfc_free_formal_arglist (gfc_formal_arglist * p)
+gfc_free_formal_arglist (gfc_formal_arglist *p)
{
gfc_formal_arglist *q;
OSDN Git Service
