mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-24 20:45:58 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.h (gfc_expr): Optionally store base-object in compcall value
	and add a new flag to distinguish assign-calls generated.
	(gfc_find_typebound_proc): Add locus argument.
	(gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_extend_expr): Return if failure was by a real error.
	* interface.c (matching_typebound_op): New routine.
	(build_compcall_for_operator): New routine.
	(gfc_extend_expr): Handle type-bound operators, some clean-up and
	return if failure was by a real error or just by not finding an
	appropriate operator definition.
	(gfc_extend_assign): Handle type-bound assignments.
	* module.c (MOD_VERSION): Incremented.
	(mio_intrinsic_op): New routine.
	(mio_full_typebound_tree): New routine to make typebound-procedures IO
	code reusable for type-bound user operators.
	(mio_f2k_derived): IO of type-bound operators.
	* primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and
	pass locus to gfc_find_typebound_proc.
	* resolve.c (resolve_operator): Only output error about no matching
	interface if gfc_extend_expr did not already fail with an error.
	(extract_compcall_passed_object): Use specified base-object if present.
	(update_compcall_arglist): Handle ignore_pass field.
	(resolve_ordinary_assign): Update to handle extended code for
	type-bound assignments, too.
	(resolve_code): Handle EXEC_ASSIGN_CALL statement code.
	(resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc.
	(resolve_typebound_generic), (resolve_typebound_procedure): Ditto.
	(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto.
	(ensure_not_abstract_walker), (resolve_fl_derived): Ditto.
	(resolve_typebound_procedures): Remove not-implemented error.
	(resolve_typebound_call): Handle assign-call flag.
	* symbol.c (find_typebound_proc_uop): New argument to pass locus for
	error message about PRIVATE, verify that a found procedure is not marked
	as erraneous.
	(gfc_find_typebound_intrinsic_op): Ditto.
	(gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg.

2009-08-27  Daniel Kraft  <d@domob.eu>

	PR fortran/37425
	* gfortran.dg/impure_assignment_1.f90: Change expected error message.
	* gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented
	error and fix problem with recursive assignment.
	* gfortran.dg/typebound_operator_2.f03: No not-implemented check.
	* gfortran.dg/typebound_operator_3.f03: New test.
	* gfortran.dg/typebound_operator_4.f03: New test.

From-SVN: r151140
This commit is contained in:
Daniel Kraft 2009-08-27 13:42:56 +02:00 committed by Daniel Kraft
parent c6a2114273
commit 4a44a72d23
13 changed files with 660 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
gcc/fortran/ChangeLog
View File

@ -1,3 +1,43 @@
2009-08-27 Daniel Kraft <d@domob.eu>
PR fortran/37425
* gfortran.h (gfc_expr): Optionally store base-object in compcall value
and add a new flag to distinguish assign-calls generated.
(gfc_find_typebound_proc): Add locus argument.
(gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto.
(gfc_extend_expr): Return if failure was by a real error.
* interface.c (matching_typebound_op): New routine.
(build_compcall_for_operator): New routine.
(gfc_extend_expr): Handle type-bound operators, some clean-up and
return if failure was by a real error or just by not finding an
appropriate operator definition.
(gfc_extend_assign): Handle type-bound assignments.
* module.c (MOD_VERSION): Incremented.
(mio_intrinsic_op): New routine.
(mio_full_typebound_tree): New routine to make typebound-procedures IO
code reusable for type-bound user operators.
(mio_f2k_derived): IO of type-bound operators.
* primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and
pass locus to gfc_find_typebound_proc.
* resolve.c (resolve_operator): Only output error about no matching
interface if gfc_extend_expr did not already fail with an error.
(extract_compcall_passed_object): Use specified base-object if present.
(update_compcall_arglist): Handle ignore_pass field.
(resolve_ordinary_assign): Update to handle extended code for
type-bound assignments, too.
(resolve_code): Handle EXEC_ASSIGN_CALL statement code.
(resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc.
(resolve_typebound_generic), (resolve_typebound_procedure): Ditto.
(resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto.
(ensure_not_abstract_walker), (resolve_fl_derived): Ditto.
(resolve_typebound_procedures): Remove not-implemented error.
(resolve_typebound_call): Handle assign-call flag.
* symbol.c (find_typebound_proc_uop): New argument to pass locus for
error message about PRIVATE, verify that a found procedure is not marked
as erraneous.
(gfc_find_typebound_intrinsic_op): Ditto.
(gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg.
2009-08-22 Bud Davis <bdavis9659@sbcglobal.net>
PR fortran/28093

29
gcc/fortran/gfortran.h
View File

@ -1622,8 +1622,8 @@ typedef struct gfc_expr
int rank;
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
/* Nonnull for functions and structure constructors, the base object for
component-calls. */
/* Nonnull for functions and structure constructors, may also used to hold the
base-object for component calls. */
gfc_symtree *symtree;
gfc_ref *ref;
@ -1699,8 +1699,19 @@ typedef struct gfc_expr
{
gfc_actual_arglist* actual;
const char* name;
void* padding; /* Overlap gfc_typebound_proc with esym. */
gfc_typebound_proc* tbp;
/* Base-object, whose component was called. NULL means that it should
be taken from symtree/ref. */
struct gfc_expr* base_object;
gfc_typebound_proc* tbp; /* Should overlap with esym. */
/* For type-bound operators, we want to call PASS procedures but already
have the full arglist; mark this, so that it is not extended by the
PASS argument. */
unsigned ignore_pass:1;
/* Do assign-calls rather than calls, that is appropriate dependency
checking. */
unsigned assign:1;
}
compcall;
@ -2458,11 +2469,13 @@ 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_proc (gfc_symbol*, gfc_try*,
const char*, bool, locus*);
gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
const char*, bool);
const char*, bool, locus*);
gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
gfc_intrinsic_op, bool);
gfc_intrinsic_op, bool,
locus*);
gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
@ -2643,7 +2656,7 @@ void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
void gfc_ppc_use (gfc_component *, gfc_actual_arglist **, locus *);
gfc_symbol *gfc_search_interface (gfc_interface *, int,
gfc_actual_arglist **);
gfc_try gfc_extend_expr (gfc_expr *);
gfc_try gfc_extend_expr (gfc_expr *, bool *);
void gfc_free_formal_arglist (gfc_formal_arglist *);
gfc_try gfc_extend_assign (gfc_code *, gfc_namespace *);
gfc_try gfc_add_interface (gfc_symbol *);

248
gcc/fortran/interface.c
View File

@ -2554,16 +2554,119 @@ gfc_find_sym_in_symtree (gfc_symbol *sym)
}
/* See if the arglist to an operator-call contains a derived-type argument
with a matching type-bound operator. If so, return the matching specific
procedure defined as operator-target as well as the base-object to use
(which is the found derived-type argument with operator). */
static gfc_typebound_proc*
matching_typebound_op (gfc_expr** tb_base,
gfc_actual_arglist* args,
gfc_intrinsic_op op, const char* uop)
{
gfc_actual_arglist* base;
for (base = args; base; base = base->next)
if (base->expr->ts.type == BT_DERIVED)
{
gfc_typebound_proc* tb;
gfc_symbol* derived;
gfc_try result;
derived = base->expr->ts.u.derived;
if (op == INTRINSIC_USER)
{
gfc_symtree* tb_uop;
gcc_assert (uop);
tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
false, NULL);
if (tb_uop)
tb = tb_uop->n.tb;
else
tb = NULL;
}
else
tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
false, NULL);
/* This means we hit a PRIVATE operator which is use-associated and
should thus not be seen. */
if (result == FAILURE)
tb = NULL;
/* Look through the super-type hierarchy for a matching specific
binding. */
for (; tb; tb = tb->overridden)
{
gfc_tbp_generic* g;
gcc_assert (tb->is_generic);
for (g = tb->u.generic; g; g = g->next)
{
gfc_symbol* target;
gfc_actual_arglist* argcopy;
bool matches;
gcc_assert (g->specific);
if (g->specific->error)
continue;
target = g->specific->u.specific->n.sym;
/* Check if this arglist matches the formal. */
argcopy = gfc_copy_actual_arglist (args);
matches = gfc_arglist_matches_symbol (&argcopy, target);
gfc_free_actual_arglist (argcopy);
/* Return if we found a match. */
if (matches)
{
*tb_base = base->expr;
return g->specific;
}
}
}
}
return NULL;
}
/* For the 'actual arglist' of an operator call and a specific typebound
procedure that has been found the target of a type-bound operator, build the
appropriate EXPR_COMPCALL and resolve it. We take this indirection over
type-bound procedures rather than resolving type-bound operators 'directly'
so that we can reuse the existing logic. */
static void
build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
gfc_expr* base, gfc_typebound_proc* target)
{
e->expr_type = EXPR_COMPCALL;
e->value.compcall.tbp = target;
e->value.compcall.name = "operator"; /* Should not matter. */
e->value.compcall.actual = actual;
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
e->value.compcall.assign = 0;
}
/* This subroutine is called when an expression is being resolved.
The expression node in question is either a user defined operator
or an intrinsic operator with arguments that aren't compatible
with the operator. This subroutine builds an actual argument list
corresponding to the operands, then searches for a compatible
interface. If one is found, the expression node is replaced with
the appropriate function call. */
the appropriate function call.
real_error is an additional output argument that specifies if FAILURE
is because of some real error and not because no match was found. */
gfc_try
gfc_extend_expr (gfc_expr *e)
gfc_extend_expr (gfc_expr *e, bool *real_error)
{
gfc_actual_arglist *actual;
gfc_symbol *sym;
@ -2576,6 +2679,8 @@ gfc_extend_expr (gfc_expr *e)
actual = gfc_get_actual_arglist ();
actual->expr = e->value.op.op1;
*real_error = false;
if (e->value.op.op2 != NULL)
{
actual->next = gfc_get_actual_arglist ();
@ -2605,47 +2710,20 @@ gfc_extend_expr (gfc_expr *e)
to check if either is defined. */
switch (i)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_EQ], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_EQ_OS], 0, &actual);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_NE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_NE_OS], 0, &actual);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_GT], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_GT_OS], 0, &actual);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_GE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_GE_OS], 0, &actual);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_LT], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_LT_OS], 0, &actual);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
sym = gfc_search_interface (ns->op[INTRINSIC_LE], 0, &actual);
if (sym == NULL)
sym = gfc_search_interface (ns->op[INTRINSIC_LE_OS], 0, &actual);
break;
#define CHECK_OS_COMPARISON(comp) \
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
if (!sym) \
sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
CHECK_OS_COMPARISON(GT)
CHECK_OS_COMPARISON(GE)
CHECK_OS_COMPARISON(LT)
CHECK_OS_COMPARISON(LE)
#undef CHECK_OS_COMPARISON
default:
sym = gfc_search_interface (ns->op[i], 0, &actual);
@ -2656,8 +2734,59 @@ gfc_extend_expr (gfc_expr *e)
}
}
/* TODO: Do an ambiguity-check and error if multiple matching interfaces are
found rather than just taking the first one and not checking further. */
if (sym == NULL)
{
gfc_typebound_proc* tbo;
gfc_expr* tb_base;
/* See if we find a matching type-bound operator. */
if (i == INTRINSIC_USER)
tbo = matching_typebound_op (&tb_base, actual,
i, e->value.op.uop->name);
else
switch (i)
{
#define CHECK_OS_COMPARISON(comp) \
case INTRINSIC_##comp: \
case INTRINSIC_##comp##_OS: \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp, NULL); \
if (!tbo) \
tbo = matching_typebound_op (&tb_base, actual, \
INTRINSIC_##comp##_OS, NULL); \
break;
CHECK_OS_COMPARISON(EQ)
CHECK_OS_COMPARISON(NE)
CHECK_OS_COMPARISON(GT)
CHECK_OS_COMPARISON(GE)
CHECK_OS_COMPARISON(LT)
CHECK_OS_COMPARISON(LE)
#undef CHECK_OS_COMPARISON
default:
tbo = matching_typebound_op (&tb_base, actual, i, NULL);
break;
}
/* If there is a matching typebound-operator, replace the expression with
a call to it and succeed. */
if (tbo)
{
gfc_try result;
gcc_assert (tb_base);
build_compcall_for_operator (e, actual, tb_base, tbo);
result = gfc_resolve_expr (e);
if (result == FAILURE)
*real_error = true;
return result;
}
/* Don't use gfc_free_actual_arglist(). */
if (actual->next != NULL)
gfc_free (actual->next);
@ -2675,16 +2804,12 @@ gfc_extend_expr (gfc_expr *e)
e->value.function.name = NULL;
e->user_operator = 1;
if (gfc_pure (NULL) && !gfc_pure (sym))
if (gfc_resolve_expr (e) == FAILURE)
{
gfc_error ("Function '%s' called in lieu of an operator at %L must "
"be PURE", sym->name, &e->where);
*real_error = true;
return FAILURE;
}
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
return SUCCESS;
}
@ -2726,8 +2851,33 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
break;
}
/* TODO: Ambiguity-check, see above for gfc_extend_expr. */
if (sym == NULL)
{
gfc_typebound_proc* tbo;
gfc_expr* tb_base;
/* See if we find a matching type-bound assignment. */
tbo = matching_typebound_op (&tb_base, actual,
INTRINSIC_ASSIGN, NULL);
/* If there is one, replace the expression with a call to it and
succeed. */
if (tbo)
{
gcc_assert (tb_base);
c->expr1 = gfc_get_expr ();
build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
c->expr1->value.compcall.assign = 1;
c->expr2 = NULL;
c->op = EXEC_COMPCALL;
/* c is resolved from the caller, so no need to do it here. */
return SUCCESS;
}
gfc_free (actual->next);
gfc_free (actual);
return FAILURE;

85
gcc/fortran/module.c
View File

@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
#define MOD_VERSION "2"
#define MOD_VERSION "3"
/* Structure that describes a position within a module file. */
@ -1461,6 +1461,25 @@ mio_integer (int *ip)
}
/* Read or write a gfc_intrinsic_op value. */
static void
mio_intrinsic_op (gfc_intrinsic_op* op)
{
/* FIXME: Would be nicer to do this via the operators symbolic name. */
if (iomode == IO_OUTPUT)
{
int converted = (int) *op;
write_atom (ATOM_INTEGER, &converted);
}
else
{
require_atom (ATOM_INTEGER);
*op = (gfc_intrinsic_op) atom_int;
}
}
/* Read or write a character pointer that points to a string on the heap. */
static const char *
@ -3324,6 +3343,7 @@ mio_typebound_proc (gfc_typebound_proc** proc)
mio_rparen ();
}
/* Walker-callback function for this purpose. */
static void
mio_typebound_symtree (gfc_symtree* st)
{
@ -3341,6 +3361,33 @@ mio_typebound_symtree (gfc_symtree* st)
mio_rparen ();
}
/* IO a full symtree (in all depth). */
static void
mio_full_typebound_tree (gfc_symtree** root)
{
mio_lparen ();
if (iomode == IO_OUTPUT)
gfc_traverse_symtree (*root, &mio_typebound_symtree);
else
{
while (peek_atom () == ATOM_LPAREN)
{
gfc_symtree* st;
mio_lparen ();
require_atom (ATOM_STRING);
st = gfc_get_tbp_symtree (root, atom_string);
gfc_free (atom_string);
mio_typebound_symtree (st);
}
}
mio_rparen ();
}
static void
mio_finalizer (gfc_finalizer **f)
{
@ -3388,24 +3435,40 @@ mio_f2k_derived (gfc_namespace *f2k)
mio_rparen ();
/* Handle type-bound procedures. */
mio_full_typebound_tree (&f2k->tb_sym_root);
/* Type-bound user operators. */
mio_full_typebound_tree (&f2k->tb_uop_root);
/* Type-bound intrinsic operators. */
mio_lparen ();
if (iomode == IO_OUTPUT)
gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree);
else
{
while (peek_atom () == ATOM_LPAREN)
int op;
for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
{
gfc_symtree* st;
gfc_intrinsic_op realop;
mio_lparen ();
if (op == INTRINSIC_USER || !f2k->tb_op[op])
continue;
require_atom (ATOM_STRING);
st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string);
gfc_free (atom_string);
mio_typebound_symtree (st);
mio_lparen ();
realop = (gfc_intrinsic_op) op;
mio_intrinsic_op (&realop);
mio_typebound_proc (&f2k->tb_op[op]);
mio_rparen ();
}
}
else
while (peek_atom () != ATOM_RPAREN)
{
gfc_intrinsic_op op;
mio_lparen ();
mio_intrinsic_op (&op);
mio_typebound_proc (&f2k->tb_op[op]);
mio_rparen ();
}
mio_rparen ();
}

