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 <[email protected]>
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 <[email protected]>
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 <[email protected]>
+ !
+ 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 <[email protected]>
+ !
+ 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
