+2009-03-29 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.
+ (check_typebound_baseobject): New method.
+ (resolve_compcall), (resolve_typebound_call): Check base-object of
+ the type-bound procedure call.
+ * gfc-internals.texi (Type-bound procedures): Document a little bit
+ about internal handling of DEFERRED bindings.
+
2008-03-29 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/38507
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)
}
/* 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. */
}
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;
{
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;
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. */
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)
}
/* 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"
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. */
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
union
{
- struct gfc_symtree* specific;
+ struct gfc_symtree* specific; /* The interface if DEFERRED. */
gfc_tbp_generic* generic;
}
u;
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. */
{
minit ("OVERRIDABLE", 0),
minit ("NON_OVERRIDABLE", 1),
+ minit ("DEFERRED", 2),
minit (NULL, -1)
};
static const mstring binding_generic[] =
mio_typebound_proc (gfc_typebound_proc** proc)
{
int flag;
+ int overriding_flag;
if (iomode == IO_INPUT)
{
(*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)
}
+/* Check that the object a TBP is called on is valid, i.e. it must not be
+ of ABSTRACT type (as in subobject%abstract_parent%tbp()). */
+
+static gfc_try
+check_typebound_baseobject (gfc_expr* e)
+{
+ gfc_expr* base;
+
+ base = extract_compcall_passed_object (e);
+ if (!base)
+ return FAILURE;
+
+ gcc_assert (base->ts.type == BT_DERIVED);
+ if (base->ts.derived->attr.abstract)
+ {
+ gfc_error ("Base object for type-bound procedure call at %L is of"
+ " ABSTRACT type '%s'", &e->where, base->ts.derived->name);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
/* Resolve a call to a type-bound procedure, either function or subroutine,
statically from the data in an EXPR_COMPCALL expression. The adapted
arglist and the target-procedure symtree are returned. */
return FAILURE;
}
+ if (check_typebound_baseobject (c->expr) == FAILURE)
+ return FAILURE;
+
if (resolve_typebound_generic_call (c->expr) == FAILURE)
return FAILURE;
return FAILURE;
}
+ if (check_typebound_baseobject (e) == FAILURE)
+ return FAILURE;
+
if (resolve_typebound_generic_call (e) == FAILURE)
return FAILURE;
gcc_assert (!e->value.compcall.tbp->is_generic);
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)
{
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);
}
+/* 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
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);
+2009-03-29 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.
+ * gfortran.dg/abstract_type_5.f03: New test.
+
2008-03-29 Tobias Schlüter <tobi@gcc.gnu.org>
PR fortran/38507
--- /dev/null
+! { dg-do "compile" }
+
+! Abstract Types.
+! Check for correct handling of abstract-typed base object references.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE, ABSTRACT :: abstract_t
+ INTEGER :: i
+ CONTAINS
+ PROCEDURE, NOPASS :: proc
+ PROCEDURE, NOPASS :: func
+ END TYPE abstract_t
+
+ TYPE, EXTENDS(abstract_t) :: concrete_t
+ END TYPE concrete_t
+
+CONTAINS
+
+ SUBROUTINE proc ()
+ IMPLICIT NONE
+ ! Do nothing
+ END SUBROUTINE proc
+
+ INTEGER FUNCTION func ()
+ IMPLICIT NONE
+ func = 1234
+ END FUNCTION func
+
+ SUBROUTINE test ()
+ IMPLICIT NONE
+ TYPE(concrete_t) :: obj
+
+ ! These are ok.
+ obj%abstract_t%i = 42
+ CALL obj%proc ()
+ PRINT *, obj%func ()
+
+ ! These are errors (even though the procedures are not DEFERRED!).
+ CALL obj%abstract_t%proc () ! { dg-error "is of ABSTRACT type" }
+ PRINT *, obj%abstract_t%func () ! { dg-error "is of ABSTRACT type" }
+ END SUBROUTINE test
+
+END MODULE m
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
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
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
