/* Deal with interfaces.
- Copyright (C) 2000-2013 Free Software Foundation, Inc.
+ Copyright (C) 2000-2017 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "options.h"
#include "gfortran.h"
#include "match.h"
#include "arith.h"
}
+/* Return the operator depending on the DTIO moded string. Note that
+ these are not operators in the normal sense and so have been placed
+ beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */
+
+static gfc_intrinsic_op
+dtio_op (char* mode)
+{
+ if (strncmp (mode, "formatted", 9) == 0)
+ return INTRINSIC_FORMATTED;
+ if (strncmp (mode, "unformatted", 9) == 0)
+ return INTRINSIC_UNFORMATTED;
+ return INTRINSIC_NONE;
+}
+
+
/* Match a generic specification. Depending on which type of
interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */
return MATCH_YES;
}
+ if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
+ if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
if (gfc_match_name (buffer) == MATCH_YES)
{
strcpy (name, buffer);
switch (type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (sym->attr.dummy)
{
- gfc_error ("Dummy procedure '%s' at %C cannot have a "
+ gfc_error ("Dummy procedure %qs at %C cannot have a "
"generic interface", sym->name);
return MATCH_ERROR;
}
if (current_interface.op == INTRINSIC_ASSIGN)
{
m = MATCH_ERROR;
- gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
+ gfc_error ("Expected %<END INTERFACE ASSIGNMENT (=)%> at %C");
}
else
{
break;
m = MATCH_ERROR;
- gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
- "but got %s", s1, s2);
+ if (strcmp(s2, "none") == 0)
+ gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
+ "at %C, ", s1);
+ else
+ gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
+ "but got %s", s1, s2);
}
}
if (type != current_interface.type
|| strcmp (current_interface.uop->name, name) != 0)
{
- gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
+ gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
current_interface.uop->name);
m = MATCH_ERROR;
}
break;
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
{
- gfc_error ("Expecting 'END INTERFACE %s' at %C",
+ gfc_error ("Expecting %<END INTERFACE %s%> at %C",
current_interface.sym->name);
m = MATCH_ERROR;
}
}
+/* Return whether the component was defined anonymously. */
+
+static bool
+is_anonymous_component (gfc_component *cmp)
+{
+ /* Only UNION and MAP components are anonymous. In the case of a MAP,
+ the derived type symbol is FL_STRUCT and the component name looks like mM*.
+ This is the only case in which the second character of a component name is
+ uppercase. */
+ return cmp->ts.type == BT_UNION
+ || (cmp->ts.type == BT_DERIVED
+ && cmp->ts.u.derived->attr.flavor == FL_STRUCT
+ && cmp->name[0] && cmp->name[1] && ISUPPER (cmp->name[1]));
+}
+
+
+/* Return whether the derived type was defined anonymously. */
+
+static bool
+is_anonymous_dt (gfc_symbol *derived)
+{
+ /* UNION and MAP types are always anonymous. Otherwise, only nested STRUCTURE
+ types can be anonymous. For anonymous MAP/STRUCTURE, we have FL_STRUCT
+ and the type name looks like XX*. This is the only case in which the
+ second character of a type name is uppercase. */
+ return derived->attr.flavor == FL_UNION
+ || (derived->attr.flavor == FL_STRUCT
+ && derived->name[0] && derived->name[1] && ISUPPER (derived->name[1]));
+}
+
+
+/* Compare components according to 4.4.2 of the Fortran standard. */
+
+static bool
+compare_components (gfc_component *cmp1, gfc_component *cmp2,
+ gfc_symbol *derived1, gfc_symbol *derived2)
+{
+ /* Compare names, but not for anonymous components such as UNION or MAP. */
+ if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
+ && strcmp (cmp1->name, cmp2->name) != 0)
+ return false;
+
+ if (cmp1->attr.access != cmp2->attr.access)
+ return false;
+
+ if (cmp1->attr.pointer != cmp2->attr.pointer)
+ return false;
+
+ if (cmp1->attr.dimension != cmp2->attr.dimension)
+ return false;
+
+ if (cmp1->attr.allocatable != cmp2->attr.allocatable)
+ return false;
+
+ if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
+ return false;
+
+ if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *l1 = cmp1->ts.u.cl;
+ gfc_charlen *l2 = cmp2->ts.u.cl;
+ if (l1 && l2 && l1->length && l2->length
+ && l1->length->expr_type == EXPR_CONSTANT
+ && l2->length->expr_type == EXPR_CONSTANT
+ && gfc_dep_compare_expr (l1->length, l2->length) != 0)
+ return false;
+ }
+
+ /* Make sure that link lists do not put this function into an
+ endless recursive loop! */
+ if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
+ && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived)
+ && !gfc_compare_types (&cmp1->ts, &cmp2->ts))
+ return false;
+
+ else if ( (cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
+ && !(cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
+ return false;
+
+ else if (!(cmp1->ts.type == BT_DERIVED && derived1 == cmp1->ts.u.derived)
+ && (cmp2->ts.type == BT_DERIVED && derived2 == cmp2->ts.u.derived))
+ return false;
+
+ return true;
+}
+
+
+/* Compare two union types by comparing the components of their maps.
+ Because unions and maps are anonymous their types get special internal
+ names; therefore the usual derived type comparison will fail on them.
+
+ Returns nonzero if equal, as with gfc_compare_derived_types. Also as with
+ gfc_compare_derived_types, 'equal' is closer to meaning 'duplicate
+ definitions' than 'equivalent structure'. */
+
+static bool
+compare_union_types (gfc_symbol *un1, gfc_symbol *un2)
+{
+ gfc_component *map1, *map2, *cmp1, *cmp2;
+ gfc_symbol *map1_t, *map2_t;
+
+ if (un1->attr.flavor != FL_UNION || un2->attr.flavor != FL_UNION)
+ return false;
+
+ if (un1->attr.zero_comp != un2->attr.zero_comp)
+ return false;
+
+ if (un1->attr.zero_comp)
+ return true;
+
+ map1 = un1->components;
+ map2 = un2->components;
+
+ /* In terms of 'equality' here we are worried about types which are
+ declared the same in two places, not types that represent equivalent
+ structures. (This is common because of FORTRAN's weird scoping rules.)
+ Though two unions with their maps in different orders could be equivalent,
+ we will say they are not equal for the purposes of this test; therefore
+ we compare the maps sequentially. */
+ for (;;)
+ {
+ map1_t = map1->ts.u.derived;
+ map2_t = map2->ts.u.derived;
+
+ cmp1 = map1_t->components;
+ cmp2 = map2_t->components;
+
+ /* Protect against null components. */
+ if (map1_t->attr.zero_comp != map2_t->attr.zero_comp)
+ return false;
+
+ if (map1_t->attr.zero_comp)
+ return true;
+
+ for (;;)
+ {
+ /* No two fields will ever point to the same map type unless they are
+ the same component, because one map field is created with its type
+ declaration. Therefore don't worry about recursion here. */
+ /* TODO: worry about recursion into parent types of the unions? */
+ if (!compare_components (cmp1, cmp2, map1_t, map2_t))
+ return false;
+
+ cmp1 = cmp1->next;
+ cmp2 = cmp2->next;
+
+ if (cmp1 == NULL && cmp2 == NULL)
+ break;
+ if (cmp1 == NULL || cmp2 == NULL)
+ return false;
+ }
+
+ map1 = map1->next;
+ map2 = map2->next;
+
+ if (map1 == NULL && map2 == NULL)
+ break;
+ if (map1 == NULL || map2 == NULL)
+ return false;
+ }
+
+ return true;
+}
+
+
+
/* Compare two derived types using the criteria in 4.4.2 of the standard,
recursing through gfc_compare_types for the components. */
-int
+bool
gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
{
- gfc_component *dt1, *dt2;
+ gfc_component *cmp1, *cmp2;
if (derived1 == derived2)
- return 1;
+ return true;
+
+ if (!derived1 || !derived2)
+ gfc_internal_error ("gfc_compare_derived_types: invalid derived type");
- gcc_assert (derived1 && derived2);
+ /* Compare UNION types specially. */
+ if (derived1->attr.flavor == FL_UNION || derived2->attr.flavor == FL_UNION)
+ return compare_union_types (derived1, derived2);
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
if (strcmp (derived1->name, derived2->name) == 0
&& derived1->module != NULL && derived2->module != NULL
&& strcmp (derived1->module, derived2->module) == 0)
- return 1;
+ return true;
/* Compare type via the rules of the standard. Both types must have
- the SEQUENCE or BIND(C) attribute to be equal. */
+ the SEQUENCE or BIND(C) attribute to be equal. STRUCTUREs are special
+ because they can be anonymous; therefore two structures with different
+ names may be equal. */
- if (strcmp (derived1->name, derived2->name))
- return 0;
+ /* Compare names, but not for anonymous types such as UNION or MAP. */
+ if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
+ && strcmp (derived1->name, derived2->name) != 0)
+ return false;
if (derived1->component_access == ACCESS_PRIVATE
|| derived2->component_access == ACCESS_PRIVATE)
- return 0;
+ return false;
if (!(derived1->attr.sequence && derived2->attr.sequence)
&& !(derived1->attr.is_bind_c && derived2->attr.is_bind_c))
- return 0;
+ return false;
+
+ /* Protect against null components. */
+ if (derived1->attr.zero_comp != derived2->attr.zero_comp)
+ return false;
- dt1 = derived1->components;
- dt2 = derived2->components;
+ if (derived1->attr.zero_comp)
+ return true;
+
+ cmp1 = derived1->components;
+ cmp2 = derived2->components;
/* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
simple test can speed things up. Otherwise, lots of things have to
match. */
for (;;)
{
- if (strcmp (dt1->name, dt2->name) != 0)
- return 0;
-
- 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->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
- return 0;
-
- /* Make sure that link lists do not put this function into an
- endless recursive loop! */
- if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
- && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
- && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
- return 0;
-
- else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
- && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
- return 0;
-
- 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 (!compare_components (cmp1, cmp2, derived1, derived2))
+ return false;
- dt1 = dt1->next;
- dt2 = dt2->next;
+ cmp1 = cmp1->next;
+ cmp2 = cmp2->next;
- if (dt1 == NULL && dt2 == NULL)
+ if (cmp1 == NULL && cmp2 == NULL)
break;
- if (dt1 == NULL || dt2 == NULL)
- return 0;
+ if (cmp1 == NULL || cmp2 == NULL)
+ return false;
}
- return 1;
+ return true;
}
/* Compare two typespecs, recursively if necessary. */
-int
+bool
gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
{
/* See if one of the typespecs is a BT_VOID, which is what is being used
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;
+ return true;
- if (ts1->type == BT_CLASS
- && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
- return 1;
+ /* The _data component is not always present, therefore check for its
+ presence before assuming, that its derived->attr is available.
+ When the _data component is not present, then nevertheless the
+ unlimited_polymorphic flag may be set in the derived type's attr. */
+ if (ts1->type == BT_CLASS && ts1->u.derived->components
+ && ((ts1->u.derived->attr.is_class
+ && ts1->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts1->u.derived->attr.unlimited_polymorphic))
+ return true;
/* F2003: C717 */
if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
- && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
+ && ts2->u.derived->components
+ && ((ts2->u.derived->attr.is_class
+ && ts2->u.derived->components->ts.u.derived->attr
+ .unlimited_polymorphic)
+ || ts2->u.derived->attr.unlimited_polymorphic)
&& (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
- return 1;
+ return true;
if (ts1->type != ts2->type
&& ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
|| (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
- return 0;
+ return false;
+
+ if (ts1->type == BT_UNION)
+ return compare_union_types (ts1->u.derived, ts2->u.derived);
+
if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
return (ts1->kind == ts2->kind);
/* Compare derived types. */
- if (gfc_type_compatible (ts1, ts2))
- return 1;
-
- return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
+ return gfc_type_compatible (ts1, ts2);
}
-static int
+static bool
compare_type (gfc_symbol *s1, gfc_symbol *s2)
{
if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
/* TYPE and CLASS of the same declared type are type compatible,
but have different characteristics. */
if ((s1->ts.type == BT_CLASS && s2->ts.type == BT_DERIVED)
|| (s1->ts.type == BT_DERIVED && s2->ts.type == BT_CLASS))
- return 0;
+ return false;
return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
}
-static int
+static bool
compare_rank (gfc_symbol *s1, gfc_symbol *s2)
{
gfc_array_spec *as1, *as2;
int r1, r2;
if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
as2 = (s2->ts.type == BT_CLASS) ? CLASS_DATA (s2)->as : s2->as;
r2 = as2 ? as2->rank : 0;
if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
- return 0; /* Ranks differ. */
+ return false; /* Ranks differ. */
- return 1;
+ return true;
}
/* Given two symbols that are formal arguments, compare their ranks
- and types. Returns nonzero if they have the same rank and type,
- zero otherwise. */
+ and types. Returns true if they have the same rank and type,
+ false otherwise. */
-static int
+static bool
compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
{
return compare_type (s1, s2) && compare_rank (s1, s2);
/* 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. */
+ procedures. Returns true if the same, false if different. */
-static int
+static bool
compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
{
if (s1 == NULL || s2 == NULL)
- return s1 == s2 ? 1 : 0;
+ return (s1 == s2);
if (s1 == s2)
- return 1;
+ return true;
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;
+ return false;
/* 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;
+ return s1->attr.external ? compare_type_rank (s1, s2) : false;
if (s2->attr.function == 0 && s2->attr.subroutine == 0)
- return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
+ return s2->attr.external ? compare_type_rank (s1, s2) : false;
/* Now the type of procedure has been identified. */
if (s1->attr.function != s2->attr.function
|| s1->attr.subroutine != s2->attr.subroutine)
- return 0;
+ return false;
- if (s1->attr.function && compare_type_rank (s1, s2) == 0)
- return 0;
+ if (s1->attr.function && !compare_type_rank (s1, s2))
+ return false;
/* Originally, gfortran recursed here to check the interfaces of passed
procedures. This is explicitly not required by the standard. */
- return 1;
+ return true;
}
by this test. This subroutine implements rule 1 of section F03:16.2.3.
'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
-static int
+static bool
count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
const char *p1, const char *p2)
{
- int rc, ac1, ac2, i, j, k, n1;
+ int ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
typedef struct
/* Now loop over each distinct type found in f1. */
k = 0;
- rc = 0;
+ bool rc = false;
for (i = 0; i < n1; i++)
{
if (ac1 > ac2)
{
- rc = 1;
+ rc = true;
break;
}
At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous. */
-static int
+static bool
generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
const char *p1, const char *p2)
{
|| ((gfc_option.allow_std & GFC_STD_F2008)
&& ((sym->attr.allocatable && g->sym->attr.pointer)
|| (sym->attr.pointer && g->sym->attr.allocatable))))
- return 1;
+ return true;
}
next:
f2 = f2->next;
}
- return 0;
+ return false;
}
/* Check if the characteristics of two dummy arguments match,
cf. F08:12.3.2. */
-static bool
-check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
- bool type_must_agree, char *errmsg, int err_len)
+bool
+gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
+ bool type_must_agree, char *errmsg,
+ int err_len)
{
if (s1 == NULL || s2 == NULL)
return s1 == s2 ? true : false;
return false;
}
- /* FIXME: Do more comprehensive testing of attributes, like e.g.
- ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
+ /* Check ASYNCHRONOUS attribute. */
+ if (s1->attr.asynchronous != s2->attr.asynchronous)
+ {
+ snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check CONTIGUOUS attribute. */
+ if (s1->attr.contiguous != s2->attr.contiguous)
+ {
+ snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VALUE attribute. */
+ if (s1->attr.value != s2->attr.value)
+ {
+ snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VOLATILE attribute. */
+ if (s1->attr.volatile_ != s2->attr.volatile_)
+ {
+ snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
/* Check interface of dummy procedures. */
if (s1->attr.flavor == FL_PROCEDURE)
case -2:
/* FIXME: Implement a warning for this case.
- gfc_warning ("Possible character length mismatch in argument '%s'",
+ gfc_warning (0, "Possible character length mismatch in argument %qs",
s1->name);*/
break;
return false;
}
+ if (s1->as->corank != s2->as->corank)
+ {
+ snprintf (errmsg, err_len, "Corank mismatch in argument '%s' (%i/%i)",
+ s1->name, s1->as->corank, s2->as->corank);
+ return false;
+ }
+
if (s1->as->type == AS_EXPLICIT)
- for (i = 0; i < s1->as->rank + s1->as->corank; i++)
+ for (i = 0; i < s1->as->rank + MAX (0, s1->as->corank-1); i++)
{
shape1 = gfc_subtract (gfc_copy_expr (s1->as->upper[i]),
gfc_copy_expr (s1->as->lower[i]));
case -1:
case 1:
case -3:
- snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
- "argument '%s'", i + 1, s1->name);
+ if (i < s1->as->rank)
+ snprintf (errmsg, err_len, "Shape mismatch in dimension %i of"
+ " argument '%s'", i + 1, s1->name);
+ else
+ snprintf (errmsg, err_len, "Shape mismatch in codimension %i "
+ "of argument '%s'", i - s1->as->rank + 1, s1->name);
return false;
case -2:
/* FIXME: Implement a warning for this case.
- gfc_warning ("Possible shape mismatch in argument '%s'",
+ gfc_warning (0, "Possible shape mismatch in argument %qs",
s1->name);*/
break;
/* Check if the characteristics of two function results match,
cf. F08:12.3.3. */
-static bool
-check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
+bool
+gfc_check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
char *errmsg, int err_len)
{
gfc_symbol *r1, *r2;
case -2:
/* FIXME: Implement a warning for this case.
- gfc_warning ("Possible shape mismatch in return value");*/
+ gfc_warning (0, "Possible shape mismatch in return value");*/
break;
case 0:
/* 'Compare' two formal interfaces associated with a pair of symbols.
- We return nonzero if there exists an actual argument list that
+ We return true if there exists an actual argument list that
would be ambiguous between the two interfaces, zero otherwise.
'strict_flag' specifies whether all the characteristics are
required to match, which is not the case for ambiguity checks.
'p1' and 'p2' are the PASS arguments of both procedures (if applicable). */
-int
+bool
gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
int generic_flag, int strict_flag,
char *errmsg, int err_len,
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' is not a function", name2);
- return 0;
+ return false;
}
if (s1->attr.subroutine && s2->attr.function)
{
if (errmsg != NULL)
snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
- return 0;
+ return false;
}
/* Do strict checks on all characteristics
if (s1->attr.function && s2->attr.function)
{
/* If both are functions, check result characteristics. */
- if (!check_result_characteristics (s1, s2, errmsg, err_len)
- || !check_result_characteristics (s2, s1, errmsg, err_len))
- return 0;
+ if (!gfc_check_result_characteristics (s1, s2, errmsg, err_len)
+ || !gfc_check_result_characteristics (s2, s1, errmsg, err_len))
+ return false;
}
if (s1->attr.pure && !s2->attr.pure)
{
snprintf (errmsg, err_len, "Mismatch in PURE attribute");
- return 0;
+ return false;
}
if (s1->attr.elemental && !s2->attr.elemental)
{
snprintf (errmsg, err_len, "Mismatch in ELEMENTAL attribute");
- return 0;
+ return false;
}
}
if (s1->attr.if_source == IFSRC_UNKNOWN
|| s2->attr.if_source == IFSRC_UNKNOWN)
- return 1;
+ return true;
f1 = gfc_sym_get_dummy_args (s1);
f2 = gfc_sym_get_dummy_args (s2);
+ /* Special case: No arguments. */
if (f1 == NULL && f2 == NULL)
- return 1; /* Special case: No arguments. */
+ return true;
if (generic_flag)
{
if (count_types_test (f1, f2, p1, p2)
|| count_types_test (f2, f1, p2, p1))
- return 0;
+ return false;
+
+ /* Special case: alternate returns. If both f1->sym and f2->sym are
+ NULL, then the leading formal arguments are alternate returns.
+ The previous conditional should catch argument lists with
+ different number of argument. */
+ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL)
+ return true;
+
if (generic_correspondence (f1, f2, p1, p2)
|| generic_correspondence (f2, f1, p2, p1))
- return 0;
+ return false;
}
else
/* Perform the abbreviated correspondence test for operators (the
This is also done when comparing interfaces for dummy procedures and in
procedure pointer assignments. */
- for (;;)
+ for (; f1 || f2; f1 = f1->next, f2 = f2->next)
{
/* 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;
+ return false;
}
- if (UNLIMITED_POLY (f1->sym))
- goto next;
-
if (strict_flag)
{
/* Check all characteristics. */
- if (!check_dummy_characteristics (f1->sym, f2->sym, true,
+ if (!gfc_check_dummy_characteristics (f1->sym, f2->sym, true,
errmsg, err_len))
- return 0;
+ return false;
}
else
{
"(%s/%s)", f1->sym->name,
gfc_typename (&f1->sym->ts),
gfc_typename (&f2->sym->ts));
- return 0;
+ return false;
}
if (!compare_rank (f2->sym, f1->sym))
{
snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
"(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
symbol_rank (f2->sym));
- return 0;
+ return false;
}
}
-next:
- f1 = f1->next;
- f2 = f2->next;
}
- return 1;
+ return true;
}
/* Given a pointer to an interface pointer, remove duplicate
interfaces and make sure that all symbols are either functions
- or subroutines, and all of the same kind. Returns nonzero if
+ or subroutines, and all of the same kind. Returns true if
something goes wrong. */
-static int
+static bool
check_interface0 (gfc_interface *p, const char *interface_name)
{
gfc_interface *psave, *q, *qlast;
functions or subroutines. */
if (((!p->sym->attr.function && !p->sym->attr.subroutine)
|| !p->sym->attr.if_source)
- && p->sym->attr.flavor != FL_DERIVED)
+ && !gfc_fl_struct (p->sym->attr.flavor))
{
if (p->sym->attr.external)
- gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
+ gfc_error ("Procedure %qs 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 "
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
"subroutine", p->sym->name, interface_name,
&p->sym->declared_at);
- return 1;
+ return true;
}
/* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
if ((psave->sym->attr.function && !p->sym->attr.function
- && p->sym->attr.flavor != FL_DERIVED)
+ && !gfc_fl_struct (p->sym->attr.flavor))
|| (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
{
- if (p->sym->attr.flavor != FL_DERIVED)
+ if (!gfc_fl_struct (p->sym->attr.flavor))
gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
" or all FUNCTIONs", interface_name,
&p->sym->declared_at);
- else
+ else if (p->sym->attr.flavor == FL_DERIVED)
gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
"generic name is also the name of a derived type",
interface_name, &p->sym->declared_at);
- return 1;
+ return true;
}
/* F2003, C1207. F2008, C1207. */
if (p->sym->attr.proc == PROC_INTERNAL
&& !gfc_notify_std (GFC_STD_F2008, "Internal procedure "
- "'%s' in %s at %L", p->sym->name,
+ "%qs in %s at %L", p->sym->name,
interface_name, &p->sym->declared_at))
- return 1;
+ return true;
}
p = psave;
}
}
- return 0;
+ return false;
}
/* Check lists of interfaces to make sure that no two interfaces are
ambiguous. Duplicate interfaces (from the same symbol) are OK here. */
-static int
+static bool
check_interface1 (gfc_interface *p, gfc_interface *q0,
int generic_flag, const char *interface_name,
bool referenced)
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
- if (p->sym->attr.flavor != FL_DERIVED
- && q->sym->attr.flavor != FL_DERIVED
+ if (!gfc_fl_struct (p->sym->attr.flavor)
+ && !gfc_fl_struct (q->sym->attr.flavor)
&& gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
generic_flag, 0, NULL, 0, NULL, NULL))
{
if (referenced)
- gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
- p->sym->name, q->sym->name, interface_name,
- &p->where);
+ gfc_error ("Ambiguous interfaces in %s for %qs at %L "
+ "and %qs at %L", interface_name,
+ q->sym->name, &q->sym->declared_at,
+ p->sym->name, &p->sym->declared_at);
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);
+ gfc_warning (0, "Ambiguous interfaces in %s for %qs at %L "
+ "and %qs at %L", interface_name,
+ q->sym->name, &q->sym->declared_at,
+ p->sym->name, &p->sym->declared_at);
else
- gfc_warning ("Although not referenced, '%s' has ambiguous "
+ gfc_warning (0, "Although not referenced, %qs has ambiguous "
"interfaces at %L", interface_name, &p->where);
- return 1;
+ return true;
}
}
- return 0;
+ return false;
}
for (p = sym->generic; p; p = p->next)
{
if (p->sym->attr.mod_proc
+ && !p->sym->attr.module_procedure
&& (p->sym->attr.if_source != IFSRC_DECL
|| p->sym->attr.procedure))
{
- gfc_error ("'%s' at %L is not a module procedure",
+ gfc_error ("%qs at %L is not a module procedure",
p->sym->name, &p->where);
return;
}
/* Given a symbol of a formal argument list and an expression, if the
formal argument is allocatable, check that the actual argument is
- allocatable. Returns nonzero if compatible, zero if not compatible. */
+ allocatable. Returns true if compatible, zero if not compatible. */
-static int
+static bool
compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
{
- symbol_attribute attr;
-
if (formal->attr.allocatable
|| (formal->ts.type == BT_CLASS && CLASS_DATA (formal)->attr.allocatable))
{
- attr = gfc_expr_attr (actual);
- if (!attr.allocatable)
- return 0;
+ symbol_attribute attr = gfc_expr_attr (actual);
+ if (actual->ts.type == BT_CLASS && !attr.class_ok)
+ return true;
+ else if (!attr.allocatable)
+ return false;
}
- return 1;
+ return true;
}
/* TS 29113, C407b. */
if (rank2 == -1)
- {
- gfc_error ("The assumed-rank array at %L requires that the dummy argument"
- " '%s' has assumed-rank", where, name);
- }
+ gfc_error ("The assumed-rank array at %L requires that the dummy argument"
+ " %qs has assumed-rank", where, name);
else if (rank1 == 0)
- {
- gfc_error ("Rank mismatch in argument '%s' at %L "
- "(scalar and rank-%d)", name, where, rank2);
- }
+ gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
+ "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);
- }
+ gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
+ "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);
- }
+ gfc_error_opt (OPT_Wargument_mismatch, "Rank mismatch in argument %qs "
+ "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. */
+ the two are compatible as arguments. Returns true if
+ compatible, false if not compatible. */
-static int
+static bool
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
bool rank_check, is_pointer;
+ char err[200];
+ gfc_component *ppc;
/* 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;
+ return true;
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;
+ return true;
if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
/* Make sure the vtab symbol is present when
if (actual->ts.type == BT_PROCEDURE)
{
- char err[200];
gfc_symbol *act_sym = actual->symtree->n.sym;
if (formal->attr.flavor != FL_PROCEDURE)
{
if (where)
gfc_error ("Invalid procedure argument at %L", &actual->where);
- return 0;
+ return false;
}
if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
sizeof(err), NULL, NULL))
{
if (where)
- gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
- formal->name, &actual->where, err);
- return 0;
+ gfc_error_opt (OPT_Wargument_mismatch,
+ "Interface mismatch in dummy procedure %qs at %L:"
+ " %s", formal->name, &actual->where, err);
+ return false;
}
if (formal->attr.function && !act_sym->attr.function)
&act_sym->declared_at);
if (act_sym->ts.type == BT_UNKNOWN
&& !gfc_set_default_type (act_sym, 1, act_sym->ns))
- return 0;
+ return false;
}
else if (formal->attr.subroutine && !act_sym->attr.subroutine)
gfc_add_subroutine (&act_sym->attr, act_sym->name,
&act_sym->declared_at);
- return 1;
+ return true;
+ }
+
+ ppc = gfc_get_proc_ptr_comp (actual);
+ if (ppc && ppc->ts.interface)
+ {
+ if (!gfc_compare_interfaces (formal, ppc->ts.interface, ppc->name, 0, 1,
+ err, sizeof(err), NULL, NULL))
+ {
+ if (where)
+ gfc_error_opt (OPT_Wargument_mismatch,
+ "Interface mismatch in dummy procedure %qs at %L:"
+ " %s", formal->name, &actual->where, err);
+ return false;
+ }
}
/* F2008, C1241. */
if (formal->attr.pointer && formal->attr.contiguous
- && !gfc_is_simply_contiguous (actual, true))
+ && !gfc_is_simply_contiguous (actual, true, false))
{
if (where)
- gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
+ gfc_error ("Actual argument to contiguous pointer dummy %qs at %L "
"must be simply contiguous", formal->name, &actual->where);
- return 0;
+ return false;
}
+ symbol_attribute actual_attr = gfc_expr_attr (actual);
+ if (actual->ts.type == BT_CLASS && !actual_attr.class_ok)
+ return true;
+
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& actual->ts.type != BT_HOLLERITH
&& formal->ts.type != BT_ASSUMED
CLASS_DATA (actual)->ts.u.derived)))
{
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;
+ gfc_error_opt (OPT_Wargument_mismatch,
+ "Type mismatch in argument %qs at %L; passed %s to %s",
+ formal->name, where, gfc_typename (&actual->ts),
+ gfc_typename (&formal->ts));
+ return false;
}
if (actual->ts.type == BT_ASSUMED && formal->ts.type != BT_ASSUMED)
{
if (where)
gfc_error ("Assumed-type actual argument at %L requires that dummy "
- "argument '%s' is of assumed type", &actual->where,
+ "argument %qs is of assumed type", &actual->where,
formal->name);
- return 0;
+ return false;
}
/* F2008, 12.5.2.5; IR F08/0073. */
if (formal->ts.type == BT_CLASS && formal->attr.class_ok
&& actual->expr_type != EXPR_NULL
&& ((CLASS_DATA (formal)->attr.class_pointer
- && !formal->attr.intent == INTENT_IN)
+ && formal->attr.intent != INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable))
{
if (actual->ts.type != BT_CLASS)
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+ gfc_error ("Actual argument to %qs at %L must be polymorphic",
formal->name, &actual->where);
- return 0;
+ return false;
}
- if (!gfc_expr_attr (actual).class_ok)
- return 0;
-
if ((!UNLIMITED_POLY (formal) || !UNLIMITED_POLY(actual))
&& !gfc_compare_derived_types (CLASS_DATA (actual)->ts.u.derived,
CLASS_DATA (formal)->ts.u.derived))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must have the same "
+ gfc_error ("Actual argument to %qs at %L must have the same "
"declared type", formal->name, &actual->where);
- return 0;
+ return false;
}
}
||CLASS_DATA (formal)->attr.class_pointer))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be unlimited "
+ gfc_error ("Actual argument to %qs at %L must be unlimited "
"polymorphic since the formal argument is a "
"pointer or allocatable unlimited polymorphic "
"entity [F2008: 12.5.2.5]", formal->name,
&actual->where);
- return 0;
+ return false;
}
if (formal->attr.codimension && !gfc_is_coarray (actual))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ gfc_error ("Actual argument to %qs at %L must be a coarray",
formal->name, &actual->where);
- return 0;
+ return false;
}
if (formal->attr.codimension && formal->attr.allocatable)
&& actual->symtree->n.sym->as->corank != formal->as->corank))
{
if (where)
- gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ gfc_error ("Corank mismatch in argument %qs 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;
+ return false;
}
}
if (formal->attr.codimension)
{
- /* F2008, 12.5.2.8. */
+ /* F2008, 12.5.2.8 + Corrig 2 (IR F08/0048). */
+ /* F2015, 12.5.2.8. */
if (formal->attr.dimension
&& (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
- && gfc_expr_attr (actual).dimension
- && !gfc_is_simply_contiguous (actual, true))
+ && actual_attr.dimension
+ && !gfc_is_simply_contiguous (actual, true, true))
{
if (where)
- gfc_error ("Actual argument to '%s' at %L must be simply "
- "contiguous", formal->name, &actual->where);
- return 0;
+ gfc_error ("Actual argument to %qs at %L must be simply "
+ "contiguous or an element of such an array",
+ formal->name, &actual->where);
+ return false;
}
/* F2008, C1303 and C1304. */
{
if (where)
- gfc_error ("Actual argument to non-INTENT(INOUT) dummy '%s' at %L, "
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is LOCK_TYPE or has a LOCK_TYPE component",
formal->name, &actual->where);
- return 0;
+ return false;
+ }
+
+ /* TS18508, C702/C703. */
+ if (formal->attr.intent != INTENT_INOUT
+ && (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
+ && formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || formal->attr.event_comp))
+
+ {
+ if (where)
+ gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
+ "which is EVENT_TYPE or has a EVENT_TYPE component",
+ formal->name, &actual->where);
+ return false;
}
}
&& (actual->symtree->n.sym->attr.asynchronous
|| actual->symtree->n.sym->attr.volatile_)
&& (formal->attr.asynchronous || formal->attr.volatile_)
- && actual->rank && formal->as && !gfc_is_simply_contiguous (actual, true)
+ && actual->rank && formal->as
+ && !gfc_is_simply_contiguous (actual, true, false)
&& ((formal->as->type != AS_ASSUMED_SHAPE
&& formal->as->type != AS_ASSUMED_RANK && !formal->attr.pointer)
|| formal->attr.contiguous))
{
if (where)
- gfc_error ("Dummy argument '%s' has to be a pointer, assumed-shape or "
+ gfc_error ("Dummy argument %qs has to be a pointer, assumed-shape or "
"assumed-rank 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;
+ return false;
}
if (formal->attr.allocatable && !formal->attr.codimension
- && gfc_expr_attr (actual).codimension)
+ && actual_attr.codimension)
{
if (formal->attr.intent == INTENT_OUT)
{
if (where)
gfc_error ("Passing coarray at %L to allocatable, noncoarray, "
- "INTENT(OUT) dummy argument '%s'", &actual->where,
+ "INTENT(OUT) dummy argument %qs", &actual->where,
formal->name);
- return 0;
+ return false;
}
- else if (gfc_option.warn_surprising && where
- && formal->attr.intent != INTENT_IN)
- gfc_warning ("Passing coarray at %L to allocatable, noncoarray dummy "
- "argument '%s', which is invalid if the allocation status"
+ else if (warn_surprising && where && formal->attr.intent != INTENT_IN)
+ gfc_warning (OPT_Wsurprising,
+ "Passing coarray at %L to allocatable, noncoarray dummy "
+ "argument %qs, which is invalid if the allocation status"
" is modified", &actual->where, formal->name);
}
/* If the rank is the same or the formal argument has assumed-rank. */
if (symbol_rank (formal) == actual->rank || symbol_rank (formal) == -1)
- return 1;
-
- if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as
- && CLASS_DATA (actual)->as->rank == symbol_rank (formal))
- return 1;
+ return true;
rank_check = where != NULL && !is_elemental && formal->as
&& (formal->as->type == AS_ASSUMED_SHAPE
/* Skip rank checks for NO_ARG_CHECK. */
if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
- return 1;
+ return true;
/* Scalar & coindexed, see: F2008, Section 12.5.2.4. */
if (rank_check || ranks_must_agree
if (where)
argument_rank_mismatch (formal->name, &actual->where,
symbol_rank (formal), actual->rank);
- return 0;
+ return false;
}
else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
- return 1;
+ return true;
/* 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, and F2008 12.5.2.4),
if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
{
if (where)
- gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+ gfc_error ("Polymorphic scalar passed to array dummy argument %qs "
"at %L", formal->name, &actual->where);
- return 0;
+ return false;
}
if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
{
if (where)
gfc_error ("Element of assumed-shaped or pointer "
- "array passed to array dummy argument '%s' at %L",
+ "array passed to array dummy argument %qs at %L",
formal->name, &actual->where);
- return 0;
+ return false;
}
if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
if (where)
gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
"CHARACTER actual argument with array dummy argument "
- "'%s' at %L", formal->name, &actual->where);
- return 0;
+ "%qs at %L", formal->name, &actual->where);
+ return false;
}
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",
+ "array dummy argument %qs at %L",
formal->name, &actual->where);
- return 0;
+ return false;
}
- else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
- return 0;
else
- return 1;
+ return ((gfc_option.allow_std & GFC_STD_F2003) != 0);
}
if (ref == NULL && actual->expr_type != EXPR_NULL)
if (where)
argument_rank_mismatch (formal->name, &actual->where,
symbol_rank (formal), actual->rank);
- return 0;
+ return false;
}
- return 1;
+ return true;
}
{
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)
+ && ref->u.ar.as->lower[i]->ts.type == BT_INTEGER
+ && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT
+ && ref->u.ar.as->upper[i]->ts.type == BT_INTEGER)
elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
- mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ 1L;
- mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
}
}
+ else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.function
+ && ref->u.c.component->attr.proc_pointer
+ && ref->u.c.component->attr.dimension)
+ {
+ /* Array-valued procedure-pointer components. */
+ gfc_array_spec *as = ref->u.c.component->as;
+ for (i = 0; i < as->rank; i++)
+ {
+ if (!as->upper[i] || !as->lower[i]
+ || as->upper[i]->expr_type != EXPR_CONSTANT
+ || as->lower[i]->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ elements = elements
+ * (mpz_get_si (as->upper[i]->value.integer)
+ - mpz_get_si (as->lower[i]->value.integer) + 1L);
+ }
+ }
}
if (substrlen)
/* Given an expression, check whether it is an array section
- which has a vector subscript. If it has, one is returned,
- otherwise zero. */
+ which has a vector subscript. */
-int
+bool
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;
+ return false;
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 true;
- return 0;
+ return false;
+}
+
+
+static bool
+is_procptr_result (gfc_expr *expr)
+{
+ gfc_component *c = gfc_get_proc_ptr_comp (expr);
+ if (c)
+ return (c->ts.interface && (c->ts.interface->attr.proc_pointer == 1));
+ else
+ return ((expr->symtree->n.sym->result != expr->symtree->n.sym)
+ && (expr->symtree->n.sym->result->attr.proc_pointer == 1));
}
errors when things don't match instead of just returning the status
code. */
-static int
+static bool
compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
int ranks_must_agree, int is_elemental, locus *where)
{
- gfc_actual_arglist **new_arg, *a, *actual, temp;
+ gfc_actual_arglist **new_arg, *a, *actual;
gfc_formal_arglist *f;
int i, n, na;
unsigned long actual_size, formal_size;
bool full_array = false;
+ gfc_array_ref *actual_arr_ref;
actual = *ap;
if (actual == NULL && formal == NULL)
- return 1;
+ return true;
n = 0;
for (f = formal; f; f = f->next)
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument '%s' at %L is not in "
+ gfc_error ("Keyword argument %qs at %L is not in "
"the procedure", a->name, &a->expr->where);
- return 0;
+ return false;
}
if (new_arg[i] != NULL)
{
if (where)
- gfc_error ("Keyword argument '%s' at %L is already associated "
+ gfc_error ("Keyword argument %qs at %L is already associated "
"with another actual argument", a->name,
&a->expr->where);
- return 0;
+ return false;
}
}
gfc_error ("More actual than formal arguments in procedure "
"call at %L", where);
- return 0;
+ return false;
}
if (f->sym == NULL && a->expr == NULL)
if (where)
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
- return 0;
+ return false;
}
if (a->expr == NULL)
if (where)
gfc_error ("Unexpected alternate return spec in subroutine "
"call at %L", where);
- return 0;
+ return false;
}
/* Make sure that intrinsic vtables exist for calls to unlimited
if (UNLIMITED_POLY (f->sym)
&& a->expr->ts.type != BT_DERIVED
&& a->expr->ts.type != BT_CLASS)
- gfc_find_intrinsic_vtab (&a->expr->ts);
+ gfc_find_vtab (&a->expr->ts);
if (a->expr->expr_type == EXPR_NULL
&& ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
|| (f->sym->ts.type == BT_CLASS
&& CLASS_DATA (f->sym)->attr.allocatable)))
- gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+ gfc_error ("Unexpected NULL() intrinsic at %L to dummy %qs",
where, f->sym->name);
else if (where)
gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
- "dummy '%s'", where, f->sym->name);
+ "dummy %qs", where, f->sym->name);
- return 0;
+ return false;
}
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
is_elemental, where))
- return 0;
+ return false;
/* TS 29113, 6.3p2. */
if (f->sym->ts.type == BT_ASSUMED
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;
- }
+ && a->expr->ts.u.cl && a->expr->ts.u.cl->length
+ && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && f->sym->ts.type == BT_CHARACTER && 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 (OPT_Wargument_mismatch,
+ "Character length mismatch (%ld/%ld) between actual "
+ "argument and pointer or allocatable dummy argument "
+ "%qs 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 (OPT_Wargument_mismatch,
+ "Character length mismatch (%ld/%ld) between actual "
+ "argument and assumed-shape dummy argument %qs "
+ "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 false;
+ }
if ((f->sym->attr.pointer || f->sym->attr.allocatable)
- && f->sym->ts.deferred != a->expr->ts.deferred
- && a->expr->ts.type == BT_CHARACTER)
+ && f->sym->ts.deferred != a->expr->ts.deferred
+ && a->expr->ts.type == BT_CHARACTER)
{
if (where)
gfc_error ("Actual argument at %L to allocatable or "
- "pointer dummy argument '%s' must have a deferred "
+ "pointer dummy argument %qs must have a deferred "
"length type parameter if and only if the dummy has one",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
if (f->sym->ts.type == BT_CLASS)
&& f->sym->attr.flavor != FL_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
- gfc_warning ("Character length of actual argument shorter "
- "than of dummy argument '%s' (%lu/%lu) at %L",
+ gfc_warning (OPT_Wargument_mismatch,
+ "Character length of actual argument shorter "
+ "than of dummy argument %qs (%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",
+ gfc_warning (OPT_Wargument_mismatch,
+ "Actual argument contains too few "
+ "elements for dummy argument %qs (%lu/%lu) at %L",
f->sym->name, actual_size, formal_size,
&a->expr->where);
- return 0;
+ return false;
}
skip_size_check:
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->symtree->n.sym->attr.proc_pointer
+ || gfc_is_proc_ptr_comp (a->expr)))
|| (a->expr->expr_type == EXPR_FUNCTION
- && a->expr->symtree->n.sym->result->attr.proc_pointer)
- || gfc_is_proc_ptr_comp (a->expr)))
+ && is_procptr_result (a->expr))))
{
if (where)
- gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ gfc_error ("Expected a procedure pointer for argument %qs at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
/* Satisfy F03:12.4.1.3 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (f->sym->attr.flavor == FL_PROCEDURE
- && gfc_expr_attr (a->expr).flavor != FL_PROCEDURE)
+ && !((a->expr->expr_type == EXPR_VARIABLE
+ && (a->expr->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ || a->expr->symtree->n.sym->attr.proc_pointer
+ || gfc_is_proc_ptr_comp (a->expr)))
+ || (a->expr->expr_type == EXPR_FUNCTION
+ && is_procptr_result (a->expr))))
{
if (where)
- gfc_error ("Expected a procedure for argument '%s' at %L",
+ gfc_error ("Expected a procedure for argument %qs at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
&& a->expr->ref->u.ar.type == AR_FULL)))
{
if (where)
- gfc_error ("Actual argument for '%s' cannot be an assumed-size"
+ gfc_error ("Actual argument for %qs cannot be an assumed-size"
" array at %L", f->sym->name, where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
&& compare_pointer (f->sym, a->expr) == 0)
{
if (where)
- gfc_error ("Actual argument for '%s' must be a pointer at %L",
+ gfc_error ("Actual argument for %qs must be a pointer at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
{
if (where)
gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
- "pointer dummy '%s'", &a->expr->where,f->sym->name);
- return 0;
+ "pointer dummy %qs", &a->expr->where,f->sym->name);
+ return false;
}
{
if (where)
gfc_error ("Coindexed actual argument at %L to pointer "
- "dummy '%s'",
+ "dummy %qs",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, 12.5.2.5 (no constraint). */
{
if (where)
gfc_error ("Coindexed actual argument at %L to allocatable "
- "dummy '%s' requires INTENT(IN)",
+ "dummy %qs requires INTENT(IN)",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, C1237. */
{
if (where)
gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
- "%L requires that dummy '%s' has neither "
+ "%L requires that dummy %qs has neither "
"ASYNCHRONOUS nor VOLATILE", &a->expr->where,
f->sym->name);
- return 0;
+ return false;
}
/* Fortran 2008, 12.5.2.4 (no constraint). */
{
if (where)
gfc_error ("Coindexed actual argument at %L with allocatable "
- "ultimate component to dummy '%s' requires either VALUE "
+ "ultimate component to dummy %qs requires either VALUE "
"or INTENT(IN)", &a->expr->where, f->sym->name);
- return 0;
+ return false;
}
if (f->sym->ts.type == BT_CLASS
&& !full_array)
{
if (where)
- gfc_error ("Actual CLASS array argument for '%s' must be a full "
+ gfc_error ("Actual CLASS array argument for %qs must be a full "
"array at %L", f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
if (a->expr->expr_type != EXPR_NULL
- && compare_allocatable (f->sym, a->expr) == 0)
+ && !compare_allocatable (f->sym, a->expr))
{
if (where)
- gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+ gfc_error ("Actual argument for %qs must be ALLOCATABLE at %L",
f->sym->name, &a->expr->where);
- return 0;
+ return false;
}
/* Check intent = OUT/INOUT for definable actual argument. */
&& CLASS_DATA (f->sym)->attr.class_pointer)
|| (f->sym->ts.type != BT_CLASS && f->sym->attr.pointer))
&& !gfc_check_vardef_context (a->expr, true, false, false, context))
- return 0;
+ return false;
if (!gfc_check_vardef_context (a->expr, false, false, false, context))
- return 0;
+ return false;
}
if ((f->sym->attr.intent == INTENT_OUT
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'",
+ "of the dummy argument %qs",
&a->expr->where, f->sym->name);
- return 0;
+ return false;
}
/* C1232 (R1221) For an actual argument which is an array section or
shape array, if the dummy argument has the VOLATILE attribute. */
if (f->sym->attr.volatile_
+ && a->expr->expr_type == EXPR_VARIABLE
&& 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",
+ "dummy argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
- return 0;
+ return false;
}
+ /* Find the last array_ref. */
+ actual_arr_ref = NULL;
+ if (a->expr->ref)
+ actual_arr_ref = gfc_find_array_ref (a->expr, true);
+
if (f->sym->attr.volatile_
- && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
+ && actual_arr_ref && actual_arr_ref->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;
+ "dummy argument %qs due to VOLATILE attribute",
+ &a->expr->where, f->sym->name);
+ return false;
}
/* C1233 (R1221) For an actual argument which is a pointer array, the
dummy argument has the VOLATILE attribute. */
if (f->sym->attr.volatile_
+ && a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym->attr.pointer
&& a->expr->symtree->n.sym->as
&& !(f->sym->as
if (where)
gfc_error ("Pointer-array actual argument at %L requires "
"an assumed-shape or pointer-array dummy "
- "argument '%s' due to VOLATILE attribute",
+ "argument %qs due to VOLATILE attribute",
&a->expr->where,f->sym->name);
- return 0;
+ return false;
}
match:
if (where)
gfc_error ("Missing alternate return spec in subroutine call "
"at %L", where);
- return 0;
+ return false;
}
if (!f->sym->attr.optional)
{
if (where)
- gfc_error ("Missing actual argument for argument '%s' at %L",
+ gfc_error ("Missing actual argument for argument %qs at %L",
f->sym->name, where);
- return 0;
+ return false;
}
}
if (na != 0)
{
- temp = *new_arg[0];
- *new_arg[0] = *actual;
- *actual = temp;
-
- a = new_arg[0];
- new_arg[0] = new_arg[na];
- new_arg[na] = a;
+ std::swap (*new_arg[0], *actual);
+ std::swap (new_arg[0], new_arg[na]);
}
for (i = 0; i < n - 1; i++)
if (a->expr == NULL && a->label == NULL)
a->missing_arg_type = f->sym->ts.type;
- return 1;
+ return true;
}
|| (f1_intent == INTENT_OUT && f2_intent == INTENT_IN)
|| (f1_intent == INTENT_OUT && f2_intent == INTENT_OUT))
{
- gfc_warning ("Same actual argument associated with INTENT(%s) "
- "argument '%s' and INTENT(%s) argument '%s' at %L",
+ gfc_warning (0, "Same actual argument associated with INTENT(%s) "
+ "argument %qs and INTENT(%s) argument %qs at %L",
gfc_intent_string (f1_intent), p[i].f->sym->name,
gfc_intent_string (f2_intent), p[j].f->sym->name,
&p[i].a->expr->where);
for (;; f = f->next, a = a->next)
{
+ gfc_expr *expr;
+
if (f == NULL && a == NULL)
break;
if (f == NULL || a == NULL)
gfc_internal_error ("check_intents(): List mismatch");
- if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
+ if (a->expr && a->expr->expr_type == EXPR_FUNCTION
+ && a->expr->value.function.isym
+ && a->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ expr = a->expr->value.function.actual->expr;
+ else
+ expr = a->expr;
+
+ if (expr == NULL || expr->expr_type != EXPR_VARIABLE)
continue;
f_intent = f->sym->attr.intent;
- if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (expr->symtree->n.sym))
{
if ((f->sym->ts.type == BT_CLASS && f->sym->attr.class_ok
&& CLASS_DATA (f->sym)->attr.class_pointer)
{
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
- &a->expr->where);
+ &expr->where);
return false;
}
}
/* Fortran 2008, C1283. */
- if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
+ if (gfc_pure (NULL) && gfc_is_coindexed (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));
+ &expr->where, gfc_intent_string (f_intent));
return false;
}
{
gfc_error ("Coindexed actual argument at %L in PURE procedure "
"is passed to a POINTER dummy argument",
- &a->expr->where);
+ &expr->where);
return false;
}
}
/* F2008, Section 12.5.2.4. */
- if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
- && gfc_is_coindexed (a->expr))
+ if (expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
+ && gfc_is_coindexed (expr))
{
gfc_error ("Coindexed polymorphic actual argument at %L is passed "
- "polymorphic dummy argument '%s'",
- &a->expr->where, f->sym->name);
+ "polymorphic dummy argument %qs",
+ &expr->where, f->sym->name);
return false;
}
}
for calling a ISO_C_BINDING because 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 (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",
+ if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
+ {
+ gfc_error ("Procedure %qs called at %L is not explicitly declared",
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",
+ return false;
+ }
+ if (warn_implicit_interface)
+ gfc_warning (OPT_Wimplicit_interface,
+ "Procedure %qs called with an implicit interface at %L",
+ sym->name, where);
+ else if (warn_implicit_procedure && sym->attr.proc == PROC_UNKNOWN)
+ gfc_warning (OPT_Wimplicit_procedure,
+ "Procedure %qs called at %L is not explicitly declared",
sym->name, where);
}
if (sym->attr.pointer)
{
- gfc_error("The pointer object '%s' at %L must have an explicit "
- "function interface or be declared as array",
- sym->name, where);
+ gfc_error ("The pointer object %qs at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
return false;
}
if (sym->attr.allocatable && !sym->attr.external)
{
- gfc_error("The allocatable object '%s' at %L must have an explicit "
- "function interface or be declared as array",
- sym->name, where);
+ gfc_error ("The allocatable object %qs at %L must have an explicit "
+ "function interface or be declared as array",
+ sym->name, where);
return false;
}
if (sym->attr.allocatable)
{
- gfc_error("Allocatable function '%s' at %L must have an explicit "
- "function interface", sym->name, where);
+ gfc_error ("Allocatable function %qs at %L must have an explicit "
+ "function interface", sym->name, where);
return false;
}
/* 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);
+ gfc_error ("Keyword argument requires explicit interface "
+ "for procedure %qs at %L", sym->name, &a->expr->where);
break;
}
&& a->expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
|| gfc_expr_attr (a->expr).lock_comp))
{
- gfc_error("Actual argument of LOCK_TYPE or with LOCK_TYPE "
- "component at %L requires an explicit interface for "
- "procedure '%s'", &a->expr->where, sym->name);
+ gfc_error ("Actual argument of LOCK_TYPE or with LOCK_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
+ break;
+ }
+
+ if (a->expr
+ && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
+ && ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && a->expr->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || gfc_expr_attr (a->expr).event_comp))
+ {
+ gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
+ "component at %L requires an explicit interface for "
+ "procedure %qs", &a->expr->where, sym->name);
break;
}
if (!check_intents (dummy_args, *ap))
return false;
- if (gfc_option.warn_aliasing)
+ if (warn_aliasing)
check_some_aliasing (dummy_args, *ap);
return true;
/* Warn about calls with an implicit interface. Special case
for calling a ISO_C_BINDING because c_loc and c_funloc
are pseudo-unknown. */
- if (gfc_option.warn_implicit_interface
+ if (warn_implicit_interface
&& comp->attr.if_source == IFSRC_UNKNOWN
&& !comp->attr.is_iso_c)
- gfc_warning ("Procedure pointer component '%s' called with an implicit "
+ gfc_warning (OPT_Wimplicit_interface,
+ "Procedure pointer component %qs called with an implicit "
"interface at %L", comp->name, where);
if (comp->attr.if_source == IFSRC_UNKNOWN)
/* 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);
+ gfc_error ("Keyword argument requires explicit interface "
+ "for procedure pointer component %qs at %L",
+ comp->name, &a->expr->where);
break;
}
}
return;
check_intents (comp->ts.interface->formal, *ap);
- if (gfc_option.warn_aliasing)
+ if (warn_aliasing)
check_some_aliasing (comp->ts.interface->formal, *ap);
}
gfc_formal_arglist *dummy_args;
bool r;
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+ if (sym->attr.flavor != FL_PROCEDURE)
+ return false;
dummy_args = gfc_sym_get_dummy_args (sym);
if (compare_actual_formal (args, dummy_args, r, !r, NULL))
{
check_intents (dummy_args, *args);
- if (gfc_option.warn_aliasing)
+ if (warn_aliasing)
check_some_aliasing (dummy_args, *args);
return true;
}
for (; intr; intr = intr->next)
{
- if (intr->sym->attr.flavor == FL_DERIVED)
+ if (gfc_fl_struct (intr->sym->attr.flavor))
continue;
if (sub_flag && intr->sym->attr.function)
continue;
if (st)
return st;
}
- gfc_internal_error ("Unable to find symbol %s", sym->name);
+ gfc_internal_error ("Unable to find symbol %qs", sym->name);
/* Not reached. */
}
if (base->expr->ts.type == BT_CLASS)
{
- if (CLASS_DATA (base->expr) == NULL
+ if (!base->expr->ts.u.derived || CLASS_DATA (base->expr) == NULL
|| !gfc_expr_attr (base->expr).class_ok)
continue;
derived = CLASS_DATA (base->expr)->ts.u.derived;
gfc_user_op *uop;
gfc_intrinsic_op i;
const char *gname;
+ gfc_typebound_proc* tbo;
+ gfc_expr* tb_base;
sym = NULL;
i = fold_unary_intrinsic (e->value.op.op);
+ /* 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)
+ {
+ gcc_assert (tb_base);
+ build_compcall_for_operator (e, actual, tb_base, tbo, gname);
+
+ if (!gfc_resolve_expr (e))
+ return MATCH_ERROR;
+ else
+ return MATCH_YES;
+ }
+
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
if (sym == NULL)
{
- gfc_typebound_proc* tbo;
- gfc_expr* tb_base;
-
- /* See if we find a matching type-bound operator. */
- if (i == INTRINSIC_USER)
- tbo = matching_typebound_op (&tb_base, actual,
- i, e->value.op.uop->name, &gname);
- else
- switch (i)
- {
-#define CHECK_OS_COMPARISON(comp) \
- case INTRINSIC_##comp: \
- case INTRINSIC_##comp##_OS: \
- tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp, NULL, &gname); \
- if (!tbo) \
- tbo = matching_typebound_op (&tb_base, actual, \
- INTRINSIC_##comp##_OS, NULL, &gname); \
- break;
- CHECK_OS_COMPARISON(EQ)
- CHECK_OS_COMPARISON(NE)
- CHECK_OS_COMPARISON(GT)
- CHECK_OS_COMPARISON(GE)
- CHECK_OS_COMPARISON(LT)
- CHECK_OS_COMPARISON(LE)
-#undef CHECK_OS_COMPARISON
-
- default:
- tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
- break;
- }
-
- /* If there is a matching typebound-operator, replace the expression with
- a call to it and succeed. */
- if (tbo)
- {
- bool result;
-
- gcc_assert (tb_base);
- build_compcall_for_operator (e, actual, tb_base, tbo, gname);
-
- result = gfc_resolve_expr (e);
- if (!result)
- return MATCH_ERROR;
-
- return MATCH_YES;
- }
-
/* Don't use gfc_free_actual_arglist(). */
free (actual->next);
free (actual);
-
return MATCH_NO;
}
{
if (ip->sym == new_sym)
{
- gfc_error ("Entity '%s' at %L is already present in the interface",
+ gfc_error ("Entity %qs at %L is already present in the interface",
new_sym->name, &loc);
return false;
}
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
- if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
+ if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
- || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
+ || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
- if (!gfc_check_new_interface (ns->op[current_interface.op],
+ if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
if (sym == NULL)
continue;
- if (!gfc_check_new_interface (sym->generic,
+ if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
break;
case INTERFACE_USER_OP:
- if (!gfc_check_new_interface (current_interface.uop->op,
+ if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
{
case INTERFACE_INTRINSIC_OP:
return current_interface.ns->op[current_interface.op];
- break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
return current_interface.sym->generic;
- break;
case INTERFACE_USER_OP:
return current_interface.uop->op;
- break;
default:
gcc_unreachable ();
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
/* If the overwritten procedure is GENERIC, this is an error. */
if (old->n.tb->is_generic)
{
- gfc_error ("Can't overwrite GENERIC '%s' at %L",
+ gfc_error ("Can't overwrite GENERIC %qs at %L",
old->name, &proc->n.tb->where);
return false;
}
/* Check that overridden binding is not NON_OVERRIDABLE. */
if (old->n.tb->non_overridable)
{
- gfc_error ("'%s' at %L overrides a procedure binding declared"
+ gfc_error ("%qs at %L overrides a procedure binding declared"
" NON_OVERRIDABLE", proc->name, &where);
return false;
}
/* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
if (!old->n.tb->deferred && proc->n.tb->deferred)
{
- gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
+ gfc_error ("%qs at %L must not be DEFERRED as it overrides a"
" non-DEFERRED binding", proc->name, &where);
return false;
}
/* If the overridden binding is PURE, the overriding must be, too. */
if (old_target->attr.pure && !proc_target->attr.pure)
{
- gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE",
+ gfc_error ("%qs at %L overrides a PURE procedure and must also be PURE",
proc->name, &where);
return false;
}
is not, the overriding must not be either. */
if (old_target->attr.elemental && !proc_target->attr.elemental)
{
- gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be"
+ gfc_error ("%qs at %L overrides an ELEMENTAL procedure and must also be"
" ELEMENTAL", proc->name, &where);
return false;
}
if (!old_target->attr.elemental && proc_target->attr.elemental)
{
- gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not"
+ gfc_error ("%qs at %L overrides a non-ELEMENTAL procedure and must not"
" be ELEMENTAL, either", proc->name, &where);
return false;
}
SUBROUTINE. */
if (old_target->attr.subroutine && !proc_target->attr.subroutine)
{
- gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a"
+ gfc_error ("%qs at %L overrides a SUBROUTINE and must also be a"
" SUBROUTINE", proc->name, &where);
return false;
}
{
if (!proc_target->attr.function)
{
- gfc_error ("'%s' at %L overrides a FUNCTION and must also be a"
+ gfc_error ("%qs at %L overrides a FUNCTION and must also be a"
" FUNCTION", proc->name, &where);
return false;
}
- if (!check_result_characteristics (proc_target, old_target, err,
- sizeof(err)))
+ if (!gfc_check_result_characteristics (proc_target, old_target,
+ err, sizeof(err)))
{
gfc_error ("Result mismatch for the overriding procedure "
- "'%s' at %L: %s", proc->name, &where, err);
+ "%qs at %L: %s", proc->name, &where, err);
return false;
}
}
if (old->n.tb->access == ACCESS_PUBLIC
&& proc->n.tb->access == ACCESS_PRIVATE)
{
- gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be"
+ gfc_error ("%qs at %L overrides a PUBLIC procedure and must not be"
" PRIVATE", proc->name, &where);
return false;
}
/* Check that the names correspond. */
if (strcmp (proc_formal->sym->name, old_formal->sym->name))
{
- gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as"
+ gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
" to match the corresponding argument of the overridden"
" procedure", proc_formal->sym->name, proc->name, &where,
old_formal->sym->name);
}
check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
- if (!check_dummy_characteristics (proc_formal->sym, old_formal->sym,
+ if (!gfc_check_dummy_characteristics (proc_formal->sym, old_formal->sym,
check_type, err, sizeof(err)))
{
- gfc_error ("Argument mismatch for the overriding procedure "
- "'%s' at %L: %s", proc->name, &where, err);
+ gfc_error_opt (OPT_Wargument_mismatch,
+ "Argument mismatch for the overriding procedure "
+ "%qs at %L: %s", proc->name, &where, err);
return false;
}
}
if (proc_formal || old_formal)
{
- gfc_error ("'%s' at %L must have the same number of formal arguments as"
+ gfc_error ("%qs at %L must have the same number of formal arguments as"
" the overridden procedure", proc->name, &where);
return false;
}
NOPASS. */
if (old->n.tb->nopass && !proc->n.tb->nopass)
{
- gfc_error ("'%s' at %L overrides a NOPASS binding and must also be"
+ gfc_error ("%qs at %L overrides a NOPASS binding and must also be"
" NOPASS", proc->name, &where);
return false;
}
{
if (proc->n.tb->nopass)
{
- gfc_error ("'%s' at %L overrides a binding with PASS and must also be"
+ gfc_error ("%qs at %L overrides a binding with PASS and must also be"
" PASS", proc->name, &where);
return false;
}
if (proc_pass_arg != old_pass_arg)
{
- gfc_error ("Passed-object dummy argument of '%s' at %L must be at"
+ gfc_error ("Passed-object dummy argument of %qs at %L must be at"
" the same position as the passed-object dummy argument of"
" the overridden procedure", proc->name, &where);
return false;
return true;
}
+
+
+/* The following three functions check that the formal arguments
+ of user defined derived type IO procedures are compliant with
+ the requirements of the standard. */
+
+static void
+check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
+ int kind, int rank, sym_intent intent)
+{
+ if (fsym->ts.type != type)
+ {
+ gfc_error ("DTIO dummy argument at %L must be of type %s",
+ &fsym->declared_at, gfc_basic_typename (type));
+ return;
+ }
+
+ if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
+ && fsym->ts.kind != kind)
+ gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
+ &fsym->declared_at, kind);
+
+ if (!typebound
+ && rank == 0
+ && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
+ || ((type != BT_CLASS) && fsym->attr.dimension)))
+ gfc_error ("DTIO dummy argument at %L be a scalar",
+ &fsym->declared_at);
+ else if (rank == 1
+ && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
+ gfc_error ("DTIO dummy argument at %L must be an "
+ "ASSUMED SHAPE ARRAY", &fsym->declared_at);
+
+ if (fsym->attr.intent != intent)
+ gfc_error ("DTIO dummy argument at %L must have intent %s",
+ &fsym->declared_at, gfc_code2string (intents, (int)intent));
+ return;
+}
+
+
+static void
+check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
+ bool typebound, bool formatted, int code)
+{
+ gfc_symbol *dtio_sub, *generic_proc, *fsym;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ gfc_interface *intr;
+ gfc_formal_arglist *formal;
+ int arg_num;
+
+ bool read = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_RUF);
+ bt type;
+ sym_intent intent;
+ int kind;
+
+ dtio_sub = NULL;
+ if (typebound)
+ {
+ /* Typebound DTIO binding. */
+ tb_io_proc = tb_io_st->n.tb;
+ if (tb_io_proc == NULL)
+ return;
+
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ if (specific_proc == NULL || specific_proc->is_generic)
+ return;
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+ else
+ {
+ generic_proc = tb_io_st->n.sym;
+ if (generic_proc == NULL || generic_proc->generic == NULL)
+ return;
+
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ if (intr->sym && intr->sym->formal && intr->sym->formal->sym
+ && ((intr->sym->formal->sym->ts.type == BT_CLASS
+ && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
+ == derived)
+ || (intr->sym->formal->sym->ts.type == BT_DERIVED
+ && intr->sym->formal->sym->ts.u.derived == derived)))
+ {
+ dtio_sub = intr->sym;
+ break;
+ }
+ else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
+ {
+ gfc_error ("Alternate return at %L is not permitted in a DTIO "
+ "procedure", &intr->sym->declared_at);
+ return;
+ }
+ }
+
+ if (dtio_sub == NULL)
+ return;
+ }
+
+ gcc_assert (dtio_sub);
+ if (!dtio_sub->attr.subroutine)
+ gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
+ dtio_sub->name, &dtio_sub->declared_at);
+
+ arg_num = 0;
+ for (formal = dtio_sub->formal; formal; formal = formal->next)
+ arg_num++;
+
+ if (arg_num < (formatted ? 6 : 4))
+ {
+ gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
+ dtio_sub->name, &dtio_sub->declared_at);
+ return;
+ }
+
+ if (arg_num > (formatted ? 6 : 4))
+ {
+ gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
+ dtio_sub->name, &dtio_sub->declared_at);
+ return;
+ }
+
+
+ /* Now go through the formal arglist. */
+ arg_num = 1;
+ for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
+ {
+ if (!formatted && arg_num == 3)
+ arg_num = 5;
+ fsym = formal->sym;
+
+ if (fsym == NULL)
+ {
+ gfc_error ("Alternate return at %L is not permitted in a DTIO "
+ "procedure", &dtio_sub->declared_at);
+ return;
+ }
+
+ switch (arg_num)
+ {
+ case(1): /* DTV */
+ type = derived->attr.sequence || derived->attr.is_bind_c ?
+ BT_DERIVED : BT_CLASS;
+ kind = 0;
+ intent = read ? INTENT_INOUT : INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+
+ case(2): /* UNIT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(3): /* IOTYPE */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(4): /* VLIST */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 1, intent);
+ break;
+ case(5): /* IOSTAT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_OUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(6): /* IOMSG */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_INOUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ derived->attr.has_dtio_procs = 1;
+ return;
+}
+
+void
+gfc_check_dtio_interfaces (gfc_symbol *derived)
+{
+ gfc_symtree *tb_io_st;
+ bool t = false;
+ int code;
+ bool formatted;
+
+ if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
+ return;
+
+ /* Check typebound DTIO bindings. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs, code),
+ true, &derived->declared_at);
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
+ }
+
+ /* Check generic DTIO interfaces. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_symtree (derived->ns->sym_root,
+ gfc_code2string (dtio_procs, code));
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
+ }
+}
+
+
+gfc_symtree*
+gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+{
+ gfc_symtree *tb_io_st = NULL;
+ bool t = false;
+
+ if (!derived || derived->attr.flavor != FL_DERIVED)
+ return NULL;
+
+ /* Try to find a typebound DTIO binding. */
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RF),
+ true,
+ &derived->declared_at);
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF),
+ true,
+ &derived->declared_at);
+ }
+ return tb_io_st;
+}
+
+
+gfc_symbol *
+gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+{
+ gfc_symtree *tb_io_st = NULL;
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *extended;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+
+ tb_io_st = gfc_find_typebound_dtio_proc (derived, write, formatted);
+
+ if (tb_io_st != NULL)
+ {
+ const char *genname;
+ gfc_symtree *st;
+
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ /* Go back and make sure that we have the right specific procedure.
+ Here we most likely have a procedure from the parent type, which
+ can be overridden in extensions. */
+ genname = tb_io_proc->u.generic->specific_st->name;
+ st = gfc_find_typebound_proc (derived, NULL, genname,
+ true, &tb_io_proc->where);
+ if (st)
+ dtio_sub = st->n.tb->u.specific->n.sym;
+ else
+ dtio_sub = specific_proc->u.specific->n.sym;
+
+ goto finish;
+ }
+
+ /* If there is not a typebound binding, look for a generic
+ DTIO interface. */
+ for (extended = derived; extended;
+ extended = gfc_get_derived_super_type (extended))
+ {
+ if (extended == NULL || extended->ns == NULL
+ || extended->attr.flavor == FL_UNKNOWN)
+ return NULL;
+
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RF));
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF));
+ }
+
+ if (tb_io_st != NULL
+ && tb_io_st->n.sym
+ && tb_io_st->n.sym->generic)
+ {
+ for (gfc_interface *intr = tb_io_st->n.sym->generic;
+ intr && intr->sym; intr = intr->next)
+ {
+ if (intr->sym->formal)
+ {
+ gfc_symbol *fsym = intr->sym->formal->sym;
+ if ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->ts.u.derived == extended)
+ || (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived == extended))
+ {
+ dtio_sub = intr->sym;
+ break;
+ }
+ }
+ }
+ }
+ }
+
+finish:
+ if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+ gfc_find_derived_vtab (derived);
+
+ return dtio_sub;
+}
projects / thirdparty / gcc.git / blobdiff