re PR fortran/40117 ([OOP][F2008] Type-bound procedure: allow list after PROCEDURE)
2010-06-12 Janus Weil <janus@gcc.gnu.org> PR fortran/40117 * decl.c (match_procedure_in_type): Allow procedure lists (F08). 2010-06-12 Janus Weil <janus@gcc.gnu.org> PR fortran/40117 * gfortran.dg/typebound_proc_4.f03: Modified error message. * gfortran.dg/typebound_proc_14.f03: New. * gfortran.dg/typebound_proc_15.f03: New. From-SVN: r160646
This commit is contained in:
Janus Weil
parent
1130db7eee
commit
1be179930b
6 changed files with 167 additions and 91 deletions
|
|
@ -1,3 +1,8 @@
|
|||
2010-06-12 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40117
|
||||
* decl.c (match_procedure_in_type): Allow procedure lists (F08).
|
||||
|
||||
2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
|
||||
|
||||
* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment.
|
||||
|
|
|
|||
|
|
@ -7542,7 +7542,7 @@ match_procedure_in_type (void)
|
|||
{
|
||||
char name[GFC_MAX_SYMBOL_LEN + 1];
|
||||
char target_buf[GFC_MAX_SYMBOL_LEN + 1];
|
||||
char* target = NULL;
|
||||
char* target = NULL, *ifc = NULL;
|
||||
gfc_typebound_proc* tb;
|
||||
bool seen_colons;
|
||||
bool seen_attrs;
|
||||
|
|
@ -7550,6 +7550,7 @@ match_procedure_in_type (void)
|
|||
gfc_symtree* stree;
|
||||
gfc_namespace* ns;
|
||||
gfc_symbol* block;
|
||||
int num;
|
||||
|
||||
/* Check current state. */
|
||||
gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
|
||||
|
|
@ -7574,7 +7575,7 @@ match_procedure_in_type (void)
|
|||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
target = target_buf;
|
||||
ifc = target_buf;
|
||||
}
|
||||
|
||||
/* Construct the data structure. */
|
||||
|
|
@ -7588,14 +7589,13 @@ 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)
|
||||
/* Check that attribute DEFERRED is given if an interface is specified. */
|
||||
if (tb->deferred && !ifc)
|
||||
{
|
||||
gfc_error ("Interface must be specified for DEFERRED binding at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
if (target && !tb->deferred)
|
||||
if (ifc && !tb->deferred)
|
||||
{
|
||||
gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
|
||||
return MATCH_ERROR;
|
||||
|
|
@ -7612,97 +7612,102 @@ match_procedure_in_type (void)
|
|||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* Match the binding name. */
|
||||
m = gfc_match_name (name);
|
||||
if (m == MATCH_ERROR)
|
||||
return m;
|
||||
if (m == MATCH_NO)
|
||||
/* Match the binding names. */
|
||||
for(num=1;;num++)
|
||||
{
|
||||
gfc_error ("Expected binding name at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* Try to match the '=> target', if it's there. */
|
||||
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"
|
||||
" at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
m = gfc_match_name (target_buf);
|
||||
m = gfc_match_name (name);
|
||||
if (m == MATCH_ERROR)
|
||||
return m;
|
||||
if (m == MATCH_NO)
|
||||
{
|
||||
gfc_error ("Expected binding target after '=>' at %C");
|
||||
gfc_error ("Expected binding name at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
target = target_buf;
|
||||
|
||||
if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
|
||||
" at %C") == FAILURE)
|
||||
return MATCH_ERROR;
|
||||
|
||||
/* Try to match the '=> target', if it's there. */
|
||||
target = ifc;
|
||||
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"
|
||||
" at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
m = gfc_match_name (target_buf);
|
||||
if (m == MATCH_ERROR)
|
||||
return m;
|
||||
if (m == MATCH_NO)
|
||||
{
|
||||
gfc_error ("Expected binding target after '=>' at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
target = target_buf;
|
||||
}
|
||||
|
||||
/* If no target was found, it has the same name as the binding. */
|
||||
if (!target)
|
||||
target = name;
|
||||
|
||||
/* Get the namespace to insert the symbols into. */
|
||||
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. */
|
||||
stree = gfc_find_symtree (ns->tb_sym_root, name);
|
||||
if (stree && stree->n.tb)
|
||||
{
|
||||
gfc_error ("There is already a procedure with binding name '%s' for "
|
||||
"the derived type '%s' at %C", name, block->name);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* Insert it and set attributes. */
|
||||
|
||||
if (!stree)
|
||||
{
|
||||
stree = gfc_new_symtree (&ns->tb_sym_root, name);
|
||||
gcc_assert (stree);
|
||||
}
|
||||
stree->n.tb = tb;
|
||||
|
||||
if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
|
||||
return MATCH_ERROR;
|
||||
gfc_set_sym_referenced (tb->u.specific->n.sym);
|
||||
|
||||
if (gfc_match_eos () == MATCH_YES)
|
||||
return MATCH_YES;
|
||||
if (gfc_match_char (',') != MATCH_YES)
|
||||
goto syntax;
|
||||
}
|
||||
|
||||
/* Now we should have the end. */
|
||||
m = gfc_match_eos ();
|
||||
if (m == MATCH_ERROR)
|
||||
return m;
|
||||
if (m == MATCH_NO)
|
||||
{
|
||||
gfc_error ("Junk after PROCEDURE declaration at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* If no target was found, it has the same name as the binding. */
|
||||
if (!target)
|
||||
target = name;
|
||||
|
||||
/* Get the namespace to insert the symbols into. */
|
||||
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. */
|
||||
stree = gfc_find_symtree (ns->tb_sym_root, name);
|
||||
if (stree && stree->n.tb)
|
||||
{
|
||||
gfc_error ("There's already a procedure with binding name '%s' for the"
|
||||
" derived type '%s' at %C", name, block->name);
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
/* Insert it and set attributes. */
|
||||
|
||||
if (!stree)
|
||||
{
|
||||
stree = gfc_new_symtree (&ns->tb_sym_root, name);
|
||||
gcc_assert (stree);
|
||||
}
|
||||
stree->n.tb = tb;
|
||||
|
||||
if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
|
||||
return MATCH_ERROR;
|
||||
gfc_set_sym_referenced (tb->u.specific->n.sym);
|
||||
|
||||
return MATCH_YES;
|
||||
syntax:
|
||||
gfc_error ("Syntax error in PROCEDURE statement at %C");
|
||||
return MATCH_ERROR;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2010-06-12 Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
PR fortran/40117
|
||||
* gfortran.dg/typebound_proc_4.f03: Modified error message.
|
||||
* gfortran.dg/typebound_proc_14.f03: New.
|
||||
* gfortran.dg/typebound_proc_15.f03: New.
|
||||
|
||||
2010-06-11 Joseph Myers <joseph@codesourcery.com>
|
||||
|
||||
* gcc.dg/opts-1.c: New test.
|
||||
|
|
|
|||
33
gcc/testsuite/gfortran.dg/typebound_proc_14.f03
Normal file
33
gcc/testsuite/gfortran.dg/typebound_proc_14.f03
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
! { dg-do compile }
|
||||
!
|
||||
! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
module m
|
||||
|
||||
implicit none
|
||||
|
||||
type :: t
|
||||
contains
|
||||
procedure :: foo, bar, baz
|
||||
end type
|
||||
|
||||
contains
|
||||
|
||||
subroutine foo (this)
|
||||
class(t) :: this
|
||||
end subroutine
|
||||
|
||||
real function bar (this)
|
||||
class(t) :: this
|
||||
end function
|
||||
|
||||
subroutine baz (this, par)
|
||||
class(t) :: this
|
||||
integer :: par
|
||||
end subroutine
|
||||
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
26
gcc/testsuite/gfortran.dg/typebound_proc_15.f03
Normal file
26
gcc/testsuite/gfortran.dg/typebound_proc_15.f03
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-std=f2003" }
|
||||
!
|
||||
! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE
|
||||
!
|
||||
! Contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
|
||||
module m
|
||||
|
||||
implicit none
|
||||
|
||||
type :: t
|
||||
contains
|
||||
procedure :: foo
|
||||
procedure :: bar, baz { dg-error "PROCEDURE list" }
|
||||
end type
|
||||
|
||||
contains
|
||||
|
||||
subroutine foo (this)
|
||||
class(t) :: this
|
||||
end subroutine
|
||||
|
||||
end
|
||||
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
|
|
@ -17,12 +17,12 @@ MODULE testmod
|
|||
PROCEDURE ? ! { dg-error "Expected binding name" }
|
||||
PROCEDURE :: p2 => ! { dg-error "Expected binding target" }
|
||||
PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" }
|
||||
PROCEDURE p4, ! { dg-error "Junk after" }
|
||||
PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" }
|
||||
PROCEDURE p4, ! { dg-error "Expected binding name" }
|
||||
PROCEDURE :: p5 => proc2, ! { dg-error "Expected binding name" }
|
||||
PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" }
|
||||
PROCEDURE, PASS p6 ! { dg-error "::" }
|
||||
PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" }
|
||||
PROCEDURE PASS :: ! { dg-error "Junk after" }
|
||||
PROCEDURE PASS :: ! { dg-error "Syntax error" }
|
||||
PROCEDURE, PASS (x ! { dg-error "Expected" }
|
||||
PROCEDURE, PASS () ! { dg-error "Expected" }
|
||||
PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" }
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue