Dear All, The original testcase appears here as dtio_19.f90. I gather that some vendors accept this, while fort does not. IMHO ifort is correct here since there is no specific DTIO procedure present. However, it could be that a more helpful error message to the effect that this is an abstract type and so "do not expect to do DTIO with it" is more appropriate. If this is desired, I can make it so.
dtio_20.f90 checks that correct code works. Bootstraps and regtests on FC21/x86_64 - OK for trunk? Paul 2016-12-12 Paul Thomas <pa...@gcc.gnu.org> PR fortran/78737 * interface.c (gfc_compare_interfaces): Whitespace. (gfc_find_specific_dtio_proc): Return NULL if dtio_sub is an abstract interface. * resolve.c (resolve_transfer): Formatting. (resolve_typebound_procedure): Ditto. 2016-12-12 Paul Thomas <pa...@gcc.gnu.org> PR fortran/78737 * gfortran.dg/dtio_19: New test. * gfortran.dg/dtio_20: New test.
Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 243516) --- gcc/fortran/interface.c (working copy) *************** gfc_compare_interfaces (gfc_symbol *s1, *** 1712,1719 **** return 0; /* Special case: alternate returns. If both f1->sym and f2->sym are ! NULL, then the leading formal arguments are alternate returns. ! The previous conditional should catch argument lists with different number of argument. */ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) return 1; --- 1712,1719 ---- return 0; /* Special case: alternate returns. If both f1->sym and f2->sym are ! NULL, then the leading formal arguments are alternate returns. ! The previous conditional should catch argument lists with different number of argument. */ if (f1 && f1->sym == NULL && f2 && f2->sym == NULL) return 1; *************** gfc_find_specific_dtio_proc (gfc_symbol *** 4893,4898 **** --- 4893,4901 ---- dtio_sub = st->n.tb->u.specific->n.sym; else dtio_sub = specific_proc->u.specific->n.sym; + + if (dtio_sub->attr.abstract && dtio_sub->attr.if_source == IFSRC_IFBODY) + return NULL; } if (tb_io_st != NULL) Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 243517) --- gcc/fortran/resolve.c (working copy) *************** resolve_transfer (gfc_code *code) *** 8982,8993 **** } if (ts->type == BT_CLASS && dtio_sub == NULL) ! { ! gfc_error ("Data transfer element at %L cannot be polymorphic unless " ! "it is processed by a defined input/output procedure", ! &code->loc); ! return; ! } if (ts->type == BT_DERIVED) { --- 8982,8990 ---- } if (ts->type == BT_CLASS && dtio_sub == NULL) ! gfc_error ("Data transfer element at %L cannot be polymorphic unless " ! "it is processed by a defined input/output procedure", ! &code->loc); if (ts->type == BT_DERIVED) { *************** resolve_typebound_procedure (gfc_symtree *** 13002,13009 **** goto error; } ! if (CLASS_DATA (me_arg)->ts.u.derived ! != resolve_bindings_derived) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" " the derived-type %qs", me_arg->name, proc->name, --- 12999,13005 ---- goto error; } ! if (CLASS_DATA (me_arg)->ts.u.derived != resolve_bindings_derived) { gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" " the derived-type %qs", me_arg->name, proc->name, Index: gcc/testsuite/gfortran.dg/dtio_19.f90 =================================================================== *** gcc/testsuite/gfortran.dg/dtio_19.f90 (revision 0) --- gcc/testsuite/gfortran.dg/dtio_19.f90 (working copy) *************** *** 0 **** --- 1,31 ---- + ! { dg-do compile } + ! + ! Test the fix for PR78737. + ! + ! Contributed by Damian Rouson <dam...@sourceryinstitute.org> + ! + module object_interface + type, abstract :: object + contains + procedure(write_formatted_interface), deferred ::write_formatted + generic :: write(formatted)=>write_formatted + end type + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import object + class(object), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + end subroutine + end interface + contains + subroutine assert(a) + class(object):: a + write(*,*) a ! { dg-error "cannot be polymorphic" } + end subroutine + end module + + end Index: gcc/testsuite/gfortran.dg/dtio_20.f90 =================================================================== *** gcc/testsuite/gfortran.dg/dtio_20.f90 (revision 0) --- gcc/testsuite/gfortran.dg/dtio_20.f90 (working copy) *************** *** 0 **** --- 1,54 ---- + ! { dg-do run } + ! + ! Test the fix for PR78737. + ! + ! Contributed by Damian Rouson <dam...@sourceryinstitute.org> + ! + module object_interface + character(30) :: buffer(2) + type, abstract :: object + contains + procedure(write_formatted_interface), deferred :: write_formatted + generic :: write(formatted) => write_formatted + end type + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import object + class(object), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + end subroutine + end interface + type, extends(object) :: non_abstract_child + integer :: i + contains + procedure :: write_formatted => write_formatted2 + end type + contains + subroutine write_formatted2(this,unit,iotype,vlist,iostat,iomsg) + class(non_abstract_child), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write(unit,'(a,i4/)') "write_formatted2 => ", this%i + end subroutine + subroutine assert(a) + class(object):: a + select type (a) + class is (non_abstract_child) + write(buffer,'(DT)') a + end select + end subroutine + end module + + use object_interface + class (object), allocatable :: z + allocate (z, source = non_abstract_child (99)) + call assert (z) + if (trim (buffer(1)) .ne. "write_formatted2 => 99") call abort + end