Commit 1be17993 by Janus Weil

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
parent 1130db7e
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> 2010-06-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
* trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment. * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment.
......
...@@ -7542,7 +7542,7 @@ match_procedure_in_type (void) ...@@ -7542,7 +7542,7 @@ match_procedure_in_type (void)
{ {
char name[GFC_MAX_SYMBOL_LEN + 1]; char name[GFC_MAX_SYMBOL_LEN + 1];
char target_buf[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; gfc_typebound_proc* tb;
bool seen_colons; bool seen_colons;
bool seen_attrs; bool seen_attrs;
...@@ -7550,6 +7550,7 @@ match_procedure_in_type (void) ...@@ -7550,6 +7550,7 @@ match_procedure_in_type (void)
gfc_symtree* stree; gfc_symtree* stree;
gfc_namespace* ns; gfc_namespace* ns;
gfc_symbol* block; gfc_symbol* block;
int num;
/* Check current state. */ /* Check current state. */
gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
...@@ -7574,7 +7575,7 @@ match_procedure_in_type (void) ...@@ -7574,7 +7575,7 @@ match_procedure_in_type (void)
return MATCH_ERROR; return MATCH_ERROR;
} }
target = target_buf; ifc = target_buf;
} }
/* Construct the data structure. */ /* Construct the data structure. */
...@@ -7588,14 +7589,13 @@ match_procedure_in_type (void) ...@@ -7588,14 +7589,13 @@ match_procedure_in_type (void)
return m; return m;
seen_attrs = (m == MATCH_YES); seen_attrs = (m == MATCH_YES);
/* Check that attribute DEFERRED is given iff an interface is specified, which /* Check that attribute DEFERRED is given if an interface is specified. */
means target != NULL. */ if (tb->deferred && !ifc)
if (tb->deferred && !target)
{ {
gfc_error ("Interface must be specified for DEFERRED binding at %C"); gfc_error ("Interface must be specified for DEFERRED binding at %C");
return MATCH_ERROR; return MATCH_ERROR;
} }
if (target && !tb->deferred) if (ifc && !tb->deferred)
{ {
gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
return MATCH_ERROR; return MATCH_ERROR;
...@@ -7612,97 +7612,102 @@ match_procedure_in_type (void) ...@@ -7612,97 +7612,102 @@ match_procedure_in_type (void)
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Match the binding name. */ /* Match the binding names. */
m = gfc_match_name (name); for(num=1;;num++)
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
{
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) m = gfc_match_name (name);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
{ {
gfc_error ("'=> target' is invalid for DEFERRED binding at %C"); gfc_error ("Expected binding name at %C");
return MATCH_ERROR; return MATCH_ERROR;
} }
if (!seen_colons) if (num>1 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: PROCEDURE list"
{ " at %C") == FAILURE)
gfc_error ("'::' needed in PROCEDURE binding with explicit target" return MATCH_ERROR;
" at %C");
return MATCH_ERROR;
}
m = gfc_match_name (target_buf); /* Try to match the '=> target', if it's there. */
target = ifc;
m = gfc_match (" =>");
if (m == MATCH_ERROR) if (m == MATCH_ERROR)
return m; return m;
if (m == MATCH_NO) if (m == MATCH_YES)
{ {
gfc_error ("Expected binding target after '=>' at %C"); if (tb->deferred)
return MATCH_ERROR; {
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;
} }
target = target_buf;
}
/* Now we should have the end. */ /* If no target was found, it has the same name as the binding. */
m = gfc_match_eos (); if (!target)
if (m == MATCH_ERROR) target = name;
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. */ /* Get the namespace to insert the symbols into. */
if (!target) ns = block->f2k_derived;
target = name; gcc_assert (ns);
/* Get the namespace to insert the symbols into. */ /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
ns = block->f2k_derived; if (tb->deferred && !block->attr.abstract)
gcc_assert (ns); {
gfc_error ("Type '%s' containing DEFERRED binding at %C "
"is not ABSTRACT", block->name);
return MATCH_ERROR;
}
/* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ /* See if we already have a binding with this name in the symtree which
if (tb->deferred && !block->attr.abstract) would be an error. If a GENERIC already targetted this binding, it may
{ be already there but then typebound is still NULL. */
gfc_error ("Type '%s' containing DEFERRED binding at %C is not ABSTRACT", stree = gfc_find_symtree (ns->tb_sym_root, name);
block->name); if (stree && stree->n.tb)
return MATCH_ERROR; {
} gfc_error ("There is already a procedure with binding name '%s' for "
"the derived type '%s' at %C", name, block->name);
return MATCH_ERROR;
}
/* See if we already have a binding with this name in the symtree which would /* Insert it and set attributes. */
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 (!stree) if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific, false))
{ return MATCH_ERROR;
stree = gfc_new_symtree (&ns->tb_sym_root, name); gfc_set_sym_referenced (tb->u.specific->n.sym);
gcc_assert (stree);
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
} }
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;
} }
......
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> 2010-06-11 Joseph Myers <joseph@codesourcery.com>
* gcc.dg/opts-1.c: New test. * gcc.dg/opts-1.c: New test.
......
! { 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" } }
! { 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 ...@@ -17,12 +17,12 @@ MODULE testmod
PROCEDURE ? ! { dg-error "Expected binding name" } PROCEDURE ? ! { dg-error "Expected binding name" }
PROCEDURE :: p2 => ! { dg-error "Expected binding target" } PROCEDURE :: p2 => ! { dg-error "Expected binding target" }
PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" } PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" }
PROCEDURE p4, ! { dg-error "Junk after" } PROCEDURE p4, ! { dg-error "Expected binding name" }
PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" } PROCEDURE :: p5 => proc2, ! { dg-error "Expected binding name" }
PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" } PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" }
PROCEDURE, PASS p6 ! { dg-error "::" } PROCEDURE, PASS p6 ! { dg-error "::" }
PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" } 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 (x ! { dg-error "Expected" }
PROCEDURE, PASS () ! { dg-error "Expected" } PROCEDURE, PASS () ! { dg-error "Expected" }
PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" } PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" }
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment