procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators)

Browse source 
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  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'.

From-SVN: r150622
This commit is contained in:
Daniel Kraft 2009-08-10 12:51:46 +02:00 • committed by Daniel Kraft
parent 4f4e722eb6
commit 94747289e9
9 changed files with 666 additions and 160 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
gcc/fortran/ChangeLog
View file

@ -1,3 +1,29 @@
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

113
gcc/fortran/decl.c
View file

@ -7406,11 +7406,13 @@ match
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. */
@ -7437,49 +7439,126 @@ gfc_match_generic (void)
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. */
@ -7504,7 +7583,7 @@ gfc_match_generic (void)
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;
}

9
gcc/fortran/gfortran.h
View file

@ -1287,6 +1287,10 @@ typedef struct gfc_namespace
/* 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;
@ -2448,6 +2452,10 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
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 *);
@ -2636,6 +2644,7 @@ gfc_interface *gfc_current_interface_head (void);
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;

109
gcc/fortran/interface.c
View file

@ -544,17 +544,16 @@ find_keyword_arg (const char *name, gfc_formal_arglist *f)
/* 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;
@ -562,34 +561,32 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
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
@ -598,8 +595,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
|| (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
@ -609,20 +606,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
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
@ -630,8 +627,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
&& 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
@ -639,8 +636,8 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
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;
}
}
@ -648,22 +645,34 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
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
@ -686,7 +695,7 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
if (t1 == BT_LOGICAL)
goto bad_repl;
else
return;
return true;
}
if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
@ -694,20 +703,20 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op op)
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)
{
@ -760,14 +769,14 @@ check_operator_interface (gfc_interface *intr, gfc_intrinsic_op 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;
}
@ -1229,7 +1238,9 @@ gfc_check_interfaces (gfc_namespace *ns)
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)
{

343
gcc/fortran/resolve.c
View file

@ -8793,37 +8793,27 @@ check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
}
/* 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;
@ -8854,7 +8844,7 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
}
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
@ -8866,19 +8856,19 @@ specific_found:
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)
{
@ -8886,36 +8876,167 @@ specific_found:
{
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)
{
@ -9082,13 +9203,42 @@ error:
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;
}
@ -11063,14 +11213,85 @@ resolve_fntype (gfc_namespace *ns)
}
}
/* 12.3.2.1.1 Defined operators. */
static gfc_try
check_uop_procedure (gfc_symbol *sym, locus where)
{
gfc_formal_arglist *formal;
if (!sym->attr.function)
{
gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
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, &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, &where);
return FAILURE;
}
if (formal->sym->attr.intent != INTENT_IN)
{
gfc_error ("First argument of operator interface at %L must be "
"INTENT(IN)", &where);
return FAILURE;
}
if (formal->sym->attr.optional)
{
gfc_error ("First argument of operator interface at %L cannot be "
"optional", &where);
return FAILURE;
}
formal = formal->next;
if (!formal || !formal->sym)
return SUCCESS;
if (formal->sym->attr.intent != INTENT_IN)
{
gfc_error ("Second argument of operator interface at %L must be "
"INTENT(IN)", &where);
return FAILURE;
}
if (formal->sym->attr.optional)
{
gfc_error ("Second argument of operator interface at %L cannot be "
"optional", &where);
return FAILURE;
}
if (formal->next)
{
gfc_error ("Operator interface at %L must have, at most, two "
"arguments", &where);
return FAILURE;
}
return SUCCESS;
}
static void
gfc_resolve_uops (gfc_symtree *symtree)
{
gfc_interface *itr;
gfc_symbol *sym;
gfc_formal_arglist *formal;
if (symtree == NULL)
return;
@ -11079,51 +11300,7 @@ gfc_resolve_uops (gfc_symtree *symtree)
gfc_resolve_uops (symtree->right);
for (itr = symtree->n.uop->op; itr; itr = itr->next)
{
sym = itr->sym;
if (!sym->attr.function)
gfc_error ("User operator procedure '%s' at %L must be a FUNCTION",
sym->name, &sym->declared_at);
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);
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.intent != INTENT_IN)
gfc_error ("First argument of operator interface at %L must be "
"INTENT(IN)", &sym->declared_at);
if (formal->sym->attr.optional)
gfc_error ("First argument of operator interface at %L cannot be "
"optional", &sym->declared_at);
formal = formal->next;
if (!formal || !formal->sym)
continue;
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->sym->attr.optional)
gfc_error ("Second argument of operator interface at %L cannot be "
"optional", &sym->declared_at);
if (formal->next)
gfc_error ("Operator interface at %L must have, at most, two "
"arguments", &sym->declared_at);
}
check_uop_procedure (itr->sym, itr->sym->declared_at);
}

101
gcc/fortran/symbol.c
View file

@ -2220,7 +2220,10 @@ gfc_get_namespace (gfc_namespace *parent, int parent_types)
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++)
@ -2948,7 +2951,6 @@ free_common_tree (gfc_symtree * common_tree)
static void
free_uop_tree (gfc_symtree *uop_tree)
{
if (uop_tree == NULL)
return;
@ -2956,7 +2958,6 @@ free_uop_tree (gfc_symtree *uop_tree)
free_uop_tree (uop_tree->right);
gfc_free_interface (uop_tree->n.uop->op);
gfc_free (uop_tree->n.uop);
gfc_free (uop_tree);
}
@ -3128,6 +3129,7 @@ gfc_free_namespace (gfc_namespace *ns)
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);
@ -4519,22 +4521,27 @@ gfc_get_derived_super_type (gfc_symbol* derived)
}
/* 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. */
@ -4558,7 +4565,79 @@ gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
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. */

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
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

50
gcc/testsuite/gfortran.dg/typebound_operator_1.f03 Normal file
View file

@ -0,0 +1,50 @@
! { 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" } }

69
gcc/testsuite/gfortran.dg/typebound_operator_2.f03 Normal file
View file

@ -0,0 +1,69 @@
! { 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" } }