/* 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
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
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);
}
-/* 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
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
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)
- gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+ {
+ m = MATCH_ERROR;
+ gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+ }
else
- gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
- gfc_op2string (current_interface.op));
+ {
+ const char *s1, *s2;
+ s1 = gfc_op2string (current_interface.op);
+ s2 = gfc_op2string (op);
+
+ /* The following if-statements are used to enforce C1202
+ from F2003. */
+ if ((strcmp(s1, "==") == 0 && strcmp(s2, ".eq.") == 0)
+ || (strcmp(s1, ".eq.") == 0 && strcmp(s2, "==") == 0))
+ break;
+ if ((strcmp(s1, "/=") == 0 && strcmp(s2, ".ne.") == 0)
+ || (strcmp(s1, ".ne.") == 0 && strcmp(s2, "/=") == 0))
+ break;
+ if ((strcmp(s1, "<=") == 0 && strcmp(s2, ".le.") == 0)
+ || (strcmp(s1, ".le.") == 0 && strcmp(s2, "<=") == 0))
+ break;
+ if ((strcmp(s1, "<") == 0 && strcmp(s2, ".lt.") == 0)
+ || (strcmp(s1, ".lt.") == 0 && strcmp(s2, "<") == 0))
+ break;
+ if ((strcmp(s1, ">=") == 0 && strcmp(s2, ".ge.") == 0)
+ || (strcmp(s1, ".ge.") == 0 && strcmp(s2, ">=") == 0))
+ break;
+ if ((strcmp(s1, ">") == 0 && strcmp(s2, ".gt.") == 0)
+ || (strcmp(s1, ".gt.") == 0 && strcmp(s2, ">") == 0))
+ break;
- m = MATCH_ERROR;
+ m = MATCH_ERROR;
+ gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
+ "but got %s", s1, s2);
+ }
+
}
break;
{
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
+ 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;
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;
int
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);
}
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. */
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:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
/* Fall through. */
break;
case INTRINSIC_GT:
+ 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)
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)
continue;
if (arg[i].sym && arg[i].sym->attr.optional)
- continue; /* Skip optional arguments */
+ continue; /* Skip optional arguments. */
arg[i].flag = k;
}
-/* 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;
}
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,
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;
}
}
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->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;
}
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
+ 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 (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.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);
- if (formal->attr.if_source == IFSRC_UNKNOWN
- || actual->symtree->n.sym->attr.external)
- return 1; /* Assume match */
+ return 1;
+ }
- return compare_interfaces (formal, actual->symtree->n.sym, 0);
+ /* 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;
-
- /* 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_SUBSTRING)
+ {
+ 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;
+ }
- for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
- break;
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
- if (ref == NULL)
- return 0; /* Not an array element */
+ 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;
+ }
- return 1;
-}
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+ && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and thus shall not have an array designator",
+ formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+ }
+ if (last && !last->u.c.component->attr.codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
-/* 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, 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;
+ }
-static int
-compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
-{
- if (actual->expr_type != EXPR_VARIABLE)
- return 1;
+ /* 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;
+ }
+ }
- if (!actual->symtree->n.sym->attr.protected)
- return 1;
+ /* F2008, C1239/C1240. */
+ if (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->attr.asynchronous
+ || actual->symtree->n.sym->attr.volatile_)
+ && (formal->attr.asynchronous || formal->attr.volatile_)
+ && actual->rank && !gfc_is_simply_contiguous (actual, true)
+ && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+ || formal->attr.contiguous))
+ {
+ if (where)
+ gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+ "array without CONTIGUOUS attribute - as actual argument at"
+ " %L is not simply contiguous and both are ASYNCHRONOUS "
+ "or VOLATILE", formal->name, &actual->where);
+ return 0;
+ }
- if (!actual->symtree->n.sym->attr.use_assoc)
+ if (symbol_rank (formal) == actual->rank)
return 1;
- if (formal->attr.intent == INTENT_IN
- || formal->attr.intent == INTENT_UNKNOWN)
+ 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.pointer)
- return 0;
-
- if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
- return 0;
+ /* 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
+ && ref->u.ar.dimen > 0)
+ break;
+
+ /* Not an array element. */
+ if (formal->ts.type == BT_CHARACTER
+ && (ref == NULL
+ || (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ || actual->symtree->n.sym->attr.pointer))))
+ {
+ if (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->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;
}
+/* 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_si (sym->as->upper[i]->value.integer)
+ - mpz_get_si (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. */
+
+int
+gfc_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
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 (!compare_parameter (f->sym, a->expr,
- ranks_must_agree || rank_check, is_elemental))
+ 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_error ("Type/rank mismatch in argument '%s' at %L",
- f->sym->name, &a->expr->where);
+ if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+ gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+ where, f->sym->name);
+ else if (where)
+ gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
+ "dummy '%s'", where, f->sym->name);
+
return 0;
}
+
+ if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+ is_elemental, where))
+ return 0;
- if (a->expr->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)
+ /* 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 (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) < 0)
- {
- if (where)
- gfc_error ("Character length of actual argument shorter "
- "than of dummy argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 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_error ("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
+ && 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;
+ }
+
+ /* 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
+ && (gfc_option.allow_std & GFC_STD_F2008) == 0
+ && compare_pointer (f->sym, a->expr) == 2)
+ {
+ if (where)
+ gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
+ "pointer dummy '%s'", &a->expr->where,f->sym->name);
+ return 0;
+ }
+
+
+ /* Fortran 2008, C1242. */
+ if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
+ {
+ 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)
{
if (where)
}
/* 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 ((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;
+ 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 (!compare_parameter_protected(f->sym, a->expr))
+ if ((f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT
+ || f->sym->attr.volatile_
+ || f->sym->attr.asynchronous)
+ && gfc_has_vector_subscript (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 ("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)
{
/* Given a symbol of a formal argument list and an expression,
- return non-zero if their intents are compatible, zero otherwise. */
+ return nonzero if their intents are compatible, zero otherwise. */
static int
compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
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;
+ }
+ }
- if (sym->attr.if_source == IFSRC_UNKNOWN
- || !compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, where))
+ 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
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;
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)
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). 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;
}
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;
}
{
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, &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);
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_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;
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)
+ 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. */
OSDN Git Service
