From b6a45605019bfe2fe588961c6959630f8b9deed0 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Thu, 2 Aug 2012 10:57:58 +0200 Subject: [PATCH] re PR fortran/54147 ([F03] Interface checks for PPCs & deferred TBPs) 2012-08-02 Janus Weil PR fortran/54147 * resolve.c (check_proc_interface): New routine for PROCEDURE interface checks. (resolve_procedure_interface,resolve_typebound_procedure, resolve_fl_derived0): Call it. 2012-08-02 Janus Weil PR fortran/54147 * gfortran.dg/abstract_type_6.f03: Modified. * gfortran.dg/proc_ptr_comp_3.f90: Modified. * gfortran.dg/proc_ptr_comp_35.f90: New. * gfortran.dg/typebound_proc_9.f03: Modified. * gfortran.dg/typebound_proc_26.f90: New. From-SVN: r190069 --- gcc/fortran/ChangeLog | 8 ++ gcc/fortran/resolve.c | 122 +++++++++--------- gcc/testsuite/ChangeLog | 9 ++ gcc/testsuite/gfortran.dg/abstract_type_6.f03 | 2 +- gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 | 6 +- .../gfortran.dg/proc_ptr_comp_35.f90 | 35 +++++ .../gfortran.dg/typebound_proc_26.f90 | 38 ++++++ .../gfortran.dg/typebound_proc_9.f03 | 2 +- 8 files changed, 159 insertions(+), 63 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/proc_ptr_comp_35.f90 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_26.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a2b69d457577..5ed954a7745a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2012-08-02 Janus Weil + + PR fortran/54147 + * resolve.c (check_proc_interface): New routine for PROCEDURE interface + checks. + (resolve_procedure_interface,resolve_typebound_procedure, + resolve_fl_derived0): Call it. + 2012-08-01 Thomas König PR fortran/54033 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a6dd0dacdd0c..c5810b27172d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -138,31 +138,14 @@ resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) } -static void resolve_symbol (gfc_symbol *sym); - - -/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ - static gfc_try -resolve_procedure_interface (gfc_symbol *sym) +check_proc_interface (gfc_symbol *ifc, locus *where) { - gfc_symbol *ifc = sym->ts.interface; - - if (!ifc) - return SUCCESS; - /* Several checks for F08:C1216. */ - if (ifc == sym) - { - gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", - sym->name, &sym->declared_at); - return FAILURE; - } if (ifc->attr.procedure) { - gfc_error ("Interface '%s', used by procedure '%s' at %L, is declared " - "in a later PROCEDURE statement", ifc->name, - sym->name, &sym->declared_at); + gfc_error ("Interface '%s' at %L is declared " + "in a later PROCEDURE statement", ifc->name, where); return FAILURE; } if (ifc->generic) @@ -175,14 +158,14 @@ resolve_procedure_interface (gfc_symbol *sym) if (!gen) { gfc_error ("Interface '%s' at %L may not be generic", - ifc->name, &sym->declared_at); + ifc->name, where); return FAILURE; } } if (ifc->attr.proc == PROC_ST_FUNCTION) { gfc_error ("Interface '%s' at %L may not be a statement function", - ifc->name, &sym->declared_at); + ifc->name, where); return FAILURE; } if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) @@ -191,15 +174,44 @@ resolve_procedure_interface (gfc_symbol *sym) if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) { gfc_error ("Intrinsic procedure '%s' not allowed in " - "PROCEDURE statement at %L", ifc->name, &sym->declared_at); + "PROCEDURE statement at %L", ifc->name, where); + return FAILURE; + } + if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') + { + gfc_error ("Interface '%s' at %L must be explicit", ifc->name, where); return FAILURE; } + return SUCCESS; +} + + +static void resolve_symbol (gfc_symbol *sym); + + +/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ + +static gfc_try +resolve_procedure_interface (gfc_symbol *sym) +{ + gfc_symbol *ifc = sym->ts.interface; + + if (!ifc) + return SUCCESS; + + if (ifc == sym) + { + gfc_error ("PROCEDURE '%s' at %L may not be used as its own interface", + sym->name, &sym->declared_at); + return FAILURE; + } + if (check_proc_interface (ifc, &sym->declared_at) == FAILURE) + return FAILURE; - /* Get the attributes from the interface (now resolved). */ if (ifc->attr.if_source || ifc->attr.intrinsic) { + /* Resolve interface and copy attributes. */ resolve_symbol (ifc); - if (ifc->attr.intrinsic) gfc_resolve_intrinsic (ifc, &ifc->declared_at); @@ -246,12 +258,6 @@ resolve_procedure_interface (gfc_symbol *sym) return FAILURE; } } - else if (ifc->name[0] != '\0') - { - gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", - ifc->name, sym->name, &sym->declared_at); - return FAILURE; - } return SUCCESS; } @@ -11565,17 +11571,25 @@ resolve_typebound_procedure (gfc_symtree* stree) /* Default access should already be resolved from the parser. */ gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); - /* It should be a module procedure or an external procedure with explicit - 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 && !stree->n.tb->deferred)) + if (stree->n.tb->deferred) { - gfc_error ("'%s' must be a module procedure or an external procedure with" - " an explicit interface at %L", proc->name, &where); - goto error; + if (check_proc_interface (proc, &where) == FAILURE) + goto error; + } + else + { + /* Check for F08:C465. */ + if ((!proc->attr.subroutine && !proc->attr.function) + || (proc->attr.proc != PROC_MODULE + && proc->attr.if_source != IFSRC_IFBODY) + || proc->attr.abstract) + { + gfc_error ("'%s' must be a module procedure or an external procedure with" + " an explicit interface at %L", proc->name, &where); + goto error; + } } + stree->n.tb->subroutine = proc->attr.subroutine; stree->n.tb->function = proc->attr.function; @@ -11928,20 +11942,17 @@ resolve_fl_derived0 (gfc_symbol *sym) if (c->attr.proc_pointer && c->ts.interface) { - if (c->ts.interface->attr.procedure && !sym->attr.vtype) - gfc_error ("Interface '%s', used by procedure pointer component " - "'%s' at %L, is declared in a later PROCEDURE statement", - c->ts.interface->name, c->name, &c->loc); + gfc_symbol *ifc = c->ts.interface; - /* Get the attributes from the interface (now resolved). */ - if (c->ts.interface->attr.if_source - || c->ts.interface->attr.intrinsic) - { - gfc_symbol *ifc = c->ts.interface; + if (!sym->attr.vtype + && check_proc_interface (ifc, &c->loc) == FAILURE) + return FAILURE; + if (ifc->attr.if_source || ifc->attr.intrinsic) + { + /* Resolve interface and copy attributes. */ if (ifc->formal && !ifc->formal_ns) resolve_symbol (ifc); - if (ifc->attr.intrinsic) gfc_resolve_intrinsic (ifc, &ifc->declared_at); @@ -11980,25 +11991,18 @@ resolve_fl_derived0 (gfc_symbol *sym) gfc_expr_replace_comp (c->as->lower[i], c); gfc_expr_replace_comp (c->as->upper[i], c); } - } + } /* Copy char length. */ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) { gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); gfc_expr_replace_comp (cl->length, c); if (cl->length && !cl->resolved - && gfc_resolve_expr (cl->length) == FAILURE) + && gfc_resolve_expr (cl->length) == FAILURE) return FAILURE; c->ts.u.cl = cl; } } - else if (!sym->attr.vtype && c->ts.interface->name[0] != '\0') - { - gfc_error ("Interface '%s' of procedure pointer component " - "'%s' at %L must be explicit", c->ts.interface->name, - c->name, &c->loc); - return FAILURE; - } } else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c062bd978151..604782ca8ac3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2012-08-02 Janus Weil + + PR fortran/54147 + * gfortran.dg/abstract_type_6.f03: Modified. + * gfortran.dg/proc_ptr_comp_3.f90: Modified. + * gfortran.dg/proc_ptr_comp_35.f90: New. + * gfortran.dg/typebound_proc_9.f03: Modified. + * gfortran.dg/typebound_proc_26.f90: New. + 2012-08-02 Richard Guenther * gcc.dg/torture/pta-callused-1.c: Adjust. diff --git a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 index e4abd793288e..5eefcb836176 100644 --- a/gcc/testsuite/gfortran.dg/abstract_type_6.f03 +++ b/gcc/testsuite/gfortran.dg/abstract_type_6.f03 @@ -10,7 +10,7 @@ module m TYPE, ABSTRACT :: top CONTAINS - PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be a module procedure" } + PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be explicit" } ! some useful default behaviour PROCEDURE :: proc_c => top_c ! { dg-error "must be a module procedure" } END TYPE top diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 index 67d5b5360683..eb1d84555ddb 100644 --- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90 @@ -24,10 +24,13 @@ type :: t procedure, pointer, nopass :: ptr6 ! { dg-error "Syntax error" } procedure(), nopass :: ptr8 ! { dg-error "POINTER attribute is required" } procedure(pp), pointer, nopass :: ptr9 ! { dg-error "declared in a later PROCEDURE statement" } - procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" } real :: y end type t +type :: t2 + procedure(aaargh), pointer, nopass :: ptr10 ! { dg-error "must be explicit" } +end type + type,bind(c) :: bct ! { dg-error "BIND.C. derived type" } procedure(), pointer,nopass :: ptr ! { dg-error "cannot be a member of|may not be C interoperable" } end type bct @@ -47,4 +50,3 @@ print *,x%ptr3() ! { dg-error "attribute conflicts with" } call x%y ! { dg-error "Expected type-bound procedure or procedure pointer component" } end - diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_35.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_35.f90 new file mode 100644 index 000000000000..75a76b8ebbfe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_ptr_comp_35.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR 54147: [F03] Interface checks for PPCs & deferred TBPs +! +! Contributed by Janus Weil + + interface gen + procedure gen + end interface + + type t1 + procedure(gen),pointer,nopass :: p1 + procedure(gen2),pointer,nopass :: p2 ! { dg-error "may not be generic" } + end type + + type t2 + procedure(sf),pointer,nopass :: p3 ! { dg-error "may not be a statement function" } + end type + + type t3 + procedure(char),pointer,nopass :: p4 ! { dg-error "Intrinsic procedure" } + end type + + interface gen2 + procedure gen + end interface + + sf(x) = x**2 ! { dg-warning "Obsolescent feature" } + +contains + + subroutine gen + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_26.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_26.f90 new file mode 100644 index 000000000000..0c4264ed131b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_26.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR 54147: [F03] Interface checks for PPCs & deferred TBPs +! +! Contributed by Janus Weil + + interface gen + procedure gen + end interface + + type, abstract :: t1 + contains + procedure(gen),deferred,nopass :: p1 + procedure(gen2),deferred,nopass :: p2 ! { dg-error "may not be generic" } + end type + + type, abstract :: t2 + contains + procedure(sf),deferred,nopass :: p3 ! { dg-error "may not be a statement function" } + end type + + type, abstract :: t3 + contains + procedure(char),deferred,nopass :: p4 ! { dg-error "Intrinsic procedure" } + end type + + interface gen2 + procedure gen + end interface + + sf(x) = x**2 ! { dg-warning "Obsolescent feature" } + +contains + + subroutine gen + end subroutine + +end diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 index 3a96c0a92d4d..a6ca35bb010a 100644 --- a/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 +++ b/gcc/testsuite/gfortran.dg/typebound_proc_9.f03 @@ -21,7 +21,7 @@ MODULE testmod 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(unknown), DEFERRED :: p5 ! { dg-error "has no IMPLICIT|must be explicit" } 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" } -- 2.39.5