5
gcc/fortran/primary.c
View File

@ -1783,7 +1783,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (m != MATCH_YES)
return MATCH_ERROR;
tbp = gfc_find_typebound_proc (sym, &t, name, false);
tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
if (tbp)
{
gfc_symbol* tbp_sym;
@ -1802,6 +1802,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
primary->expr_type = EXPR_COMPCALL;
primary->value.compcall.tbp = tbp->n.tb;
primary->value.compcall.name = tbp->name;
primary->value.compcall.ignore_pass = 0;
primary->value.compcall.assign = 0;
primary->value.compcall.base_object = NULL;
gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;

111
gcc/fortran/resolve.c
View File

@ -3508,8 +3508,14 @@ resolve_operator (gfc_expr *e)
bad_op:
if (gfc_extend_expr (e) == SUCCESS)
return SUCCESS;
{
bool real_error;
if (gfc_extend_expr (e, &real_error) == SUCCESS)
return SUCCESS;
if (real_error)
return FAILURE;
}
if (dual_locus_error)
gfc_error (msg, &op1->where, &op2->where);
@ -4685,10 +4691,15 @@ extract_compcall_passed_object (gfc_expr* e)
gcc_assert (e->expr_type == EXPR_COMPCALL);
po = gfc_get_expr ();
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
if (e->value.compcall.base_object)
po = gfc_copy_expr (e->value.compcall.base_object);
else
{
po = gfc_get_expr ();
po->expr_type = EXPR_VARIABLE;
po->symtree = e->symtree;
po->ref = gfc_copy_ref (e->ref);
}
if (gfc_resolve_expr (po) == FAILURE)
return NULL;
@ -4721,7 +4732,7 @@ update_compcall_arglist (gfc_expr* e)
return FAILURE;
}
if (tbp->nopass)
if (tbp->nopass || e->value.compcall.ignore_pass)
{
gfc_free_expr (po);
return SUCCESS;
@ -4957,7 +4968,7 @@ resolve_typebound_call (gfc_code* c)
c->ext.actual = newactual;
c->symtree = target;
c->op = EXEC_CALL;
c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
gfc_free_expr (c->expr1);
@ -4983,6 +4994,9 @@ resolve_compcall (gfc_expr* e)
return FAILURE;
}
/* These must not be assign-calls! */
gcc_assert (!e->value.compcall.assign);
if (check_typebound_baseobject (e) == FAILURE)
return FAILURE;
@ -6909,24 +6923,40 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
if (gfc_extend_assign (code, ns) == SUCCESS)
{
lhs = code->ext.actual->expr;
rhs = code->ext.actual->next->expr;
if (gfc_pure (NULL) && !gfc_pure (code->symtree->n.sym))
gfc_symbol* assign_proc;
gfc_expr** rhsptr;
if (code->op == EXEC_ASSIGN_CALL)
{
gfc_error ("Subroutine '%s' called instead of assignment at "
"%L must be PURE", code->symtree->n.sym->name,
&code->loc);
return rval;
lhs = code->ext.actual->expr;
rhsptr = &code->ext.actual->next->expr;
assign_proc = code->symtree->n.sym;
}
else
{
gfc_actual_arglist* args;
gfc_typebound_proc* tbp;
gcc_assert (code->op == EXEC_COMPCALL);
args = code->expr1->value.compcall.actual;
lhs = args->expr;
rhsptr = &args->next->expr;
tbp = code->expr1->value.compcall.tbp;
gcc_assert (!tbp->is_generic);
assign_proc = tbp->u.specific->n.sym;
}
/* Make a temporary rhs when there is a default initializer
and rhs is the same symbol as the lhs. */
if (rhs->expr_type == EXPR_VARIABLE
&& rhs->symtree->n.sym->ts.type == BT_DERIVED
&& has_default_initializer (rhs->symtree->n.sym->ts.u.derived)
&& (lhs->symtree->n.sym == rhs->symtree->n.sym))
code->ext.actual->next->expr = gfc_get_parentheses (rhs);
if ((*rhsptr)->expr_type == EXPR_VARIABLE
&& (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED
&& has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived)
&& (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym))
*rhsptr = gfc_get_parentheses (*rhsptr);
resolve_code (code, ns);
return true;
}
@ -6935,8 +6965,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
if (rhs->is_boz
&& gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&code->loc) == FAILURE)
"a DATA statement and outside INT/REAL/DBLE/CMPLX",
&code->loc) == FAILURE)
return false;
/* Handle the case of a BOZ literal on the RHS. */
@ -6981,7 +7011,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
rlen = rhs->value.character.length;
else if (rhs->ts.u.cl != NULL
&& rhs->ts.u.cl->length != NULL
&& rhs->ts.u.cl->length != NULL
&& rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT)
rlen = mpz_get_si (rhs->ts.u.cl->length->value.integer);
@ -7115,6 +7145,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_ASSIGN_CALL:
break;
case EXEC_ENTRY:
@ -8870,8 +8901,8 @@ resolve_tb_generic_targets (gfc_symbol* super_type,
/* Look for an inherited specific binding. */
if (super_type)
{
inherited = gfc_find_typebound_proc (super_type, NULL,
target_name, true);
inherited = gfc_find_typebound_proc (super_type, NULL, target_name,
true, NULL);
if (inherited)
{
@ -8952,7 +8983,8 @@ resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
if (super_type)
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
overridden = gfc_find_typebound_proc (super_type, NULL, st->name,
true, NULL);
if (overridden && overridden->n.tb)
st->n.tb->overridden = overridden->n.tb;
@ -9006,7 +9038,7 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
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);
op, true, NULL);
else
p->overridden = NULL;
@ -9021,10 +9053,10 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
target_proc = get_checked_tb_operator_target (target, p->where);
if (!target_proc)
return FAILURE;
goto error;
if (!gfc_check_operator_interface (target_proc, op, p->where))
return FAILURE;
goto error;
}
return SUCCESS;
@ -9062,7 +9094,7 @@ resolve_typebound_user_op (gfc_symtree* stree)
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_user_op (super_type, NULL,
stree->name, true);
stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
@ -9225,7 +9257,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
{
gfc_symtree* overridden;
overridden = gfc_find_typebound_proc (super_type, NULL,
stree->name, true);
stree->name, true, NULL);
if (overridden && overridden->n.tb)
stree->n.tb->overridden = overridden->n.tb;
@ -9265,7 +9297,6 @@ 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;
@ -9277,7 +9308,6 @@ resolve_typebound_procedures (gfc_symbol* derived)
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);
@ -9288,17 +9318,6 @@ resolve_typebound_procedures (gfc_symbol* derived)
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;
@ -9343,7 +9362,7 @@ ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
if (st->n.tb && st->n.tb->deferred)
{
gfc_symtree* overriding;
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL);
gcc_assert (overriding && overriding->n.tb);
if (overriding->n.tb->deferred)
{
@ -9594,7 +9613,7 @@ resolve_fl_derived (gfc_symbol *sym)
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
if (super_type
&& gfc_find_typebound_proc (super_type, NULL, c->name, true))
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
" inherited type-bound procedure",

33
gcc/fortran/symbol.c
View File

@ -4539,7 +4539,8 @@ gfc_get_derived_super_type (gfc_symbol* derived)
static gfc_symtree*
find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
const char* name, bool noaccess, bool uop)
const char* name, bool noaccess, bool uop,
locus* where)
{
gfc_symtree* res;
gfc_symtree* root;
@ -4555,7 +4556,7 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
/* Try to find it in the current type's namespace. */
res = gfc_find_symtree (root, name);
if (res && res->n.tb)
if (res && res->n.tb && !res->n.tb->error)
{
/* We found one. */
if (t)
@ -4564,7 +4565,9 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
if (!noaccess && derived->attr.use_assoc
&& res->n.tb->access == ACCESS_PRIVATE)
{
gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
if (where)
gfc_error ("'%s' of '%s' is PRIVATE at %L",
name, derived->name, where);
if (t)
*t = FAILURE;
}
@ -4579,7 +4582,8 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
return find_typebound_proc_uop (super_type, t, name, noaccess, uop);
return find_typebound_proc_uop (super_type, t, name,
noaccess, uop, where);
}
/* Nothing found. */
@ -4592,16 +4596,16 @@ find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
gfc_symtree*
gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
const char* name, bool noaccess)
const char* name, bool noaccess, locus* where)
{
return find_typebound_proc_uop (derived, t, name, noaccess, false);
return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
}
gfc_symtree*
gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
const char* name, bool noaccess)
const char* name, bool noaccess, locus* where)
{
return find_typebound_proc_uop (derived, t, name, noaccess, true);
return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
}
@ -4610,7 +4614,8 @@ gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
gfc_typebound_proc*
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
gfc_intrinsic_op op, bool noaccess)
gfc_intrinsic_op op, bool noaccess,
locus* where)
{
gfc_typebound_proc* res;
@ -4625,7 +4630,7 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
res = NULL;
/* Check access. */
if (res)
if (res && !res->error)
{
/* We found one. */
if (t)
@ -4634,8 +4639,9 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
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 (where)
gfc_error ("'%s' of '%s' is PRIVATE at %L",
gfc_op2string (op), derived->name, where);
if (t)
*t = FAILURE;
}
@ -4650,7 +4656,8 @@ gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess);
return gfc_find_typebound_intrinsic_op (super_type, t, op,
noaccess, where);
}
/* Nothing found. */

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2009-08-27 Daniel Kraft <d@domob.eu>
PR fortran/37425
* gfortran.dg/impure_assignment_1.f90: Change expected error message.
* gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented
error and fix problem with recursive assignment.
* gfortran.dg/typebound_operator_2.f03: No not-implemented check.
* gfortran.dg/typebound_operator_3.f03: New test.
* gfortran.dg/typebound_operator_4.f03: New test.
2009-08-27 Dodji Seketeli <dodji@redhat.com>
PR debug/41770

