diff options
author | Paul Thomas <pault@gcc.gnu.org> | 2018-08-23 06:27:54 +0000 |
---|---|---|
committer | Paul Thomas <pault@gcc.gnu.org> | 2018-08-23 06:27:54 +0000 |
commit | 6ab6c0c3bb09707f993a748c67087838f6b7d5f9 (patch) | |
tree | 7f33595b13c10f6fd3bd43c4e1e90953ca66ec41 | |
parent | ba7a2ad8bdc51dbfaaa1a83b24b0417691a5a80d (diff) | |
download | gcc-6ab6c0c3bb09707f993a748c67087838f6b7d5f9.zip gcc-6ab6c0c3bb09707f993a748c67087838f6b7d5f9.tar.gz gcc-6ab6c0c3bb09707f993a748c67087838f6b7d5f9.tar.bz2 |
re PR fortran/86863 ([OOP][F2008] type-bound module procedure name not recognized)
2017-08-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/86863
* resolve.c (resolve_typebound_call): If the TBP is not marked
as a subroutine, check the specific symbol.
2017-08-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/86863
* gfortran.dg/submodule_32.f08: New test.
From-SVN: r263799
-rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 14 | ||||
-rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
-rw-r--r-- | gcc/testsuite/gfortran.dg/submodule_32.f08 | 62 |
4 files changed, 84 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 56e9c95..4cbdc68 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2017-08-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/86863 + * resolve.c (resolve_typebound_call): If the TBP is not marked + as a subroutine, check the specific symbol. + 2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org> * gfortran.texi: Mention that asynchronous I/O does diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 4ad4dcf..43a8470 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6266,9 +6266,17 @@ resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) /* Check that's really a SUBROUTINE. */ if (!c->expr1->value.compcall.tbp->subroutine) { - gfc_error ("%qs at %L should be a SUBROUTINE", - c->expr1->value.compcall.name, &c->loc); - return false; + if (!c->expr1->value.compcall.tbp->is_generic + && c->expr1->value.compcall.tbp->u.specific + && c->expr1->value.compcall.tbp->u.specific->n.sym + && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine) + c->expr1->value.compcall.tbp->subroutine = 1; + else + { + gfc_error ("%qs at %L should be a SUBROUTINE", + c->expr1->value.compcall.name, &c->loc); + return false; + } } if (!check_typebound_baseobject (c->expr1)) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e70d05..d011aa7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-08-23 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/86863 + * gfortran.dg/submodule_32.f08: New test. + 2018-08-22 Janus Weil <janus@gcc.gnu.org> PR fortran/86935 diff --git a/gcc/testsuite/gfortran.dg/submodule_32.f08 b/gcc/testsuite/gfortran.dg/submodule_32.f08 new file mode 100644 index 0000000..529015b8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/submodule_32.f08 @@ -0,0 +1,62 @@ +! { dg-do run } +! +! Test the fix for PR86863, where the Type Bound Procedures were +! not flagged as subroutines thereby causing an error at the call +! statements. +! +! Contributed by Damian Rouson <damian@sourceryinstitute.org> +! +module foo + implicit none + integer :: flag = 0 + type bar + contains + procedure, nopass :: foobar + procedure, nopass :: barfoo + end type +contains + subroutine foobar + flag = 1 + end subroutine + subroutine barfoo + flag = 0 + end subroutine +end module + +module foobartoo + implicit none + interface + module subroutine set(object) + use foo + implicit none + type(bar) object + end subroutine + module subroutine unset(object) + use foo + implicit none + type(bar) object + end subroutine + end interface +contains + module procedure unset + use foo, only : bar + call object%barfoo + end procedure +end module + +submodule(foobartoo) subfoobar +contains + module procedure set + use foo, only : bar + call object%foobar + end procedure +end submodule + + use foo + use foobartoo + type(bar) :: obj + call set(obj) + if (flag .ne. 1) stop 1 + call unset(obj) + if (flag .ne. 0) stop 2 +end |