This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, Fortran] PR fortran/37425: Finish type-bound operators
- From: Daniel Kraft <d at domob dot eu>
- To: Tobias Burnus <burnus at net-b dot de>
- Cc: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Mon, 24 Aug 2009 14:20:49 +0200
- Subject: Re: [Patch, Fortran] PR fortran/37425: Finish type-bound operators
- References: <4A8B1873.3060507@domob.eu> <4A90FBF8.70405@net-b.de>
Hi Tobias!
Here's a revised patch based on your comments. I've also done a svn
update and will in any case do a fresh regression test before committing.
Is this one ok?
Tobias Burnus wrote:
Daniel Kraft wrote:
* What's the usage of EXEC_ASSIGN_CALL instead of EXEC_CALL?
It was introduced with PR25746 - and there with the patch "[Patch,
fortran] PR25746 - operator assignment dependency checking",
http://gcc.gnu.org/ml/gcc-patches/2006-05/msg00296.html.
That patch introduces the distinction in gfc_trans_call whether a
dependency checking should be done (EXEC_ASSIGN_CALL) or not (EXEC_CALL).
Hm, I still don't get the difference between EXEC_ASSIGN_CALL and
EXEC_CALL. Shouldn't writing the ASSIGNMENT(=) operator and calling the
assignment-procedure directly in the code be exactly equivalent? This
seems not to be the case with a special EXEC_ASSIGN_CALL...
But what's more important for me is do I have to do the same thing for
type-bound assigment operators, i.e. introduce something like
EXEC_ASSIGN_COMPCALL? Or can the patch go in just like it is now? If
it is not changed, my generated calls to the assignmet-procedures will
be ordinary EXEC_CALLs; but I can change it to be EXEC_ASSIGN_CALLs,
too, if that is necessary -- but it will probably complicate matters
more for future dynamic dispatch implementations, so if that is not
strictly necessary I'd like to leave it off.
* Should we do ambiguity-checks while looking for matching operators?
Like, continue always through-out all checks to see if we would have
found another match? Compare PR 37297, maybe we could leave that open
but keep in mind to do something about it later.
I think we should defer it to a later patch / to a PR, but I think we
should do it. Depending on the order of USE statements or type
declarations we may use a different operator; such bugs are quite
difficult to find in user code.
Ok, I changed the XXXs to TODOs and will open a PR. There's already one
for no complete ambiguity-checks on GENERIC bindings, but that one is
meant for checks on the declarations, not when a call is ambiguous (PR
37297) -- so I think a new one is really what we want here.
+/* 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_try* result,
[...]
+ if (result && *result == FAILURE)
+ return NULL;
Can you add a word or so regarding the purpose of "result"? It obviously
does not just return a SUCCESS or FAILURE, but its presence might also
alter the program flow - depending whether it is present or not.
I did get rid of the result argument entirely now, on a second thought
that was not necessary any longer (it was before when I had implemented
another handling of PRIVATE operators). Thanks for getting my attention
to it!
+ already_error is an additional output argument that specifies if FAILURE
+ is because of some real error and not because no match was found. */
+gfc_extend_expr (gfc_expr *e, bool *already_error)
I would have guessed something different from the name than the comment
implies. Something like "real_error" or "not_matched" fits better my
expectations from the name with those of the comment.
Ditto in resolve.c
Changed to real_error; thanks for the suggestion, I was myself not
really happy with already_error, and that was another remain from some
prior trials with slightly different semantics.
+! FIXME: Check that calls to inherited bindnigs work once CLASS allows that.
Typo: bindings
>
+! Here we see it also works for imported from module.
When reading "imported" I always thinks of the IMPORT statement thus I
would use "Here, we see that also use-associated operators work". But as
it is merely a comment in a test case, it really does not matter.
Fixed those two.
Yours,
Daniel
--
Done: Arc-Bar-Cav-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Kni-Mon-Pri
2009-08-24 Daniel Kraft <d@domob.eu>
PR fortran/37425
* gfortran.h (gfc_expr): Optionally store base-object in compcall value.
(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.
* 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-24 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.
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c (revision 151053)
+++ gcc/fortran/interface.c (working copy)
@@ -2554,16 +2554,118 @@ 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;
+}
+
+
/* 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 +2678,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 +2709,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 +2733,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 +2803,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 +2850,35 @@ gfc_extend_assign (gfc_code *c, gfc_name
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->expr2 = NULL;
+ /* XXX: Do we need to create an EXEC_ASSIGN_CALL in the final
+ output??? What's the difference between EXEC_ASSIGN_CALL and
+ ordinary EXEC_CALL? */
+ 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;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 151053)
+++ gcc/fortran/symbol.c (working copy)
@@ -4539,7 +4539,8 @@ gfc_get_derived_super_type (gfc_symbol*
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* der
/* 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* der
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* der
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* der
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*
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_sym
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_sym
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_sym
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. */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 151053)
+++ gcc/fortran/gfortran.h (working copy)
@@ -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,15 @@ 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;
}
compcall;
@@ -2458,11 +2465,13 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymb
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 +2652,7 @@ void gfc_procedure_use (gfc_symbol *, gf
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 *);
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 151053)
+++ gcc/fortran/module.c (working copy)
@@ -77,7 +77,7 @@ along with GCC; see the file COPYING3.
/* 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**
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;
-
- mio_lparen ();
+ gfc_intrinsic_op realop;
- require_atom (ATOM_STRING);
- st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string);
- gfc_free (atom_string);
+ if (op == INTRINSIC_USER || !f2k->tb_op[op])
+ continue;
- 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 ();
}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 151053)
+++ gcc/fortran/resolve.c (working copy)
@@ -3510,8 +3510,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);
@@ -4687,10 +4693,15 @@ extract_compcall_passed_object (gfc_expr
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;
@@ -4723,7 +4734,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;
@@ -6911,24 +6922,40 @@ resolve_ordinary_assign (gfc_code *code,
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_error ("Subroutine '%s' called instead of assignment at "
- "%L must be PURE", code->symtree->n.sym->name,
- &code->loc);
- return rval;
+ gfc_symbol* assign_proc;
+ gfc_expr** rhsptr;
+
+ if (code->op == EXEC_ASSIGN_CALL)
+ {
+ 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;
}
@@ -6937,8 +6964,8 @@ resolve_ordinary_assign (gfc_code *code,
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. */
@@ -6983,7 +7010,7 @@ resolve_ordinary_assign (gfc_code *code,
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);
@@ -7117,6 +7144,7 @@ resolve_code (gfc_code *code, gfc_namesp
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
+ case EXEC_ASSIGN_CALL:
break;
case EXEC_ENTRY:
@@ -8872,8 +8900,8 @@ resolve_tb_generic_targets (gfc_symbol*
/* 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)
{
@@ -8954,7 +8982,8 @@ resolve_typebound_generic (gfc_symbol* d
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;
@@ -9008,7 +9037,7 @@ resolve_typebound_intrinsic_op (gfc_symb
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;
@@ -9023,10 +9052,10 @@ resolve_typebound_intrinsic_op (gfc_symb
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;
@@ -9064,7 +9093,7 @@ resolve_typebound_user_op (gfc_symtree*
{
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;
@@ -9227,7 +9256,7 @@ resolve_typebound_procedure (gfc_symtree
{
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;
@@ -9267,7 +9296,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;
@@ -9279,7 +9307,6 @@ resolve_typebound_procedures (gfc_symbol
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);
@@ -9290,17 +9317,6 @@ resolve_typebound_procedures (gfc_symbol
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;
@@ -9345,7 +9361,7 @@ ensure_not_abstract_walker (gfc_symbol*
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)
{
@@ -9596,7 +9612,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",
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 151053)
+++ gcc/fortran/primary.c (working copy)
@@ -1783,7 +1783,7 @@ gfc_match_varspec (gfc_expr *primary, in
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,8 @@ gfc_match_varspec (gfc_expr *primary, in
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.base_object = NULL;
gcc_assert (primary->symtree->n.sym->attr.referenced);
if (tbp_sym)
primary->ts = tbp_sym->ts;
Index: gcc/testsuite/gfortran.dg/typebound_operator_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_2.f03 (revision 151053)
+++ gcc/testsuite/gfortran.dg/typebound_operator_2.f03 (working copy)
@@ -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
Index: gcc/testsuite/gfortran.dg/typebound_operator_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_operator_4.f03 (revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/impure_assignment_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/impure_assignment_1.f90 (revision 151053)
+++ gcc/testsuite/gfortran.dg/impure_assignment_1.f90 (working copy)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/typebound_operator_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_1.f03 (revision 151053)
+++ gcc/testsuite/gfortran.dg/typebound_operator_1.f03 (working copy)
@@ -8,7 +8,7 @@
MODULE m
IMPLICIT NONE
- TYPE t ! { dg-error "not yet implemented" }
+ TYPE t
CONTAINS
PROCEDURE, PASS :: onearg
PROCEDURE, PASS :: twoarg1
@@ -41,7 +41,7 @@ CONTAINS
SUBROUTINE assign_proc (me, b)
CLASS(t), INTENT(OUT) :: me
- CLASS(t), INTENT(IN) :: b
+ LOGICAL, INTENT(IN) :: b
me = t ()
END SUBROUTINE assign_proc
Index: gcc/testsuite/gfortran.dg/typebound_operator_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_operator_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_operator_3.f03 (revision 0)
@@ -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" } }