2
gcc/testsuite/gfortran.dg/impure_assignment_1.f90
View File

@ -21,7 +21,7 @@ CONTAINS
PURE SUBROUTINE S2(I,J)
TYPE(T1), INTENT(OUT):: I
TYPE(T1), INTENT(IN) :: J
I=J ! { dg-error "must be PURE" }
I=J ! { dg-error "is not PURE" }
END SUBROUTINE S2
END
! { dg-final { cleanup-modules "M1" } }

7
gcc/testsuite/gfortran.dg/typebound_operator_1.f03
View File

@ -8,7 +8,8 @@
MODULE m
IMPLICIT NONE
TYPE t ! { dg-error "not yet implemented" }
TYPE t
LOGICAL :: x
CONTAINS
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: twoarg1
@ -41,8 +42,8 @@ CONTAINS
SUBROUTINE assign_proc (me, b)
CLASS(t), INTENT(OUT) :: me
CLASS(t), INTENT(IN) :: b
me = t ()
LOGICAL, INTENT(IN) :: b
me%x = .NOT. b
END SUBROUTINE assign_proc
END MODULE m

2
gcc/testsuite/gfortran.dg/typebound_operator_2.f03
View File

@ -8,7 +8,7 @@
MODULE m
IMPLICIT NONE
TYPE t ! { dg-error "not yet implemented" }
TYPE t
CONTAINS
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: onearg_alt => onearg

