Consider the following code: module module_myobj implicit none type :: myobj contains procedure :: myfunc end type contains function myfunc(this, status) class(myobj), intent(in) :: this integer, intent(out), optional :: status character(len=80) :: myfunc if (present(status)) then write (*,*) 'myfunc: status is present.' else write (*,*) 'myfunc: status is not present.' end if myfunc = ' ' end function end module program test_optional use :: module_myobj implicit none character(len=80) :: res integer :: status type(myobj) :: myinstance res = myfunc(myinstance) ! OK res = myfunc(myinstance, status) ! OK res = myinstance%myfunc() ! FAILED res = myinstance%myfunc(status) ! OK end program This currently produces the output: myfunc: status is not present. myfunc: status is present. myfunc: status is present. myfunc: status is present. The correct output would be: myfunc: status is not present. myfunc: status is present. myfunc: status is not present. myfunc: status is present. Apparently this only happens for type-bound character-valued functions (but not for subroutines or e.g. integer-valued functions). -fdump-tree-original shows the following for the four calls to 'myfunc': myfunc ((character(kind=1)[1:80] *) &str.3, 80, &class.2, 0B); myfunc ((character(kind=1)[1:80] *) &str.5, 80, &class.4, &status); myfunc ((character(kind=1)[1:80] *) &str.7, 80, &class.6); myfunc ((character(kind=1)[1:80] *) &str.9, 80, &class.8, &status); In the third case we fail to pass a null pointer for the missing optional arg.
(In reply to comment #0) > Apparently this only happens for type-bound character-valued functions (but not > for subroutines or e.g. integer-valued functions). Actually that is wrong. It does work with subroutines, but it fails with all sorts of functions, also integer-valued ones, and with NOPASS: module module_myobj implicit none type :: myobj contains procedure, nopass :: myfunc end type contains integer function myfunc(status) integer, optional :: status if (present(status)) then write (*,*) 'myfunc: status is present.' else write (*,*) 'myfunc: status is not present.' end if myfunc = 1 end function end module program test_optional use :: module_myobj implicit none integer :: res,status type(myobj) :: myinstance res = myfunc() ! OK res = myfunc(status) ! OK res = myinstance%myfunc() ! FAILED res = myinstance%myfunc(status) ! OK end program For checking if it works, one should not only look at the output of the program, since this could be correct by chance. Instead, one should look at the dump, to see if a zero is passed for the missing optional arg.
Btw, I just checked an analogous example with a procedure pointer component instead of a type-bound procedure, and this works.
Ok, think I got it. It's a one-liner: Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 157225) +++ gcc/fortran/resolve.c (working copy) @@ -5124,7 +5124,7 @@ resolve_compcall (gfc_expr* e, bool fcn) return FAILURE; e->value.function.actual = newactual; - e->value.function.name = e->value.compcall.name; + e->value.function.name = NULL; e->value.function.esym = target->n.sym; e->value.function.class_esym = NULL; e->value.function.isym = NULL; Hope this produces no regressions. [Explanation: The problem was that 'compare_actual_formal', which sets up the null pointer for the missing actual arg, was never called for the TBP call. Due to e->value.function.name being set already, 'resolve_function' always assumed the function call had already been resolved, although it was never done.]
(In reply to comment #3) > Hope this produces no regressions. Unfortunately it does :( FAIL: gfortran.dg/dynamic_dispatch_1.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_3.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_4.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_6.f03 -O0 (test for excess errors) FAIL: gfortran.dg/class_12.f03 -O (test for excess errors) FAIL: gfortran.dg/interface_abstract_4.f90 -O (test for excess errors)
(In reply to comment #4) > FAIL: gfortran.dg/dynamic_dispatch_1.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_3.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_4.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_6.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/class_12.f03 -O (test for excess errors) > FAIL: gfortran.dg/interface_abstract_4.f90 -O (test for excess errors) All of these throw error messages like ABSTRACT INTERFACE '...' must not be referenced at (1) or Type mismatch in argument '...' at (1); passed CLASS(...) to CLASS(...)
(In reply to comment #5) > All of these throw error messages like > > ABSTRACT INTERFACE '...' must not be referenced at (1) This was PR41873 and was fixed by querying "expr->value.function.name", which fails now. We should find a better way to silence this error message for polymorphic calls. > Type mismatch in argument '...' at (1); passed CLASS(...) to CLASS(...) This one is a bit more tricky, but understandable. It is not a problem of the one-line patch shown above, but of the implementation of polymorphic calls: When doing a polymorphic call with 'dynamic type /= declared type' of the passed object and an overridden TBP, we have to convert the passed object to a CLASS of the dynamic type.
(In reply to comment #6) > > ABSTRACT INTERFACE '...' must not be referenced at (1) > > This was PR41873 and was fixed by querying "expr->value.function.name", which > fails now. We should find a better way to silence this error message for > polymorphic calls. To solve this I propose the following: Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 157233) +++ gcc/fortran/resolve.c (working copy) @@ -2556,8 +2556,8 @@ resolve_function (gfc_expr *expr) } /* If this ia a deferred TBP with an abstract interface (which may - of course be referenced), expr->value.function.name will be set. */ - if (sym && sym->attr.abstract && !expr->value.function.name) + of course be referenced), expr->value.function.esym will be set. */ + if (sym && sym->attr.abstract && !expr->value.function.esym) { gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L", sym->name, &expr->where); This leaves us with the following regressions: FAIL: gfortran.dg/dynamic_dispatch_1.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_3.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_4.f03 -O0 (test for excess errors) FAIL: gfortran.dg/dynamic_dispatch_6.f03 -O0 (test for excess errors) due to the error Error: Type mismatch in argument '...' at (1); passed CLASS(...) to CLASS(...)
(In reply to comment #7) > This leaves us with the following regressions: > > FAIL: gfortran.dg/dynamic_dispatch_1.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_3.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_4.f03 -O0 (test for excess errors) > FAIL: gfortran.dg/dynamic_dispatch_6.f03 -O0 (test for excess errors) > > due to the error > > Error: Type mismatch in argument '...' at (1); passed CLASS(...) to CLASS(...) These are resolved when adding to the patches in comment #3 and #7 the following one: Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 157262) +++ gcc/fortran/resolve.c (working copy) @@ -5178,18 +5178,17 @@ check_class_members (gfc_symbol *derived) return; } - if (tbp->n.tb->is_generic) + /* If we have to match a passed class member, force the actual + expression to have the correct type. */ + if (!tbp->n.tb->nopass) { - /* If we have to match a passed class member, force the actual - expression to have the correct type. */ - if (!tbp->n.tb->nopass) - { - if (e->value.compcall.base_object == NULL) - e->value.compcall.base_object = - extract_compcall_passed_object (e); + if (e->value.compcall.base_object == NULL) + e->value.compcall.base_object = extract_compcall_passed_object (e); - e->value.compcall.base_object->ts.type = BT_DERIVED; - e->value.compcall.base_object->ts.u.derived = derived; + if (!derived->attr.abstract) + { + e->value.compcall.base_object->ts.type = BT_DERIVED; + e->value.compcall.base_object->ts.u.derived = derived; } } I hope that's it now. I'll do another regtest to make sure ...
For the record, the patch in comment #8 does not apply on fortran-dev. AFAICT the patches in comments #2 and 7 are enough for the branch.
Subject: Bug 43256 Author: janus Date: Mon Mar 8 09:35:04 2010 New Revision: 157272 URL: http://gcc.gnu.org/viewcvs?root=gcc&view=rev&rev=157272 Log: 2010-03-08 Janus Weil <janus@gcc.gnu.org> PR fortran/43256 * resolve.c (resolve_compcall): Don't set 'value.function.name' here for TBPs, otherwise they will not be resolved properly. (resolve_function): Use 'value.function.esym' instead of 'value.function.name' to check if we're dealing with a TBP. (check_class_members): Set correct type of passed object for all TBPs, not only generic ones, except if the type is abstract. 2010-03-08 Janus Weil <janus@gcc.gnu.org> PR fortran/43256 * gfortran.dg/typebound_call_13.f03: New. Added: trunk/gcc/testsuite/gfortran.dg/typebound_call_13.f03 Modified: trunk/gcc/fortran/ChangeLog trunk/gcc/fortran/resolve.c trunk/gcc/testsuite/ChangeLog
Fixed with r157272. Closing.