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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* Deal with interfaces. An explicit interface is represented as a
Generic interfaces:
The generic name points to a linked list of symbols. Each symbol
- has an explicit interface. Each explicit interface has it's own
+ has an explicit interface. Each explicit interface has its own
namespace containing the arguments. Module procedures are symbols in
which the interface is added later when the module procedure is parsed.
/* Comparing the symbol node names is OK because only use-associated
symbols can be renamed. */
if (type != current_interface.type
- || strcmp (current_interface.sym->name, name) != 0)
+ || strcmp (current_interface.uop->name, name) != 0)
{
gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
- current_interface.sym->name);
+ current_interface.uop->name);
m = MATCH_ERROR;
}
}
-/* Compare two typespecs, recursively if necessary. */
+/* Compare two derived types using the criteria in 4.4.2 of the standard,
+ recursing through gfc_compare_types for the components. */
int
-gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+gfc_compare_derived_types (gfc_symbol * derived1, gfc_symbol * derived2)
{
gfc_component *dt1, *dt2;
- if (ts1->type != ts2->type)
- return 0;
- if (ts1->type != BT_DERIVED)
- return (ts1->kind == ts2->kind);
-
- /* Compare derived types. */
- if (ts1->derived == ts2->derived)
- 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 (ts1->derived->name, ts2->derived->name) == 0
- && ((ts1->derived->module == NULL && ts2->derived->module == NULL)
- || (ts1->derived != NULL && ts2->derived != NULL
- && strcmp (ts1->derived->module, ts2->derived->module) == 0)))
+ if (strcmp (derived1->name, derived2->name) == 0
+ && derived1 != NULL && derived2 != NULL
+ && derived1->module != NULL && derived2->module != NULL
+ && strcmp (derived1->module, derived2->module) == 0)
return 1;
/* Compare type via the rules of the standard. Both types must have
the SEQUENCE attribute to be equal. */
- if (strcmp (ts1->derived->name, ts2->derived->name))
+ if (strcmp (derived1->name, derived2->name))
return 0;
- dt1 = ts1->derived->components;
- dt2 = ts2->derived->components;
+ if (derived1->component_access == ACCESS_PRIVATE
+ || derived2->component_access == ACCESS_PRIVATE)
+ return 0;
- if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
+ if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
return 0;
+ dt1 = derived1->components;
+ dt2 = 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. */
return 1;
}
+/* Compare two typespecs, recursively if necessary. */
+
+int
+gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
+{
+
+ if (ts1->type != ts2->type)
+ return 0;
+ if (ts1->type != BT_DERIVED)
+ return (ts1->kind == ts2->kind);
+
+ /* Compare derived types. */
+ if (ts1->derived == ts2->derived)
+ return 1;
+
+ return gfc_compare_derived_types (ts1->derived ,ts2->derived);
+}
+
/* Given two symbols that are formal arguments, compare their ranks
and types. Returns nonzero if they have the same rank and type,
if (p->sym == q->sym)
continue; /* Duplicates OK here */
- if (strcmp (p->sym->name, q->sym->name) == 0
- && strcmp (p->sym->module, q->sym->module) == 0)
+ if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
if (compare_interfaces (p->sym, q->sym, generic_flag))
/* 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. */
+
+static int
+compare_allocatable (gfc_symbol * formal, gfc_expr * actual)
+{
+ symbol_attribute attr;
+
+ if (formal->attr.allocatable)
+ {
+ attr = gfc_expr_attr (actual);
+ if (!attr.allocatable)
+ return 0;
+ }
+
+ return 1;
+}
+
+
+/* Given a symbol of a formal argument list and an expression, if the
formal argument is a pointer, see if the actual argument is a
pointer. Returns nonzero if compatible, zero if not compatible. */
return compare_interfaces (formal, actual->symtree->n.sym, 0);
}
- if (actual->expr_type != EXPR_NULL
+ if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& !gfc_compare_types (&formal->ts, &actual->ts))
return 0;
gfc_actual_arglist **new, *a, *actual, temp;
gfc_formal_arglist *f;
int i, n, na;
+ bool rank_check;
actual = *ap;
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, is_elemental))
+ (f->sym, a->expr, ranks_must_agree || rank_check, is_elemental))
{
if (where)
gfc_error ("Type/rank mismatch in argument '%s' at %L",
return 0;
}
+ if (f->sym->as
+ && f->sym->as->type == AS_ASSUMED_SHAPE
+ && a->expr->expr_type == EXPR_VARIABLE
+ && a->expr->symtree->n.sym->as
+ && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
+ && (a->expr->ref == NULL
+ || (a->expr->ref->type == REF_ARRAY
+ && a->expr->ref->u.ar.type == AR_FULL)))
+ {
+ if (where)
+ gfc_error ("Actual argument for '%s' cannot be an assumed-size"
+ " array at %L", f->sym->name, where);
+ return 0;
+ }
+
if (a->expr->expr_type != EXPR_NULL
&& compare_pointer (f->sym, a->expr) == 0)
{
return 0;
}
+ if (a->expr->expr_type != EXPR_NULL
+ && compare_allocatable (f->sym, a->expr) == 0)
+ {
+ if (where)
+ gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
+ /* Check intent = OUT/INOUT for definable actual argument. */
+ if (a->expr->expr_type != EXPR_VARIABLE
+ && (f->sym->attr.intent == INTENT_OUT
+ || f->sym->attr.intent == INTENT_INOUT))
+ {
+ gfc_error ("Actual argument at %L must be definable to "
+ "match dummy INTENT = OUT/INOUT", &a->expr->where);
+ return 0;
+ }
+
match:
if (a == actual)
na = i;
void
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)
if (sym->attr.if_source == IFSRC_UNKNOWN
|| !compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, where))
+ sym->attr.elemental, where))
return;
check_intents (sym->formal, *ap);
e->value.function.actual = actual;
e->value.function.esym = NULL;
e->value.function.isym = NULL;
+ e->value.function.name = NULL;
if (gfc_pure (NULL) && !gfc_pure (sym))
{
c->expr2 = NULL;
c->ext.actual = actual;
- if (gfc_pure (NULL) && !gfc_pure (sym))
- {
- gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
- "PURE", sym->name, &c->loc);
- return FAILURE;
- }
-
return SUCCESS;
}
OSDN Git Service