127
gcc/testsuite/gfortran.dg/typebound_operator_3.f03 Normal file
View File

@ -0,0 +1,127 @@
! { dg-do run }
! { dg-options "-w" }
! FIXME: Remove -w when CLASS is fully implemented.
! Type-bound procedures
! Check they can actually be called and run correctly.
! This also checks for correct module save/restore.
! FIXME: Check that calls to inherited bindings work once CLASS allows that.
MODULE m
IMPLICIT NONE
TYPE mynum
REAL :: num_real
INTEGER :: num_int
CONTAINS
PROCEDURE, PASS, PRIVATE :: add_mynum ! Check that this may be PRIVATE.
PROCEDURE, PASS :: add_int
PROCEDURE, PASS :: add_real
PROCEDURE, PASS :: assign_int
PROCEDURE, PASS :: assign_real
PROCEDURE, PASS(from) :: assign_to_int
PROCEDURE, PASS(from) :: assign_to_real
PROCEDURE, PASS :: get_all
GENERIC :: OPERATOR(+) => add_mynum, add_int, add_real
GENERIC :: OPERATOR(.GET.) => get_all
GENERIC :: ASSIGNMENT(=) => assign_int, assign_real, &
assign_to_int, assign_to_real
END TYPE mynum
CONTAINS
TYPE(mynum) FUNCTION add_mynum (a, b)
CLASS(mynum), INTENT(IN) :: a, b
add_mynum = mynum (a%num_real + b%num_real, a%num_int + b%num_int)
END FUNCTION add_mynum
TYPE(mynum) FUNCTION add_int (a, b)
CLASS(mynum), INTENT(IN) :: a
INTEGER, INTENT(IN) :: b
add_int = mynum (a%num_real, a%num_int + b)
END FUNCTION add_int
TYPE(mynum) FUNCTION add_real (a, b)
CLASS(mynum), INTENT(IN) :: a
REAL, INTENT(IN) :: b
add_real = mynum (a%num_real + b, a%num_int)
END FUNCTION add_real
REAL FUNCTION get_all (me)
CLASS(mynum), INTENT(IN) :: me
get_all = me%num_real + me%num_int
END FUNCTION get_all
SUBROUTINE assign_real (dest, from)
CLASS(mynum), INTENT(INOUT) :: dest
REAL, INTENT(IN) :: from
dest%num_real = from
END SUBROUTINE assign_real
SUBROUTINE assign_int (dest, from)
CLASS(mynum), INTENT(INOUT) :: dest
INTEGER, INTENT(IN) :: from
dest%num_int = from
END SUBROUTINE assign_int
SUBROUTINE assign_to_real (dest, from)
REAL, INTENT(OUT) :: dest
CLASS(mynum), INTENT(IN) :: from
dest = from%num_real
END SUBROUTINE assign_to_real
SUBROUTINE assign_to_int (dest, from)
INTEGER, INTENT(OUT) :: dest
CLASS(mynum), INTENT(IN) :: from
dest = from%num_int
END SUBROUTINE assign_to_int
! Test it works basically within the module.
SUBROUTINE check_in_module ()
IMPLICIT NONE
TYPE(mynum) :: num
num = mynum (1.0, 2)
num = num + 7
IF (num%num_real /= 1.0 .OR. num%num_int /= 9) CALL abort ()
END SUBROUTINE check_in_module
END MODULE m
! Here we see it also works for use-associated operators loaded from a module.
PROGRAM main
USE m, ONLY: mynum, check_in_module
IMPLICIT NONE
TYPE(mynum) :: num1, num2, num3
REAL :: real_var
INTEGER :: int_var
CALL check_in_module ()
num1 = mynum (1.0, 2)
num2 = mynum (2.0, 3)
num3 = num1 + num2
IF (num3%num_real /= 3.0 .OR. num3%num_int /= 5) CALL abort ()
num3 = num1 + 5
IF (num3%num_real /= 1.0 .OR. num3%num_int /= 7) CALL abort ()
num3 = num1 + (-100.5)
IF (num3%num_real /= -99.5 .OR. num3%num_int /= 2) CALL abort ()
num3 = 42
num3 = -1.2
IF (num3%num_real /= -1.2 .OR. num3%num_int /= 42) CALL abort ()
real_var = num3
int_var = num3
IF (real_var /= -1.2 .OR. int_var /= 42) CALL abort ()
IF (.GET. num1 /= 3.0) CALL abort ()
END PROGRAM main
! { dg-final { cleanup-modules "m" } }

