re PR fortran/37423 (Fortran 2003: DEFERRED bindings not yet implemented)
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. 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. From-SVN: r145248
This commit is contained in:
Daniel Kraft
Daniel Kraft
parent
0340f2ba6e
commit
b0e5fa9401
|
|
@ -1,3 +1,27 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -6732,6 +6732,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic)
|
|||
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_proc* ba, bool generic)
|
|||
}
|
||||
|
||||
/* 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_proc* ba, bool generic)
|
|||
}
|
||||
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. */
|
||||
|
|
|
|||
|
|
@ -601,6 +601,11 @@ name, and later during resolution phase the corresponding argument is looked for
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -1700,6 +1700,7 @@ static const mstring binding_overriding[] =
|
|||
{
|
||||
minit ("OVERRIDABLE", 0),
|
||||
minit ("NON_OVERRIDABLE", 1),
|
||||
minit ("DEFERRED", 2),
|
||||
minit (NULL, -1)
|
||||
};
|
||||
static const mstring binding_generic[] =
|
||||
|
|
@ -3205,6 +3206,7 @@ static void
|
|||
mio_typebound_proc (gfc_typebound_proc** proc)
|
||||
{
|
||||
int flag;
|
||||
int overriding_flag;
|
||||
|
||||
if (iomode == IO_INPUT)
|
||||
{
|
||||
|
|
@ -3217,9 +3219,15 @@ mio_typebound_proc (gfc_typebound_proc** 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)
|
||||
|
|
|
|||
|
|
@ -4551,6 +4551,30 @@ update_compcall_arglist (gfc_expr* e)
|
|||
}
|
||||
|
||||
|
||||
/* 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. */
|
||||
|
|
@ -4668,6 +4692,9 @@ resolve_typebound_call (gfc_code* c)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (check_typebound_baseobject (c->expr) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (resolve_typebound_generic_call (c->expr) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
|
|
@ -4704,6 +4731,9 @@ resolve_compcall (gfc_expr* e)
|
|||
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);
|
||||
|
|
@ -8163,6 +8193,14 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
|
|||
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)
|
||||
{
|
||||
|
|
@ -8505,11 +8543,11 @@ resolve_typebound_procedure (gfc_symtree* stree)
|
|||
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);
|
||||
|
|
@ -8664,6 +8702,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
|
||||
|
|
@ -8791,6 +8890,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);
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,13 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,45 @@
|
|||
! { 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
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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" } }
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
Loading…
Reference in New Issue