This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[4.5, patch, fortran] Implement DEFERRED bindings
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 07 Dec 2008 18:14:32 +0100
- Subject: [4.5, patch, fortran] Implement DEFERRED bindings
Hi all,
here's my contribution for gfortran 4.5 patches :D This implements
DEFERRED bindings for gfortran based on my type-bound procedures and
ABSTRACT derived-types implementation.
It should be quite an "obvious" patch, except maybe the detection of
things like that:
TYPE, ABSTRACT t1
CONTAINS
PROCEDURE(intf), DEFERRED :: proc
END TYPE t1
TYPE, EXTENDS(t1) :: t2
END TYPE t2
! t2 inherits the DEFERRED binding and does not override
! it, but is not ABSTRACT itself!
See resolve.c:ensure_not_abstract in the patch for how I do it. There
are faster algorithms possible, but I don't think this is time critical
and I believe it is quite the clearest solution as I did it.
I hope I got all of DEFERRED semantics correct and did not miss
anything... See the tests for what the patch is supposed to handle.
Comments very welcome as usual!
No regressions on GNU/Linux-x86-32. Ok for 4.5?
Yours,
Daniel
--
Done: Arc-Bar-Cav-Rog-Sam-Val-Wiz
To go: Hea-Kni-Mon-Pri-Ran-Tou
2008-12-07 Daniel Kraft <d@domob.eu>
PR fortran/37423
* gfortran.h (struct gfc_typebound_proc): Added new flag `deferred' and
added a comment explaining DEFERRED binding handling.
* decl.c (match_binding_attributes): Really match DEFERRED attribute.
(match_procedure_in_type): Really match PROCEDURE(interface) syntax
and do some validity checks for DEFERRED and this construct.
* module.c (binding_overriding): New string constant for DEFERRED.
(mio_typebound_proc): Module-IO DEFERRED flag.
* resolve.c (check_typebound_override): Ensure that a non-DEFERRED
binding is not overridden by a DEFERRED one.
(resolve_typebound_procedure): Allow abstract interfaces as targets
for DEFERRED bindings.
(ensure_not_abstract_walker), (ensure_not_abstract): New methods.
(resolve_fl_derived): Use new `ensure_not_abstract' method for
non-ABSTRACT types extending ABSTRACT ones to ensure each DEFERRED
binding is overridden.
* gfc-internals.texi (Type-bound procedures): Document a little bit
about internal handling of DEFERRED bindings.
2008-12-07 Daniel Kraft <d@domob.eu>
PR fortran/37423
* gfortran.dg/typebound_proc_4.f03: Remove not-implemented check for
DEFERRED bindings.
* gfortran.dg/typebound_proc_9.f03: New test.
* gfortran.dg/typebound_proc_10.f03: New test.
* gfortran.dg/typebound_proc_11.f03: New test.
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 142526)
+++ gcc/fortran/decl.c (working copy)
@@ -6732,6 +6732,7 @@ match_binding_attributes (gfc_typebound_
ba->pass_arg_num = 0;
ba->nopass = 0;
ba->non_overridable = 0;
+ ba->deferred = 0;
/* If we find a comma, we believe there are binding attributes. */
if (gfc_match_char (',') == MATCH_NO)
@@ -6813,14 +6814,19 @@ match_binding_attributes (gfc_typebound_
}
/* DEFERRED flag. */
- /* TODO: Handle really once implemented. */
m = gfc_match (" deferred");
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
{
- gfc_error ("DEFERRED not yet implemented at %C");
- goto error;
+ if (ba->deferred)
+ {
+ gfc_error ("Duplicate DEFERRED at %C");
+ goto error;
+ }
+
+ ba->deferred = 1;
+ continue;
}
/* PASS possibly including argument. */
@@ -6861,6 +6867,13 @@ match_binding_attributes (gfc_typebound_
}
while (gfc_match_char (',') == MATCH_YES);
+ /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
+ if (ba->non_overridable && ba->deferred)
+ {
+ gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C");
+ goto error;
+ }
+
if (ba->access == ACCESS_UNKNOWN)
ba->access = gfc_typebound_default_access;
@@ -6879,7 +6892,7 @@ match_procedure_in_type (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
char target_buf[GFC_MAX_SYMBOL_LEN + 1];
- char* target;
+ char* target = NULL;
gfc_typebound_proc* tb;
bool seen_colons;
bool seen_attrs;
@@ -6893,11 +6906,25 @@ match_procedure_in_type (void)
block = gfc_state_stack->previous->sym;
gcc_assert (block);
- /* TODO: Really implement PROCEDURE(interface). */
+ /* Try to match PROCEDURE(interface). */
if (gfc_match (" (") == MATCH_YES)
{
- gfc_error ("PROCEDURE(interface) at %C is not yet implemented");
- return MATCH_ERROR;
+ m = gfc_match_name (target_buf);
+ if (m == MATCH_ERROR)
+ return m;
+ if (m != MATCH_YES)
+ {
+ gfc_error ("Interface-name expected after '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("')' expected at %C");
+ return MATCH_ERROR;
+ }
+
+ target = target_buf;
}
/* Construct the data structure. */
@@ -6911,6 +6938,19 @@ match_procedure_in_type (void)
return m;
seen_attrs = (m == MATCH_YES);
+ /* Check that attribute DEFERRED is given iff an interface is specified, which
+ means target != NULL. */
+ if (tb->deferred && !target)
+ {
+ gfc_error ("Interface must be specified for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+ if (target && !tb->deferred)
+ {
+ gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
+ return MATCH_ERROR;
+ }
+
/* Match the colons. */
m = gfc_match (" ::");
if (m == MATCH_ERROR)
@@ -6933,12 +6973,17 @@ match_procedure_in_type (void)
}
/* Try to match the '=> target', if it's there. */
- target = NULL;
m = gfc_match (" =>");
if (m == MATCH_ERROR)
return m;
if (m == MATCH_YES)
{
+ if (tb->deferred)
+ {
+ gfc_error ("'=> target' is invalid for DEFERRED binding at %C");
+ return MATCH_ERROR;
+ }
+
if (!seen_colons)
{
gfc_error ("'::' needed in PROCEDURE binding with explicit target"
@@ -6975,6 +7020,14 @@ match_procedure_in_type (void)
ns = block->f2k_derived;
gcc_assert (ns);
+ /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
+ if (tb->deferred && !block->attr.abstract)
+ {
+ gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT",
+ block->name);
+ return MATCH_ERROR;
+ }
+
/* See if we already have a binding with this name in the symtree which would
be an error. If a GENERIC already targetted this binding, it may be
already there but then typebound is still NULL. */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 142526)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1019,7 +1019,7 @@ typedef struct gfc_typebound_proc
union
{
- struct gfc_symtree* specific;
+ struct gfc_symtree* specific; /* The interface if DEFERRED. */
gfc_tbp_generic* generic;
}
u;
@@ -1038,6 +1038,7 @@ typedef struct gfc_typebound_proc
unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
unsigned non_overridable:1;
+ unsigned deferred:1;
unsigned is_generic:1;
unsigned function:1, subroutine:1;
unsigned error:1; /* Ignore it, when an error occurred during resolution. */
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 142526)
+++ gcc/fortran/module.c (working copy)
@@ -1696,6 +1696,7 @@ static const mstring binding_overriding[
{
minit ("OVERRIDABLE", 0),
minit ("NON_OVERRIDABLE", 1),
+ minit ("DEFERRED", 2),
minit (NULL, -1)
};
static const mstring binding_generic[] =
@@ -3201,6 +3202,7 @@ static void
mio_typebound_proc (gfc_typebound_proc** proc)
{
int flag;
+ int overriding_flag;
if (iomode == IO_INPUT)
{
@@ -3213,9 +3215,15 @@ mio_typebound_proc (gfc_typebound_proc**
(*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+ /* IO the NON_OVERRIDABLE/DEFERRED combination. */
+ gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+ overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
+ overriding_flag = mio_name (overriding_flag, binding_overriding);
+ (*proc)->deferred = ((overriding_flag & 2) != 0);
+ (*proc)->non_overridable = ((overriding_flag & 1) != 0);
+ gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
+
(*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
- (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
- binding_overriding);
(*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
if (iomode == IO_INPUT)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 142526)
+++ gcc/fortran/resolve.c (working copy)
@@ -8141,6 +8141,14 @@ check_typebound_override (gfc_symtree* p
return FAILURE;
}
+ /* It's an error to override a non-DEFERRED procedure with a DEFERRED one. */
+ if (!old->typebound->deferred && proc->typebound->deferred)
+ {
+ gfc_error ("'%s' at %L must not be DEFERRED as it overrides a"
+ " non-DEFERRED binding", proc->name, &where);
+ return FAILURE;
+ }
+
/* If the overridden binding is PURE, the overriding must be, too. */
if (old_target->attr.pure && !proc_target->attr.pure)
{
@@ -8483,11 +8491,11 @@ resolve_typebound_procedure (gfc_symtree
gcc_assert (stree->typebound->access != ACCESS_UNKNOWN);
/* It should be a module procedure or an external procedure with explicit
- interface. */
+ interface. For DEFERRED bindings, abstract interfaces are ok as well. */
if ((!proc->attr.subroutine && !proc->attr.function)
|| (proc->attr.proc != PROC_MODULE
&& proc->attr.if_source != IFSRC_IFBODY)
- || proc->attr.abstract)
+ || (proc->attr.abstract && !stree->typebound->deferred))
{
gfc_error ("'%s' must be a module procedure or an external procedure with"
" an explicit interface at %L", proc->name, &where);
@@ -8642,6 +8650,67 @@ add_dt_to_dt_list (gfc_symbol *derived)
}
+/* Ensure that a derived-type is really not abstract, meaning that every
+ inherited DEFERRED binding is overridden by a non-DEFERRED one. */
+
+static gfc_try
+ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st)
+{
+ if (!st)
+ return SUCCESS;
+
+ if (ensure_not_abstract_walker (sub, st->left) == FAILURE)
+ return FAILURE;
+ if (ensure_not_abstract_walker (sub, st->right) == FAILURE)
+ return FAILURE;
+
+ if (st->typebound && st->typebound->deferred)
+ {
+ gfc_symtree* overriding;
+ overriding = gfc_find_typebound_proc (sub, NULL, st->name, true);
+ gcc_assert (overriding && overriding->typebound);
+ if (overriding->typebound->deferred)
+ {
+ gfc_error ("Derived-type '%s' declared at %L must be ABSTRACT because"
+ " '%s' is DEFERRED and not overridden",
+ sub->name, &sub->declared_at, st->name);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
+
+static gfc_try
+ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
+{
+ /* The algorithm used here is to recursively travel up the ancestry of sub
+ and for each ancestor-type, check all bindings. If any of them is
+ DEFERRED, look it up starting from sub and see if the found (overriding)
+ binding is not DEFERRED.
+ This is not the most efficient way to do this, but it should be ok and is
+ clearer than something sophisticated. */
+
+ gcc_assert (ancestor && ancestor->attr.abstract && !sub->attr.abstract);
+
+ /* Walk bindings of this ancestor. */
+ if (ancestor->f2k_derived)
+ {
+ gfc_try t;
+ t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->sym_root);
+ if (t == FAILURE)
+ return FAILURE;
+ }
+
+ /* Find next ancestor type and recurse on it. */
+ ancestor = gfc_get_derived_super_type (ancestor);
+ if (ancestor)
+ return ensure_not_abstract (sub, ancestor);
+
+ return SUCCESS;
+}
+
+
/* Resolve the components of a derived type. */
static gfc_try
@@ -8769,6 +8838,12 @@ resolve_fl_derived (gfc_symbol *sym)
if (gfc_resolve_finalizers (sym) == FAILURE)
return FAILURE;
+ /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that
+ all DEFERRED bindings are overridden. */
+ if (super_type && super_type->attr.abstract && !sym->attr.abstract
+ && ensure_not_abstract (sym, super_type) == FAILURE)
+ return FAILURE;
+
/* Add derived type to the derived type list. */
add_dt_to_dt_list (sym);
Index: gcc/fortran/gfc-internals.texi
===================================================================
--- gcc/fortran/gfc-internals.texi (revision 142526)
+++ gcc/fortran/gfc-internals.texi (working copy)
@@ -601,6 +601,11 @@ name, and later during resolution phase
and its position remembered as @code{pass_arg_num} in @code{gfc_typebound_proc}.
The binding's target procedure is pointed-to by @code{u.specific}.
+@code{DEFERRED} bindings are just like ordinary specific bindings, except
+that their @code{deferred} flag is set of course and that @code{u.specific}
+points to their ``interface'' defining symbol (might be an abstract interface)
+instead of the target procedure.
+
At the moment, all type-bound procedure calls are statically dispatched and
transformed into ordinary procedure calls at resolution time; their actual
argument list is updated to include at the right position the passed-object
Index: gcc/testsuite/gfortran.dg/typebound_proc_11.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_11.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_11.f03 (revision 0)
@@ -0,0 +1,33 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test that legal usage of DEFERRED is accepted.
+
+MODULE testmod
+ IMPLICIT NONE
+
+ ABSTRACT INTERFACE
+ SUBROUTINE intf ()
+ END SUBROUTINE intf
+ END INTERFACE
+
+ TYPE, ABSTRACT :: abstract_type
+ CONTAINS
+ PROCEDURE(intf), DEFERRED, NOPASS :: p1
+ PROCEDURE(realproc), DEFERRED, NOPASS :: p2
+ END TYPE abstract_type
+
+ TYPE, EXTENDS(abstract_type) :: sub_type
+ CONTAINS
+ PROCEDURE, NOPASS :: p1 => realproc
+ PROCEDURE, NOPASS :: p2 => realproc
+ END TYPE sub_type
+
+CONTAINS
+
+ SUBROUTINE realproc ()
+ END SUBROUTINE realproc
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_10.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_10.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_10.f03 (revision 0)
@@ -0,0 +1,43 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for resolution errors with DEFERRED, namely checks about invalid
+! overriding and taking into account inherited DEFERRED bindings.
+! Also check that DEFERRED attribute is saved to module correctly.
+
+MODULE m1
+ IMPLICIT NONE
+
+ ABSTRACT INTERFACE
+ SUBROUTINE intf ()
+ END SUBROUTINE intf
+ END INTERFACE
+
+ TYPE, ABSTRACT :: abstract_type
+ CONTAINS
+ PROCEDURE(intf), DEFERRED, NOPASS :: def
+ PROCEDURE, NOPASS :: nodef => realproc
+ END TYPE abstract_type
+
+CONTAINS
+
+ SUBROUTINE realproc ()
+ END SUBROUTINE realproc
+
+END MODULE m1
+
+MODULE m2
+ USE m1
+ IMPLICIT NONE
+
+ TYPE, ABSTRACT, EXTENDS(abstract_type) :: sub_type1
+ CONTAINS
+ PROCEDURE(intf), DEFERRED, NOPASS :: nodef ! { dg-error "must not be DEFERRED" }
+ END TYPE sub_type1
+
+ TYPE, EXTENDS(abstract_type) :: sub_type2 ! { dg-error "must be ABSTRACT" }
+ END TYPE sub_type2
+
+END MODULE m2
+
+! { dg-final { cleanup-modules "m1" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_9.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_proc_9.f03 (revision 0)
@@ -0,0 +1,33 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Test for basic parsing errors for invalid DEFERRED.
+
+MODULE testmod
+ IMPLICIT NONE
+
+ ABSTRACT INTERFACE
+ SUBROUTINE intf ()
+ END SUBROUTINE intf
+ END INTERFACE
+
+ TYPE not_abstract
+ CONTAINS
+ PROCEDURE(intf), DEFERRED, NOPASS :: proc ! { dg-error "is not ABSTRACT" }
+ END TYPE not_abstract
+
+ TYPE, ABSTRACT :: abstract_type
+ CONTAINS
+ PROCEDURE, DEFERRED :: p2 ! { dg-error "Interface must be specified" }
+ PROCEDURE(intf), NOPASS :: p3 ! { dg-error "should be declared DEFERRED" }
+ PROCEDURE(intf), DEFERRED, NON_OVERRIDABLE :: p4 ! { dg-error "can't both" }
+ PROCEDURE(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|module procedure" }
+ PROCEDURE(intf), DEFERRED, DEFERRED :: p6 ! { dg-error "Duplicate DEFERRED" }
+ PROCEDURE(intf), DEFERRED :: p6 => proc ! { dg-error "is invalid for DEFERRED" }
+ PROCEDURE(), DEFERRED :: p7 ! { dg-error "Interface-name expected" }
+ PROCEDURE(intf, DEFERRED) :: p8 ! { dg-error "'\\)' expected" }
+ END TYPE abstract_type
+
+END MODULE testmod
+
+! { dg-final { cleanup-modules "testmod" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (revision 142526)
+++ gcc/testsuite/gfortran.dg/typebound_proc_4.f03 (working copy)
@@ -30,10 +30,6 @@ MODULE testmod
PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" }
PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" }
PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" }
-
- ! TODO: Correct these when things get implemented.
- PROCEDURE, DEFERRED :: x ! { dg-error "not yet implemented" }
- PROCEDURE(abc) ! { dg-error "not yet implemented" }
END TYPE t
CONTAINS