gfc_typebound_proc*
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
gfc_intrinsic_op op, bool noaccess,
locus* where)
{
gfc_typebound_proc* res;
/* Set default to failure. */
if (t)
*t = FAILURE;
/* Try to find it in the current type's namespace. */
if (derived->f2k_derived)
res = derived->f2k_derived->tb_op[op];
else
res = NULL;
/* Check access. */
if (res && !res->error)
{
/* We found one. */
if (t)
*t = SUCCESS;
if (!noaccess && derived->attr.use_assoc
&& res->access == ACCESS_PRIVATE)
{
if (where)
gfc_error ("'%s' of '%s' is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = FAILURE;
}
return res;
}
/* Otherwise, recurse on parent type if derived is an extension. */
if (derived->attr.extension)
{
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
return gfc_find_typebound_intrinsic_op (super_type, t, op,
noaccess, where);
}
/* Nothing found. */
return NULL;
}
void
gfc_check_interfaces (gfc_namespace * ns)
{
gfc_namespace *old_ns, *ns2;
char interface_name[100];
gfc_intrinsic_op i;
old_ns = gfc_current_ns;
gfc_current_ns = ns;
gfc_traverse_ns (ns, check_sym_interfaces);
gfc_traverse_user_op (ns, check_uop_interfaces);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
{
if (i == INTRINSIC_USER)
continue;
if (i == INTRINSIC_ASSIGN)
strcpy (interface_name, "intrinsic assignment operator");
else
sprintf (interface_name, "intrinsic '%s' operator",
gfc_op2string (i));
if (check_interface0 (ns->operator[i], interface_name))
continue;
check_operator_interface (ns->operator[i], i);
for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
interface_name))
break;
}
gfc_current_ns = old_ns;
}
static void
show_f2k_derived (gfc_namespace* f2k)
{
gfc_finalizer* f;
int op;
show_indent ();
fputs ("Procedure bindings:", dumpfile);
++show_level;
/* Finalizer bindings. */
for (f = f2k->finalizers; f; f = f->next)
{
show_indent ();
fprintf (dumpfile, "FINAL %s", f->proc_tree->n.sym->name);
}
/* Type-bound procedures. */
gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
--show_level;
show_indent ();
fputs ("Operator bindings:", dumpfile);
++show_level;
/* User-defined operators. */
gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
/* Intrinsic operators. */
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
if (f2k->tb_op[op])
show_typebound_proc (f2k->tb_op[op],
gfc_op2string ((gfc_intrinsic_op) op));
--show_level;
}
static void
show_namespace (gfc_namespace *ns)
{
gfc_interface *intr;
gfc_namespace *save;
int op;
gfc_equiv *eq;
int i;
gcc_assert (ns);
save = gfc_current_ns;
show_indent ();
fputs ("Namespace:", dumpfile);
i = 0;
do
{
int l = i;
while (i < GFC_LETTERS - 1
&& gfc_compare_types (&ns->default_type[i+1],
&ns->default_type[l]))
i++;
if (i > l)
fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
else
fprintf (dumpfile, " %c: ", l+'A');
show_typespec(&ns->default_type[l]);
i++;
} while (i < GFC_LETTERS);
if (ns->proc_name != NULL)
{
show_indent ();
fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
}
++show_level;
gfc_current_ns = ns;
gfc_traverse_symtree (ns->common_root, show_common);
gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
/* User operator interfaces */
intr = ns->op[op];
if (intr == NULL)
continue;
show_indent ();
fprintf (dumpfile, "Operator interfaces for %s:",
gfc_op2string ((gfc_intrinsic_op) op));
for (; intr; intr = intr->next)
fprintf (dumpfile, " %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
fputs ("User operators:\n", dumpfile);
gfc_traverse_user_op (ns, show_uop);
}
for (eq = ns->equiv; eq; eq = eq->next)
show_equiv (eq);
fputc ('\n', dumpfile);
show_indent ();
fputs ("code:", dumpfile);
show_code (show_level, ns->code);
--show_level;
for (ns = ns->contained; ns; ns = ns->sibling)
{
fputs ("\nCONTAINS\n", dumpfile);
++show_level;
show_namespace (ns);
--show_level;
}
fputc ('\n', dumpfile);
gfc_current_ns = save;
}
void
gfc_show_namespace (gfc_namespace * ns)
{
gfc_interface *intr;
gfc_namespace *save;
gfc_intrinsic_op op;
gfc_equiv *eq;
int i;
save = gfc_current_ns;
show_level++;
show_indent ();
gfc_status ("Namespace:");
if (ns != NULL)
{
i = 0;
do
{
int l = i;
while (i < GFC_LETTERS - 1
&& gfc_compare_types(&ns->default_type[i+1],
&ns->default_type[l]))
i++;
if (i > l)
gfc_status(" %c-%c: ", l+'A', i+'A');
else
gfc_status(" %c: ", l+'A');
gfc_show_typespec(&ns->default_type[l]);
i++;
} while (i < GFC_LETTERS);
if (ns->proc_name != NULL)
{
show_indent ();
gfc_status ("procedure name = %s", ns->proc_name->name);
}
gfc_current_ns = ns;
gfc_traverse_symtree (ns->common_root, show_common);
gfc_traverse_symtree (ns->sym_root, show_symtree);
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
{
/* User operator interfaces */
intr = ns->operator[op];
if (intr == NULL)
continue;
show_indent ();
gfc_status ("Operator interfaces for %s:", gfc_op2string (op));
for (; intr; intr = intr->next)
gfc_status (" %s", intr->sym->name);
}
if (ns->uop_root != NULL)
{
show_indent ();
gfc_status ("User operators:\n");
gfc_traverse_user_op (ns, show_uop);
}
}
for (eq = ns->equiv; eq; eq = eq->next)
gfc_show_equiv (eq);
gfc_status_char ('\n');
gfc_status_char ('\n');
gfc_show_code (0, ns->code);
for (ns = ns->contained; ns; ns = ns->sibling)
{
show_indent ();
gfc_status ("CONTAINS\n");
gfc_show_namespace (ns);
}
show_level--;
gfc_status_char ('\n');
gfc_current_ns = save;
}
match
gfc_match_end_interface (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_intrinsic_op operator;
match m;
m = gfc_match_space ();
if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
return MATCH_ERROR;
/* If we're not looking at the end of the statement now, or if this
is not a nameless interface but we did not see a space, punt. */
if (gfc_match_eos () != MATCH_YES
|| (type != INTERFACE_NAMELESS
&& m != MATCH_YES))
{
gfc_error
("Syntax error: Trailing garbage in END INTERFACE statement at %C");
return MATCH_ERROR;
}
m = MATCH_YES;
switch (current_interface.type)
{
case INTERFACE_NAMELESS:
if (type != current_interface.type)
{
gfc_error ("Expected a nameless interface at %C");
m = MATCH_ERROR;
}
break;
case INTERFACE_INTRINSIC_OP:
if (type != current_interface.type || operator != current_interface.op)
{
if (current_interface.op == INTRINSIC_ASSIGN)
gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
else
gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
gfc_op2string (current_interface.op));
m = MATCH_ERROR;
}
break;
case INTERFACE_USER_OP:
/* 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)
{
gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
current_interface.sym->name);
m = MATCH_ERROR;
}
break;
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
{
gfc_error ("Expecting 'END INTERFACE %s' at %C",
current_interface.sym->name);
m = MATCH_ERROR;
}
break;
}
return m;
}
