diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2e27433e9d5..48dd521d85f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2010-06-12 Janus Weil + + PR fortran/40117 + * decl.c (match_procedure_in_type): Allow procedure lists (F08). + 2010-06-11 Francois-Xavier Coudert * trans-intrinsic.c (gfc_build_intrinsic_lib_fndecls): Fix comment. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index e2de24f3f13..f969383fdc8 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4d2a83da63f..e56ac3af3f0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-06-12 Janus Weil + + 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 * gcc.dg/opts-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_14.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_14.f03 new file mode 100644 index 00000000000..766a0ef66c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_14.f03 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 40117: [OOP][F2008] Type-bound procedure: allow list after PROCEDURE +! +! Contributed by Janus Weil + +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" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_15.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_15.f03 new file mode 100644 index 00000000000..a8a2ce7e87a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_15.f03 @@ -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 + +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" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 index 92adc1a852a..60aa728a40f 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 @@ -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" }