94
gcc/testsuite/gfortran.dg/typebound_operator_4.f03 Normal file
View File

@ -0,0 +1,94 @@
! { dg-do compile }
! { dg-options "-w" }
! FIXME: Remove -w when CLASS is fully implemented.
! Type-bound procedures
! Check for errors with operator calls.
MODULE m
IMPLICIT NONE
TYPE myint
INTEGER :: value
CONTAINS
PROCEDURE, PASS :: add_int
PROCEDURE, PASS :: assign_int
GENERIC, PRIVATE :: OPERATOR(.PLUS.) => add_int
GENERIC, PRIVATE :: OPERATOR(+) => add_int
GENERIC, PRIVATE :: ASSIGNMENT(=) => assign_int
END TYPE myint
TYPE myreal
REAL :: value
CONTAINS
PROCEDURE, PASS :: add_real
PROCEDURE, PASS :: assign_real
GENERIC :: OPERATOR(.PLUS.) => add_real
GENERIC :: OPERATOR(+) => add_real
GENERIC :: ASSIGNMENT(=) => assign_real
END TYPE myreal
CONTAINS
PURE TYPE(myint) FUNCTION add_int (a, b)
CLASS(myint), INTENT(IN) :: a
INTEGER, INTENT(IN) :: b
add_int = myint (a%value + b)
END FUNCTION add_int
PURE SUBROUTINE assign_int (dest, from)
CLASS(myint), INTENT(OUT) :: dest
INTEGER, INTENT(IN) :: from
dest = myint (from)
END SUBROUTINE assign_int
TYPE(myreal) FUNCTION add_real (a, b)
CLASS(myreal), INTENT(IN) :: a
REAL, INTENT(IN) :: b
add_real = myreal (a%value + b)
END FUNCTION add_real
SUBROUTINE assign_real (dest, from)
CLASS(myreal), INTENT(OUT) :: dest
REAL, INTENT(IN) :: from
dest = myreal (from)
END SUBROUTINE assign_real
SUBROUTINE in_module ()
TYPE(myint) :: x
x = 0 ! { dg-bogus "Can't convert" }
x = x + 42 ! { dg-bogus "Operands of" }
x = x .PLUS. 5 ! { dg-bogus "Unknown operator" }
END SUBROUTINE in_module
PURE SUBROUTINE iampure ()
TYPE(myint) :: x
x = 0 ! { dg-bogus "is not PURE" }
x = x + 42 ! { dg-bogus "to a non-PURE procedure" }
x = x .PLUS. 5 ! { dg-bogus "to a non-PURE procedure" }
END SUBROUTINE iampure
END MODULE m
PURE SUBROUTINE iampure2 ()
USE m
IMPLICIT NONE
TYPE(myreal) :: x
x = 0.0 ! { dg-error "is not PURE" }
x = x + 42.0 ! { dg-error "to a non-PURE procedure" }
x = x .PLUS. 5.0 ! { dg-error "to a non-PURE procedure" }
END SUBROUTINE iampure2
PROGRAM main
USE m
IMPLICIT NONE
TYPE(myint) :: x
x = 0 ! { dg-error "Can't convert" }
x = x + 42 ! { dg-error "Operands of" }
x = x .PLUS. 5 ! { dg-error "Unknown operator" }
END PROGRAM main
! { dg-final { cleanup-modules "m" } }