+2009-08-10 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37425
+ * gfortran.h (struct gfc_namespace): New fields tb_uop_root and tb_op.
+ (gfc_find_typebound_user_op): New routine.
+ (gfc_find_typebound_intrinsic_op): Ditto.
+ (gfc_check_operator_interface): Now public routine.
+ * decl.c (gfc_match_generic): Match OPERATOR(X) or ASSIGNMENT(=).
+ * interface.c (check_operator_interface): Made public, renamed to
+ `gfc_check_operator_interface' accordingly and hand in the interface
+ as gfc_symbol rather than gfc_interface so it is useful for type-bound
+ operators, too. Return boolean result.
+ (gfc_check_interfaces): Adapt call to `check_operator_interface'.
+ * symbol.c (gfc_get_namespace): Initialize new field `tb_op'.
+ (gfc_free_namespace): Free `tb_uop_root'-based tree.
+ (find_typebound_proc_uop): New helper function.
+ (gfc_find_typebound_proc): Use it.
+ (gfc_find_typebound_user_op): New method.
+ (gfc_find_typebound_intrinsic_op): Ditto.
+ * resolve.c (resolve_tb_generic_targets): New helper function.
+ (resolve_typebound_generic): Use it.
+ (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): New.
+ (resolve_typebound_procedures): Resolve operators, too.
+ (check_uop_procedure): New, code from gfc_resolve_uops.
+ (gfc_resolve_uops): Moved main code to new `check_uop_procedure'.
+
2009-08-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/40940
gfc_match_generic (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
gfc_symbol* block;
gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
gfc_typebound_proc* tb;
- gfc_symtree* st;
gfc_namespace* ns;
+ interface_type op_type;
+ gfc_intrinsic_op op;
match m;
/* Check current state. */
goto error;
}
- /* The binding name and =>. */
- m = gfc_match (" %n =>", name);
+ /* Match the binding name; depending on type (operator / generic) format
+ it for future error messages into bind_name. */
+
+ m = gfc_match_generic_spec (&op_type, name, &op);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
{
- gfc_error ("Expected generic name at %C");
+ gfc_error ("Expected generic name or operator descriptor at %C");
goto error;
}
- /* If there's already something with this name, check that it is another
- GENERIC and then extend that rather than build a new node. */
- st = gfc_find_symtree (ns->tb_sym_root, name);
- if (st)
+ switch (op_type)
{
- gcc_assert (st->n.tb);
- tb = st->n.tb;
+ case INTERFACE_GENERIC:
+ snprintf (bind_name, sizeof (bind_name), "%s", name);
+ break;
+
+ case INTERFACE_USER_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
+ break;
+
+ case INTERFACE_INTRINSIC_OP:
+ snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
+ gfc_op2string (op));
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ /* Match the required =>. */
+ if (gfc_match (" =>") != MATCH_YES)
+ {
+ gfc_error ("Expected '=>' at %C");
+ goto error;
+ }
+
+ /* Try to find existing GENERIC binding with this name / for this operator;
+ if there is something, check that it is another GENERIC and then extend
+ it rather than building a new node. Otherwise, create it and put it
+ at the right position. */
+
+ switch (op_type)
+ {
+ case INTERFACE_USER_OP:
+ case INTERFACE_GENERIC:
+ {
+ const bool is_op = (op_type == INTERFACE_USER_OP);
+ gfc_symtree* st;
+
+ st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
+ if (st)
+ {
+ tb = st->n.tb;
+ gcc_assert (tb);
+ }
+ else
+ tb = NULL;
+
+ break;
+ }
+
+ case INTERFACE_INTRINSIC_OP:
+ tb = ns->tb_op[op];
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+
+ if (tb)
+ {
if (!tb->is_generic)
{
+ gcc_assert (op_type == INTERFACE_GENERIC);
gfc_error ("There's already a non-generic procedure with binding name"
" '%s' for the derived type '%s' at %C",
- name, block->name);
+ bind_name, block->name);
goto error;
}
if (tb->access != tbattr.access)
{
gfc_error ("Binding at %C must have the same access as already"
- " defined binding '%s'", name);
+ " defined binding '%s'", bind_name);
goto error;
}
}
else
{
- st = gfc_new_symtree (&ns->tb_sym_root, name);
- gcc_assert (st);
-
- st->n.tb = tb = gfc_get_typebound_proc ();
+ tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
tb->access = tbattr.access;
tb->is_generic = 1;
tb->u.generic = NULL;
+
+ switch (op_type)
+ {
+ case INTERFACE_GENERIC:
+ case INTERFACE_USER_OP:
+ {
+ const bool is_op = (op_type == INTERFACE_USER_OP);
+ gfc_symtree* st;
+
+ st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root,
+ name);
+ gcc_assert (st);
+ st->n.tb = tb;
+
+ break;
+ }
+
+ case INTERFACE_INTRINSIC_OP:
+ ns->tb_op[op] = tb;
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
}
/* Now, match all following names as specific targets. */
if (target_st == target->specific_st)
{
gfc_error ("'%s' already defined as specific binding for the"
- " generic '%s' at %C", name, st->name);
+ " generic '%s' at %C", name, bind_name);
goto error;
}
/* Tree containing type-bound procedures. */
gfc_symtree *tb_sym_root;
+ /* Type-bound user operators. */
+ gfc_symtree *tb_uop_root;
+ /* For derived-types, store type-bound intrinsic operators here. */
+ gfc_typebound_proc *tb_op[GFC_INTRINSIC_OPS];
/* Linked list of finalizer procedures. */
struct gfc_finalizer *finalizers;
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+ const char*, bool);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+ gfc_intrinsic_op, bool);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
void gfc_set_current_interface_head (gfc_interface *);
gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
bool gfc_arglist_matches_symbol (gfc_actual_arglist**, gfc_symbol*);
+bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
/* io.c */
extern gfc_st_label format_asterisk;
/* Given an operator interface and the operator, make sure that all
interfaces for that operator are legal. */
-static void
-check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
+bool
+gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
+ locus opwhere)
{
gfc_formal_arglist *formal;
sym_intent i1, i2;
- gfc_symbol *sym;
bt t1, t2;
int args, r1, r2, k1, k2;
- if (intr == NULL)
- return;
+ gcc_assert (sym);
args = 0;
t1 = t2 = BT_UNKNOWN;
r1 = r2 = -1;
k1 = k2 = -1;
- for (formal = intr->sym->formal; formal; formal = formal->next)
+ for (formal = sym->formal; formal; formal = formal->next)
{
- sym = formal->sym;
- if (sym == NULL)
+ gfc_symbol *fsym = formal->sym;
+ if (fsym == NULL)
{
gfc_error ("Alternate return cannot appear in operator "
- "interface at %L", &intr->sym->declared_at);
- return;
+ "interface at %L", &sym->declared_at);
+ return false;
}
if (args == 0)
{
- t1 = sym->ts.type;
- i1 = sym->attr.intent;
- r1 = (sym->as != NULL) ? sym->as->rank : 0;
- k1 = sym->ts.kind;
+ t1 = fsym->ts.type;
+ i1 = fsym->attr.intent;
+ r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
+ k1 = fsym->ts.kind;
}
if (args == 1)
{
- t2 = sym->ts.type;
- i2 = sym->attr.intent;
- r2 = (sym->as != NULL) ? sym->as->rank : 0;
- k2 = sym->ts.kind;
+ t2 = fsym->ts.type;
+ i2 = fsym->attr.intent;
+ r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
+ k2 = fsym->ts.kind;
}
args++;
}
- sym = intr->sym;
-
/* Only +, - and .not. can be unary operators.
.not. cannot be a binary operator. */
if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
|| (args == 2 && op == INTRINSIC_NOT))
{
gfc_error ("Operator interface at %L has the wrong number of arguments",
- &intr->sym->declared_at);
- return;
+ &sym->declared_at);
+ return false;
}
/* Check that intrinsics are mapped to functions, except
if (!sym->attr.subroutine)
{
gfc_error ("Assignment operator interface at %L must be "
- "a SUBROUTINE", &intr->sym->declared_at);
- return;
+ "a SUBROUTINE", &sym->declared_at);
+ return false;
}
if (args != 2)
{
gfc_error ("Assignment operator interface at %L must have "
- "two arguments", &intr->sym->declared_at);
- return;
+ "two arguments", &sym->declared_at);
+ return false;
}
/* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
- - First argument an array with different rank than second,
- - Types and kinds do not conform, and
- - First argument is of derived type. */
+ - 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
&& (r1 == 0 || r1 == r2)
&& (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
&& gfc_numeric_ts (&sym->formal->next->sym->ts))))
{
gfc_error ("Assignment operator interface at %L must not redefine "
- "an INTRINSIC type assignment", &intr->sym->declared_at);
- return;
+ "an INTRINSIC type assignment", &sym->declared_at);
+ return false;
}
}
else
if (!sym->attr.function)
{
gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
- &intr->sym->declared_at);
- return;
+ &sym->declared_at);
+ return false;
}
}
if (op == INTRINSIC_ASSIGN)
{
if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
- gfc_error ("First argument of defined assignment at %L must be "
- "INTENT(OUT) or INTENT(INOUT)", &intr->sym->declared_at);
+ {
+ gfc_error ("First argument of defined assignment at %L must be "
+ "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
+ return false;
+ }
if (i2 != INTENT_IN)
- gfc_error ("Second argument of defined assignment at %L must be "
- "INTENT(IN)", &intr->sym->declared_at);
+ {
+ gfc_error ("Second argument of defined assignment at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
}
else
{
if (i1 != INTENT_IN)
- gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &intr->sym->declared_at);
+ {
+ gfc_error ("First argument of operator interface at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
if (args == 2 && i2 != INTENT_IN)
- gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &intr->sym->declared_at);
+ {
+ gfc_error ("Second argument of operator interface at %L must be "
+ "INTENT(IN)", &sym->declared_at);
+ return false;
+ }
}
/* From now on, all we have to do is check that the operator definition
if (t1 == BT_LOGICAL)
goto bad_repl;
else
- return;
+ return true;
}
if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
if (IS_NUMERIC_TYPE (t1))
goto bad_repl;
else
- return;
+ return true;
}
/* Character intrinsic operators have same character kind, thus
operator definitions with operands of different character kinds
are always safe. */
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
- return;
+ return true;
/* Intrinsic operators always perform on arguments of same rank,
so different ranks is also always safe. (rank == 0) is an exception
to that, because all intrinsic operators are elemental. */
if (r1 != r2 && r1 != 0 && r2 != 0)
- return;
+ return true;
switch (op)
{
break;
}
- return;
+ return true;
#undef IS_NUMERIC_TYPE
bad_repl:
gfc_error ("Operator interface at %L conflicts with intrinsic interface",
- &intr->where);
- return;
+ &opwhere);
+ return false;
}
if (check_interface0 (ns->op[i], interface_name))
continue;
- check_operator_interface (ns->op[i], (gfc_intrinsic_op) i);
+ if (ns->op[i])
+ gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
+ ns->op[i]->where);
for (ns2 = ns; ns2; ns2 = ns2->parent)
{
}
-/* Resolve a GENERIC procedure binding for a derived type. */
+/* Worker function for resolving a generic procedure binding; this is used to
+ resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures.
+
+ The difference between those cases is finding possible inherited bindings
+ that are overridden, as one has to look for them in tb_sym_root,
+ tb_uop_root or tb_op, respectively. Thus the caller must already find
+ the super-type and set p->overridden correctly. */
static gfc_try
-resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+resolve_tb_generic_targets (gfc_symbol* super_type,
+ gfc_typebound_proc* p, const char* name)
{
gfc_tbp_generic* target;
gfc_symtree* first_target;
- gfc_symbol* super_type;
gfc_symtree* inherited;
- locus where;
-
- gcc_assert (st->n.tb);
- gcc_assert (st->n.tb->is_generic);
-
- where = st->n.tb->where;
- super_type = gfc_get_derived_super_type (derived);
-
- /* Find the overridden binding if any. */
- st->n.tb->overridden = NULL;
- if (super_type)
- {
- gfc_symtree* overridden;
- overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
- if (overridden && overridden->n.tb)
- st->n.tb->overridden = overridden->n.tb;
- }
+ gcc_assert (p && p->is_generic);
/* Try to find the specific bindings for the symtrees in our target-list. */
- gcc_assert (st->n.tb->u.generic);
- for (target = st->n.tb->u.generic; target; target = target->next)
+ gcc_assert (p->u.generic);
+ for (target = p->u.generic; target; target = target->next)
if (!target->specific)
{
gfc_typebound_proc* overridden_tbp;
}
gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
- " at %L", target_name, st->name, &where);
+ " at %L", target_name, name, &p->where);
return FAILURE;
/* Once we've found the specific binding, check it is not ambiguous with
if (target->specific->is_generic)
{
gfc_error ("GENERIC '%s' at %L must target a specific binding,"
- " '%s' is GENERIC, too", st->name, &where, target_name);
+ " '%s' is GENERIC, too", name, &p->where, target_name);
return FAILURE;
}
/* Check those already resolved on this type directly. */
- for (g = st->n.tb->u.generic; g; g = g->next)
+ for (g = p->u.generic; g; g = g->next)
if (g != target && g->specific
- && check_generic_tbp_ambiguity (target, g, st->name, where)
+ && check_generic_tbp_ambiguity (target, g, name, p->where)
== FAILURE)
return FAILURE;
/* Check for ambiguity with inherited specific targets. */
- for (overridden_tbp = st->n.tb->overridden; overridden_tbp;
+ for (overridden_tbp = p->overridden; overridden_tbp;
overridden_tbp = overridden_tbp->overridden)
if (overridden_tbp->is_generic)
{
{
gcc_assert (g->specific);
if (check_generic_tbp_ambiguity (target, g,
- st->name, where) == FAILURE)
+ name, p->where) == FAILURE)
return FAILURE;
}
}
}
/* If we attempt to "overwrite" a specific binding, this is an error. */
- if (st->n.tb->overridden && !st->n.tb->overridden->is_generic)
+ if (p->overridden && !p->overridden->is_generic)
{
gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
- " the same name", st->name, &where);
+ " the same name", name, &p->where);
return FAILURE;
}
/* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
all must have the same attributes here. */
- first_target = st->n.tb->u.generic->specific->u.specific;
+ first_target = p->u.generic->specific->u.specific;
gcc_assert (first_target);
- st->n.tb->subroutine = first_target->n.sym->attr.subroutine;
- st->n.tb->function = first_target->n.sym->attr.function;
+ p->subroutine = first_target->n.sym->attr.subroutine;
+ p->function = first_target->n.sym->attr.function;
return SUCCESS;
}
-/* Resolve the type-bound procedures for a derived type. */
+/* Resolve a GENERIC procedure binding for a derived type. */
+
+static gfc_try
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+ gfc_symbol* super_type;
+
+ /* Find the overridden binding if any. */
+ st->n.tb->overridden = NULL;
+ super_type = gfc_get_derived_super_type (derived);
+ if (super_type)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+
+ if (overridden && overridden->n.tb)
+ st->n.tb->overridden = overridden->n.tb;
+ }
+
+ /* Resolve using worker function. */
+ return resolve_tb_generic_targets (super_type, st->n.tb, st->name);
+}
+
+
+/* Resolve a type-bound intrinsic operator. */
+
+static gfc_try
+resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
+ gfc_typebound_proc* p)
+{
+ gfc_symbol* super_type;
+ gfc_tbp_generic* target;
+
+ /* If there's already an error here, do nothing (but don't fail again). */
+ if (p->error)
+ return SUCCESS;
+
+ /* Operators should always be GENERIC bindings. */
+ gcc_assert (p->is_generic);
+
+ /* Look for an overridden binding. */
+ super_type = gfc_get_derived_super_type (derived);
+ if (super_type && super_type->f2k_derived)
+ p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL,
+ op, true);
+ else
+ p->overridden = NULL;
+
+ /* Resolve general GENERIC properties using worker function. */
+ if (resolve_tb_generic_targets (super_type, p, gfc_op2string (op)) == FAILURE)
+ goto error;
+
+ /* Check the targets to be procedures of correct interface. */
+ for (target = p->u.generic; target; target = target->next)
+ {
+ gfc_symbol* target_proc;
+
+ gcc_assert (target->specific && !target->specific->is_generic);
+ target_proc = target->specific->u.specific->n.sym;
+ gcc_assert (target_proc);
+
+ if (!gfc_check_operator_interface (target_proc, op, p->where))
+ return FAILURE;
+ }
+
+ return SUCCESS;
+
+error:
+ p->error = 1;
+ return FAILURE;
+}
+
+
+/* Resolve a type-bound user operator (tree-walker callback). */
static gfc_symbol* resolve_bindings_derived;
static gfc_try resolve_bindings_result;
+static gfc_try check_uop_procedure (gfc_symbol* sym, locus where);
+
+static void
+resolve_typebound_user_op (gfc_symtree* stree)
+{
+ gfc_symbol* super_type;
+ gfc_tbp_generic* target;
+
+ gcc_assert (stree && stree->n.tb);
+
+ if (stree->n.tb->error)
+ return;
+
+ /* Operators should always be GENERIC bindings. */
+ gcc_assert (stree->n.tb->is_generic);
+
+ /* Find overridden procedure, if any. */
+ super_type = gfc_get_derived_super_type (resolve_bindings_derived);
+ if (super_type && super_type->f2k_derived)
+ {
+ gfc_symtree* overridden;
+ overridden = gfc_find_typebound_user_op (super_type, NULL,
+ stree->name, true);
+
+ if (overridden && overridden->n.tb)
+ stree->n.tb->overridden = overridden->n.tb;
+ }
+ else
+ stree->n.tb->overridden = NULL;
+
+ /* Resolve basically using worker function. */
+ if (resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)
+ == FAILURE)
+ goto error;
+
+ /* Check the targets to be functions of correct interface. */
+ for (target = stree->n.tb->u.generic; target; target = target->next)
+ {
+ gfc_symbol* target_proc;
+
+ gcc_assert (target->specific && !target->specific->is_generic);
+ target_proc = target->specific->u.specific->n.sym;
+ gcc_assert (target_proc);
+
+ if (check_uop_procedure (target_proc, stree->n.tb->where) == FAILURE)
+ goto error;
+ }
+
+ return;
+
+error:
+ resolve_bindings_result = FAILURE;
+ stree->n.tb->error = 1;
+}
+
+
+/* Resolve the type-bound procedures for a derived type. */
+
static void
resolve_typebound_procedure (gfc_symtree* stree)
{
static gfc_try
resolve_typebound_procedures (gfc_symbol* derived)
{
+ int op;
+ bool found_op;
+
if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root)
return SUCCESS;
resolve_bindings_derived = derived;
resolve_bindings_result = SUCCESS;
- gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
- &resolve_typebound_procedure);
+
+ if (derived->f2k_derived->tb_sym_root)
+ gfc_traverse_symtree (derived->f2k_derived->tb_sym_root,
+ &resolve_typebound_procedure);
+
+ found_op = (derived->f2k_derived->tb_uop_root != NULL);
+ if (derived->f2k_derived->tb_uop_root)
+ gfc_traverse_symtree (derived->f2k_derived->tb_uop_root,
+ &resolve_typebound_user_op);
+
+ for (op = 0; op != GFC_INTRINSIC_OPS; ++op)
+ {
+ gfc_typebound_proc* p = derived->f2k_derived->tb_op[op];
+ if (p && resolve_typebound_intrinsic_op (derived, (gfc_intrinsic_op) op,
+ p) == FAILURE)
+ resolve_bindings_result = FAILURE;
+ if (p)
+ found_op = true;
+ }
+
+ /* FIXME: Remove this (and found_op) once calls are fully implemented. */
+ if (found_op)
+ {
+ gfc_error ("Derived type '%s' at %L contains type-bound OPERATOR's,"
+ " they are not yet implemented.",
+ derived->name, &derived->declared_at);
+ resolve_bindings_result = FAILURE;
+ }
return resolve_bindings_result;
}
}
}
+
/* 12.3.2.1.1 Defined operators. */
-static void
-gfc_resolve_uops (gfc_symtree *symtree)
+static gfc_try
+check_uop_procedure (gfc_symbol *sym, locus where)
{
- gfc_interface *itr;
- gfc_symbol *sym;
gfc_formal_arglist *formal;
- if (symtree == NULL)
- return;
+ if (!sym->attr.function)
+ {
+ gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
+ sym->name, &where);
+ return FAILURE;
+ }
- gfc_resolve_uops (symtree->left);
- gfc_resolve_uops (symtree->right);
+ if (sym->ts.type == BT_CHARACTER
+ && !(sym->ts.cl && sym->ts.cl->length)
+ && !(sym->result && sym->result->ts.cl
+ && sym->result->ts.cl->length))
+ {
+ gfc_error ("User operator procedure '%s' at %L cannot be assumed "
+ "character length", sym->name, &where);
+ return FAILURE;
+ }
- for (itr = symtree->n.uop->op; itr; itr = itr->next)
+ formal = sym->formal;
+ if (!formal || !formal->sym)
{
- sym = itr->sym;
- if (!sym->attr.function)
- gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
- sym->name, &sym->declared_at);
+ gfc_error ("User operator procedure '%s' at %L must have at least "
+ "one argument", sym->name, &where);
+ return FAILURE;
+ }
- if (sym->ts.type == BT_CHARACTER
- && !(sym->ts.cl && sym->ts.cl->length)
- && !(sym->result && sym->result->ts.cl
- && sym->result->ts.cl->length))
- gfc_error ("User operator procedure '%s' at %L cannot be assumed "
- "character length", sym->name, &sym->declared_at);
+ if (formal->sym->attr.intent != INTENT_IN)
+ {
+ gfc_error ("First argument of operator interface at %L must be "
+ "INTENT(IN)", &where);
+ return FAILURE;
+ }
- formal = sym->formal;
- if (!formal || !formal->sym)
- {
- gfc_error ("User operator procedure '%s' at %L must have at least "
- "one argument", sym->name, &sym->declared_at);
- continue;
- }
+ if (formal->sym->attr.optional)
+ {
+ gfc_error ("First argument of operator interface at %L cannot be "
+ "optional", &where);
+ return FAILURE;
+ }
- if (formal->sym->attr.intent != INTENT_IN)
- gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &sym->declared_at);
+ formal = formal->next;
+ if (!formal || !formal->sym)
+ return SUCCESS;
- if (formal->sym->attr.optional)
- gfc_error ("First argument of operator interface at %L cannot be "
- "optional", &sym->declared_at);
+ if (formal->sym->attr.intent != INTENT_IN)
+ {
+ gfc_error ("Second argument of operator interface at %L must be "
+ "INTENT(IN)", &where);
+ return FAILURE;
+ }
- formal = formal->next;
- if (!formal || !formal->sym)
- continue;
+ if (formal->sym->attr.optional)
+ {
+ gfc_error ("Second argument of operator interface at %L cannot be "
+ "optional", &where);
+ return FAILURE;
+ }
- if (formal->sym->attr.intent != INTENT_IN)
- gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &sym->declared_at);
+ if (formal->next)
+ {
+ gfc_error ("Operator interface at %L must have, at most, two "
+ "arguments", &where);
+ return FAILURE;
+ }
- if (formal->sym->attr.optional)
- gfc_error ("Second argument of operator interface at %L cannot be "
- "optional", &sym->declared_at);
+ return SUCCESS;
+}
- if (formal->next)
- gfc_error ("Operator interface at %L must have, at most, two "
- "arguments", &sym->declared_at);
- }
+static void
+gfc_resolve_uops (gfc_symtree *symtree)
+{
+ gfc_interface *itr;
+
+ if (symtree == NULL)
+ return;
+
+ gfc_resolve_uops (symtree->left);
+ gfc_resolve_uops (symtree->right);
+
+ for (itr = symtree->n.uop->op; itr; itr = itr->next)
+ check_uop_procedure (itr->sym, itr->sym->declared_at);
}
ns->parent = parent;
for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
- ns->operator_access[in] = ACCESS_UNKNOWN;
+ {
+ ns->operator_access[in] = ACCESS_UNKNOWN;
+ ns->tb_op[in] = NULL;
+ }
/* Initialize default implicit types. */
for (i = 'a'; i <= 'z'; i++)
static void
free_uop_tree (gfc_symtree *uop_tree)
{
-
if (uop_tree == NULL)
return;
free_uop_tree (uop_tree->right);
gfc_free_interface (uop_tree->n.uop->op);
-
gfc_free (uop_tree->n.uop);
gfc_free (uop_tree);
}
free_uop_tree (ns->uop_root);
free_common_tree (ns->common_root);
free_tb_tree (ns->tb_sym_root);
+ free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
}
-/* Find a type-bound procedure by name for a derived-type (looking recursively
- through the super-types). */
+/* General worker function to find either a type-bound procedure or a
+ type-bound user operator. */
-gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
- const char* name, bool noaccess)
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, bool uop)
{
gfc_symtree* res;
+ gfc_symtree* root;
+
+ /* Set correct symbol-root. */
+ gcc_assert (derived->f2k_derived);
+ root = (uop ? derived->f2k_derived->tb_uop_root
+ : derived->f2k_derived->tb_sym_root);
/* Set default to failure. */
if (t)
*t = FAILURE;
/* Try to find it in the current type's namespace. */
- gcc_assert (derived->f2k_derived);
- res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
+ res = gfc_find_symtree (root, name);
if (res && res->n.tb)
{
/* We found one. */
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, t, name, noaccess);
+
+ return find_typebound_proc_uop (super_type, t, name, noaccess, uop);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+ (looking recursively through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, false);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, true);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+ super-type hierarchy. */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+ gfc_intrinsic_op op, bool noaccess)
+{
+ 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)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' of '%s' is PRIVATE at %C",
+ gfc_op2string (op), derived->name);
+ 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);
}
/* Nothing found. */
+2009-08-10 Daniel Kraft <d@domob.eu>
+
+ PR fortran/37425
+ * gfortran.dg/typebound_operator_1.f03: New test.
+ * gfortran.dg/typebound_operator_2.f03: New test.
+
2009-08-10 Richard Guenther <rguenther@suse.de>
PR middle-end/41006
--- /dev/null
+! { dg-do compile }
+! { dg-options "-w" }
+! FIXME: Remove -w once CLASS is fully supported.
+
+! Type-bound procedures
+! Check correct type-bound operator definitions.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE t ! { dg-error "not yet implemented" }
+ CONTAINS
+ PROCEDURE, PASS :: onearg
+ PROCEDURE, PASS :: twoarg1
+ PROCEDURE, PASS :: twoarg2
+ PROCEDURE, PASS(me) :: assign_proc
+
+ GENERIC :: OPERATOR(.BINARY.) => twoarg1, twoarg2
+ GENERIC :: OPERATOR(.UNARY.) => onearg
+ GENERIC :: ASSIGNMENT(=) => assign_proc
+ END TYPE t
+
+CONTAINS
+
+ INTEGER FUNCTION onearg (me)
+ CLASS(t), INTENT(IN) :: me
+ onearg = 5
+ END FUNCTION onearg
+
+ INTEGER FUNCTION twoarg1 (me, a)
+ CLASS(t), INTENT(IN) :: me
+ INTEGER, INTENT(IN) :: a
+ twoarg1 = 42
+ END FUNCTION twoarg1
+
+ INTEGER FUNCTION twoarg2 (me, a)
+ CLASS(t), INTENT(IN) :: me
+ REAL, INTENT(IN) :: a
+ twoarg2 = 123
+ END FUNCTION twoarg2
+
+ SUBROUTINE assign_proc (me, b)
+ CLASS(t), INTENT(OUT) :: me
+ CLASS(t), INTENT(IN) :: b
+ me = t ()
+ END SUBROUTINE assign_proc
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-w" }
+! FIXME: Remove -w once CLASS is fully supported.
+
+! Type-bound procedures
+! Checks for correct errors with invalid OPERATOR/ASSIGNMENT usage.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE t ! { dg-error "not yet implemented" }
+ CONTAINS
+ PROCEDURE, PASS :: onearg
+ PROCEDURE, PASS :: onearg_alt => onearg
+ PROCEDURE, PASS :: onearg_alt2 => onearg
+ PROCEDURE, PASS :: threearg
+ PROCEDURE, NOPASS :: noarg
+ PROCEDURE, PASS :: sub
+ PROCEDURE, PASS :: sub2 ! { dg-error "must be a FUNCTION" }
+ PROCEDURE, PASS :: func
+
+ ! These give errors at the targets' definitions.
+ GENERIC :: OPERATOR(.AND.) => sub2
+ GENERIC :: OPERATOR(*) => onearg
+ GENERIC :: ASSIGNMENT(=) => func
+
+ GENERIC :: OPERATOR(.UOPA.) => sub ! { dg-error "must be a FUNCTION" }
+ GENERIC :: OPERATOR(.UOPB.) => threearg ! { dg-error "at most, two arguments" }
+ GENERIC :: OPERATOR(.UOPC.) => noarg ! { dg-error "at least one argument" }
+
+ GENERIC :: OPERATOR(.UNARY.) => onearg_alt
+ GENERIC, PRIVATE :: OPERATOR(.UNARY.) => onearg_alt2 ! { dg-error "must have the same access" }
+ END TYPE t
+
+CONTAINS
+
+ INTEGER FUNCTION onearg (me) ! { dg-error "wrong number of arguments" }
+ CLASS(t), INTENT(IN) :: me
+ onearg = 5
+ END FUNCTION onearg
+
+ INTEGER FUNCTION threearg (a, b, c)
+ CLASS(t), INTENT(IN) :: a, b, c
+ threearg = 42
+ END FUNCTION threearg
+
+ INTEGER FUNCTION noarg ()
+ noarg = 42
+ END FUNCTION noarg
+
+ LOGICAL FUNCTION func (me, b) ! { dg-error "must be a SUBROUTINE" }
+ CLASS(t), INTENT(OUT) :: me
+ CLASS(t), INTENT(IN) :: b
+ me = t ()
+ func = .TRUE.
+ END FUNCTION func
+
+ SUBROUTINE sub (a)
+ CLASS(t), INTENT(IN) :: a
+ END SUBROUTINE sub
+
+ SUBROUTINE sub2 (a, x)
+ CLASS(t), INTENT(IN) :: a
+ INTEGER, INTENT(IN) :: x
+ END SUBROUTINE sub2
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
projects / platform / upstream / gcc.git / commitdiff