/* Deal with interfaces.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
Free Software Foundation, Inc.
Contributed by Andy Vaught
if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
return 0;
- if (gfc_compare_types (&dt1->ts, &dt2->ts) == 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.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+ && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
+ return 0;
+
+ else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+ && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
+ return 0;
+
+ else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived)
+ && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.derived))
return 0;
dt1 = dt1->next;
static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
+static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
/* Given two symbols that are formal arguments, compare their types
and rank and their formal interfaces if they are both dummy
if (sym == NULL)
{
gfc_error ("Alternate return cannot appear in operator "
- "interface at %L", &intr->where);
+ "interface at %L", &intr->sym->declared_at);
return;
}
if (args == 0)
|| (args == 2 && operator == INTRINSIC_NOT))
{
gfc_error ("Operator interface at %L has the wrong number of arguments",
- &intr->where);
+ &intr->sym->declared_at);
return;
}
if (!sym->attr.subroutine)
{
gfc_error ("Assignment operator interface at %L must be "
- "a SUBROUTINE", &intr->where);
+ "a SUBROUTINE", &intr->sym->declared_at);
return;
}
if (args != 2)
{
gfc_error ("Assignment operator interface at %L must have "
- "two arguments", &intr->where);
+ "two arguments", &intr->sym->declared_at);
return;
}
+
+ /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
+ - First argument an array with different rank than second,
+ - Types and kinds do not conform, and
+ - First argument is of derived type. */
if (sym->formal->sym->ts.type != BT_DERIVED
- && sym->formal->next->sym->ts.type != BT_DERIVED
+ && (r1 == 0 || r1 == r2)
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
|| (gfc_numeric_ts (&sym->formal->sym->ts)
&& gfc_numeric_ts (&sym->formal->next->sym->ts))))
{
gfc_error ("Assignment operator interface at %L must not redefine "
- "an INTRINSIC type assignment", &intr->where);
+ "an INTRINSIC type assignment", &intr->sym->declared_at);
return;
}
}
if (!sym->attr.function)
{
gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
- &intr->where);
+ &intr->sym->declared_at);
return;
}
}
{
if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
gfc_error ("First argument of defined assignment at %L must be "
- "INTENT(IN) or INTENT(INOUT)", &intr->where);
+ "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
if (i2 != INTENT_IN)
gfc_error ("Second argument of defined assignment at %L must be "
- "INTENT(IN)", &intr->where);
+ "INTENT(IN)", &intr->sym->declared_at);
}
else
{
if (i1 != INTENT_IN)
gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
+ "INTENT(IN)", &intr->sym->declared_at);
if (args == 2 && i2 != INTENT_IN)
gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
+ "INTENT(IN)", &intr->sym->declared_at);
}
/* From now on, all we have to do is check that the operator definition
/* Build an array of integers that gives the same integer to
arguments of the same type/rank. */
- arg = gfc_getmem (n1 * sizeof (arginfo));
+ arg = XCNEWVEC (arginfo, n1);
f = f1;
for (i = 0; i < n1; i++, f = f->next)
gfc_formal_arglist *f1, *f2;
if (s1->attr.function != s2->attr.function
- && s1->attr.subroutine != s2->attr.subroutine)
+ || s1->attr.subroutine != s2->attr.subroutine)
return 0; /* Disagreement between function/subroutine. */
f1 = s1->formal;
}
+static int
+compare_intr_interfaces (gfc_symbol *s1, gfc_symbol *s2)
+{
+ gfc_formal_arglist *f, *f1;
+ gfc_intrinsic_arg *fi, *f2;
+ gfc_intrinsic_sym *isym;
+
+ if (s1->attr.function != s2->attr.function
+ || s1->attr.subroutine != s2->attr.subroutine)
+ return 0; /* Disagreement between function/subroutine. */
+
+ /* If the arguments are functions, check type and kind. */
+
+ if (s1->attr.dummy && s1->attr.function && s2->attr.function)
+ {
+ if (s1->ts.type != s2->ts.type)
+ return 0;
+ if (s1->ts.kind != s2->ts.kind)
+ return 0;
+ if (s1->attr.if_source == IFSRC_DECL)
+ return 1;
+ }
+
+ isym = gfc_find_function (s2->name);
+
+ /* This should already have been checked in
+ resolve.c (resolve_actual_arglist). */
+ gcc_assert (isym);
+
+ f1 = s1->formal;
+ f2 = isym->formal;
+
+ /* Special case. */
+ if (f1 == NULL && f2 == NULL)
+ return 1;
+
+ /* First scan through the formal argument list and check the intrinsic. */
+ fi = f2;
+ for (f = f1; f; f = f->next)
+ {
+ if (fi == NULL)
+ return 0;
+ if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
+ return 0;
+ fi = fi->next;
+ }
+
+ /* Now scan through the intrinsic argument list and check the formal. */
+ f = f1;
+ for (fi = f2; fi; fi = fi->next)
+ {
+ if (f == NULL)
+ return 0;
+ if ((fi->ts.type != f->sym->ts.type) || (fi->ts.kind != f->sym->ts.kind))
+ return 0;
+ f = f->next;
+ }
+
+ return 1;
+}
+
+
+/* Compare an actual argument list with an intrinsic argument list. */
+
+static int
+compare_actual_formal_intr (gfc_actual_arglist **ap, gfc_symbol *s2)
+{
+ gfc_actual_arglist *a;
+ gfc_intrinsic_arg *fi, *f2;
+ gfc_intrinsic_sym *isym;
+
+ isym = gfc_find_function (s2->name);
+
+ /* This should already have been checked in
+ resolve.c (resolve_actual_arglist). */
+ gcc_assert (isym);
+
+ f2 = isym->formal;
+
+ /* Special case. */
+ if (*ap == NULL && f2 == NULL)
+ return 1;
+
+ /* First scan through the actual argument list and check the intrinsic. */
+ fi = f2;
+ for (a = *ap; a; a = a->next)
+ {
+ if (fi == NULL)
+ return 0;
+ if ((fi->ts.type != a->expr->ts.type)
+ || (fi->ts.kind != a->expr->ts.kind))
+ return 0;
+ fi = fi->next;
+ }
+
+ /* Now scan through the intrinsic argument list and check the formal. */
+ a = *ap;
+ for (fi = f2; fi; fi = fi->next)
+ {
+ if (a == NULL)
+ return 0;
+ if ((fi->ts.type != a->expr->ts.type)
+ || (fi->ts.kind != a->expr->ts.kind))
+ return 0;
+ a = a->next;
+ }
+
+ return 1;
+}
+
+
/* Given a pointer to an interface pointer, remove duplicate
interfaces and make sure that all symbols are either functions or
subroutines. Returns nonzero if something goes wrong. */
for (p = sym->generic; p; p = p->next)
{
- if (p->sym->attr.mod_proc && p->sym->attr.if_source != IFSRC_DECL)
+ if (p->sym->attr.mod_proc
+ && (p->sym->attr.if_source != IFSRC_DECL
+ || p->sym->attr.procedure))
{
gfc_error ("'%s' at %L is not a module procedure",
p->sym->name, &p->where);
static int
compare_parameter (gfc_symbol *formal, gfc_expr *actual,
- int ranks_must_agree, int is_elemental)
+ int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
+ bool rank_check;
/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
procs c_f_pointer or c_f_procpointer, and we need to accept most
if (actual->ts.type == BT_PROCEDURE)
{
if (formal->attr.flavor != FL_PROCEDURE)
- return 0;
+ goto proc_fail;
if (formal->attr.function
&& !compare_type_rank (formal, actual->symtree->n.sym))
- return 0;
+ goto proc_fail;
if (formal->attr.if_source == IFSRC_UNKNOWN
|| actual->symtree->n.sym->attr.external)
return 1; /* Assume match. */
- return compare_interfaces (formal, actual->symtree->n.sym, 0);
+ if (actual->symtree->n.sym->attr.intrinsic)
+ {
+ if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
+ goto proc_fail;
+ }
+ else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
+ goto proc_fail;
+
+ return 1;
+
+ proc_fail:
+ if (where)
+ gfc_error ("Type/rank mismatch in argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
}
if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
&& !gfc_compare_types (&formal->ts, &actual->ts))
- return 0;
+ {
+ 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;
+ }
if (symbol_rank (formal) == actual->rank)
return 1;
- /* At this point the ranks didn't agree. */
- if (ranks_must_agree || formal->attr.pointer)
- return 0;
-
- if (actual->rank != 0)
- return is_elemental || formal->attr.dimension;
+ rank_check = where != NULL && !is_elemental && formal->as
+ && (formal->as->type == AS_ASSUMED_SHAPE
+ || formal->as->type == AS_DEFERRED);
- /* At this point, we are considering a scalar passed to an array.
- This is legal if the scalar is an array element of the right sort. */
- if (formal->as->type == AS_ASSUMED_SHAPE)
- return 0;
-
- for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_SUBSTRING)
+ if (rank_check || ranks_must_agree || formal->attr.pointer
+ || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
+ || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE))
+ {
+ if (where)
+ gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, symbol_rank (formal),
+ actual->rank);
return 0;
+ }
+ else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
+ return 1;
+
+ /* At this point, we are considering a scalar passed to an array. This
+ is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+ - if the actual argument is (a substring of) an element of a
+ non-assumed-shape/non-pointer array;
+ - (F2003) if the actual argument is of type character. */
for (ref = actual->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
break;
- if (ref == NULL)
- return 0; /* Not an array element. */
+ /* Not an array element. */
+ if (formal->ts.type == BT_CHARACTER
+ && (ref == NULL
+ || (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ || actual->symtree->n.sym->attr.pointer))))
+ {
+ if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
+ {
+ gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
+ "array dummy argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
+ }
+ else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
+ return 0;
+ else
+ return 1;
+ }
+ else if (ref == NULL)
+ {
+ if (where)
+ gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, symbol_rank (formal),
+ actual->rank);
+ return 0;
+ }
+
+ if (actual->expr_type == EXPR_VARIABLE
+ && actual->symtree->n.sym->as
+ && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ || actual->symtree->n.sym->attr.pointer))
+ {
+ if (where)
+ gfc_error ("Element of assumed-shaped array passed to dummy "
+ "argument '%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
return 1;
}
{
int i;
long int strlen, elements;
+ long int substrlen = 0;
+ bool is_str_storage = false;
gfc_ref *ref;
if (e == NULL)
for (ref = e->ref; ref; ref = ref->next)
{
+ if (ref->type == REF_SUBSTRING && ref->u.ss.start
+ && ref->u.ss.start->expr_type == EXPR_CONSTANT)
+ {
+ if (is_str_storage)
+ {
+ /* The string length is the substring length.
+ Set now to full string length. */
+ if (ref->u.ss.length == NULL
+ || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
+ }
+ substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
+ continue;
+ }
+
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
&& ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
&& ref->u.ar.as->upper)
if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
&& ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
&& ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
- elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
- - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
+ elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ 1L;
else
return 0;
}
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && e->expr_type == EXPR_VARIABLE)
+ {
+ if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
+ || e->symtree->n.sym->attr.pointer)
+ {
+ elements = 1;
+ continue;
+ }
+
+ /* Determine the number of remaining elements in the element
+ sequence for array element designators. */
+ is_str_storage = true;
+ for (i = ref->u.ar.dimen - 1; i >= 0; i--)
+ {
+ if (ref->u.ar.start[i] == NULL
+ || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->upper[i] == NULL
+ || ref->u.ar.as->lower[i] == NULL
+ || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
+ || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
+ return 0;
+
+ elements
+ = elements
+ * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
+ + 1L)
+ - (mpz_get_si (ref->u.ar.start[i]->value.integer)
+ - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
+ }
+ }
else
- /* TODO: Determine the number of remaining elements in the element
- sequence for array element designators.
- See also get_array_index in data.c. */
return 0;
}
- return elements*strlen;
+ if (substrlen)
+ return (is_str_storage) ? substrlen + (elements-1)*strlen
+ : elements*strlen;
+ else
+ return elements*strlen;
}
gfc_actual_arglist **new, *a, *actual, temp;
gfc_formal_arglist *f;
int i, n, na;
- bool rank_check;
unsigned long actual_size, formal_size;
actual = *ap;
"call at %L", where);
return 0;
}
+
+ if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
+ is_elemental, where))
+ return 0;
- rank_check = where != NULL && !is_elemental && f->sym->as
- && (f->sym->as->type == AS_ASSUMED_SHAPE
- || f->sym->as->type == AS_DEFERRED);
-
- if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
- && a->expr->rank == 0
- && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
- {
- if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
- {
- gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
- "with array dummy argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
- else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
- return 0;
-
- }
- else if (!compare_parameter (f->sym, a->expr,
- ranks_must_agree || rank_check, is_elemental))
- {
- if (where)
- gfc_error ("Type/rank mismatch in argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
-
+ /* Special case for character arguments. For allocatable, pointer
+ and assumed-shape dummies, the string length needs to match
+ exactly. */
if (a->expr->ts.type == BT_CHARACTER
&& a->expr->ts.cl && a->expr->ts.cl->length
&& a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
&& f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
- && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ && f->sym->ts.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.cl->length->value.integer,
+ f->sym->ts.cl->length->value.integer) != 0))
{
- if ((f->sym->attr.pointer || f->sym->attr.allocatable)
- && (mpz_cmp (a->expr->ts.cl->length->value.integer,
- f->sym->ts.cl->length->value.integer) != 0))
- {
- if (where)
- gfc_warning ("Character length mismatch between actual "
- "argument and pointer or allocatable dummy "
- "argument '%s' at %L",
- f->sym->name, &a->expr->where);
- return 0;
- }
+ if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
+ gfc_warning ("Character length mismatch (%ld/%ld) between actual "
+ "argument and pointer or allocatable dummy argument "
+ "'%s' at %L",
+ mpz_get_si (a->expr->ts.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.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.cl->length->value.integer),
+ mpz_get_si (f->sym->ts.cl->length->value.integer),
+ f->sym->name, &a->expr->where);
+ return 0;
}
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
- if (actual_size != 0 && actual_size < formal_size)
+ if (actual_size != 0
+ && actual_size < formal_size
+ && a->expr->ts.type != BT_PROCEDURE)
{
if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
gfc_warning ("Character length of actual argument shorter "
return 0;
}
+ /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+ is provided for a procedure pointer formal argument. */
+ if (f->sym->attr.proc_pointer
+ && !a->expr->symtree->n.sym->attr.proc_pointer)
+ {
+ if (where)
+ gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE
}
/* Check intent = OUT/INOUT for definable actual argument. */
- if (a->expr->expr_type != EXPR_VARIABLE
+ if ((a->expr->expr_type != EXPR_VARIABLE
+ || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
+ && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
&& (f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT))
{
if (where)
- gfc_error ("Actual argument at %L must be definable to "
- "match dummy INTENT = OUT/INOUT", &a->expr->where);
+ gfc_error ("Actual argument at %L must be definable as "
+ "the dummy argument '%s' is INTENT = OUT/INOUT",
+ &a->expr->where, f->sym->name);
return 0;
}
{
if (where)
gfc_error ("Array-section actual argument with vector subscripts "
- "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
+ "at %L is incompatible with INTENT(OUT), INTENT(INOUT) "
"or VOLATILE attribute of the dummy argument '%s'",
&a->expr->where, f->sym->name);
return 0;
*ap = new[0];
/* Note the types of omitted optional arguments. */
- for (a = actual, f = formal; a; a = a->next, f = f->next)
+ for (a = *ap, f = formal; a; a = a->next, f = f->next)
if (a->expr == NULL && a->label == NULL)
a->missing_arg_type = f->sym->ts.type;
return FAILURE;
}
- if (a->expr->symtree->n.sym->attr.pointer)
+ if (f->sym->attr.pointer)
{
gfc_error ("Procedure argument at %L is local to a PURE "
"procedure and has the POINTER attribute",
gfc_warning ("Procedure '%s' called with an implicit interface at %L",
sym->name, where);
- if (sym->attr.if_source == IFSRC_UNKNOWN
- || !compare_actual_formal (ap, sym->formal, 0,
- sym->attr.elemental, where))
+ if (sym->ts.interface && sym->ts.interface->attr.intrinsic)
+ {
+ gfc_intrinsic_sym *isym;
+ isym = gfc_find_function (sym->ts.interface->name);
+ if (isym != NULL)
+ {
+ if (compare_actual_formal_intr (ap, sym->ts.interface))
+ return;
+ gfc_error ("Type/rank mismatch in argument '%s' at %L",
+ sym->name, where);
+ return;
+ }
+ }
+
+ if (sym->attr.if_source == IFSRC_UNKNOWN)
+ {
+ gfc_actual_arglist *a;
+ for (a = *ap; a; a = a->next)
+ {
+ /* Skip g77 keyword extensions like %VAL, %REF, %LOC. */
+ if (a->name != NULL && a->name[0] != '%')
+ {
+ gfc_error("Keyword argument requires explicit interface "
+ "for procedure '%s' at %L", sym->name, &a->expr->where);
+ break;
+ }
+ }
+
+ return;
+ }
+
+ if (!compare_actual_formal (ap, sym->formal, 0,
+ sym->attr.elemental, where))
return;
check_intents (sym->formal, *ap);
rhs = c->expr2;
/* Don't allow an intrinsic assignment to be replaced. */
- if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
+ if (lhs->ts.type != BT_DERIVED
+ && (rhs->rank == 0 || rhs->rank == lhs->rank)
&& (lhs->ts.type == rhs->ts.type
|| (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
return FAILURE;
}
+gfc_interface *
+gfc_current_interface_head (void)
+{
+ switch (current_interface.type)
+ {
+ case INTERFACE_INTRINSIC_OP:
+ return current_interface.ns->operator[current_interface.op];
+ break;
+
+ case INTERFACE_GENERIC:
+ return current_interface.sym->generic;
+ break;
+
+ case INTERFACE_USER_OP:
+ return current_interface.uop->operator;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+void
+gfc_set_current_interface_head (gfc_interface *i)
+{
+ switch (current_interface.type)
+ {
+ case INTERFACE_INTRINSIC_OP:
+ current_interface.ns->operator[current_interface.op] = i;
+ break;
+
+ case INTERFACE_GENERIC:
+ current_interface.sym->generic = i;
+ break;
+
+ case INTERFACE_USER_OP:
+ current_interface.uop->operator = i;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
/* Gets rid of a formal argument list. We do not free symbols.
Symbols are freed when a namespace is freed. */
OSDN Git Service
