Dear All,
Please find attached a patch to clean up the various issues with
errors in DTIO procedures. The tests were all provided by Gerhard
Steinmetz for which thanks are due.
I intend to commit this patch as 'obvious' tomorrow morning unless
there are any objections in the meantime.
Bootstrapped and regtested on x86_64/FC21 - OK for trunk?
Paul
2016-09-21 Paul Thomas <pa...@gcc.gnu.org>
* interface.c (check_dtio_interface1): Introduce errors for
alternate returns and incorrect numbers of arguments.
(gfc_find_specific_dtio_proc): Return cleanly if the derived
type either doesn't exist or has no namespace.
2016-09-21 Paul Thomas <pa...@gcc.gnu.org>
* gfortran.dg/dtio_13.f90: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 240301)
--- gcc/fortran/interface.c (working copy)
*************** check_dtio_interface1 (gfc_symbol *deriv
*** 4629,4635 ****
for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
{
! if (intr->sym && intr->sym->formal
&& ((intr->sym->formal->sym->ts.type == BT_CLASS
&& CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
== derived)
--- 4629,4635 ----
for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
{
! if (intr->sym && intr->sym->formal && intr->sym->formal->sym
&& ((intr->sym->formal->sym->ts.type == BT_CLASS
&& CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
== derived)
*************** check_dtio_interface1 (gfc_symbol *deriv
*** 4639,4644 ****
--- 4639,4650 ----
dtio_sub = intr->sym;
break;
}
+ else if (intr->sym && intr->sym->formal && !intr->sym->formal->sym)
+ {
+ gfc_error ("Alternate return at %L is not permitted in a DTIO "
+ "procedure", &intr->sym->declared_at);
+ return;
+ }
}
if (dtio_sub == NULL)
*************** check_dtio_interface1 (gfc_symbol *deriv
*** 4647,4655 ****
gcc_assert (dtio_sub);
if (!dtio_sub->attr.subroutine)
! gfc_error ("DTIO procedure %s at %L must be a subroutine",
dtio_sub->name, &dtio_sub->declared_at);
/* Now go through the formal arglist. */
arg_num = 1;
for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
--- 4653,4680 ----
gcc_assert (dtio_sub);
if (!dtio_sub->attr.subroutine)
! gfc_error ("DTIO procedure '%s' at %L must be a subroutine",
dtio_sub->name, &dtio_sub->declared_at);
+ arg_num = 0;
+ for (formal = dtio_sub->formal; formal; formal = formal->next)
+ arg_num++;
+
+ if (arg_num < (formatted ? 6 : 4))
+ {
+ gfc_error ("Too few dummy arguments in DTIO procedure '%s' at %L",
+ dtio_sub->name, &dtio_sub->declared_at);
+ return;
+ }
+
+ if (arg_num > (formatted ? 6 : 4))
+ {
+ gfc_error ("Too many dummy arguments in DTIO procedure '%s' at %L",
+ dtio_sub->name, &dtio_sub->declared_at);
+ return;
+ }
+
+
/* Now go through the formal arglist. */
arg_num = 1;
for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
*************** check_dtio_interface1 (gfc_symbol *deriv
*** 4657,4662 ****
--- 4682,4695 ----
if (!formatted && arg_num == 3)
arg_num = 5;
fsym = formal->sym;
+
+ if (fsym == NULL)
+ {
+ gfc_error ("Alternate return at %L is not permitted in a DTIO "
+ "procedure", &dtio_sub->declared_at);
+ return;
+ }
+
switch (arg_num)
{
case(1): /* DTV */
*************** gfc_find_specific_dtio_proc (gfc_symbol
*** 4823,4828 ****
--- 4856,4864 ----
for (extended = derived; extended;
extended = gfc_get_derived_super_type (extended))
{
+ if (extended == NULL || extended->ns == NULL)
+ return NULL;
+
if (formatted == true)
{
if (write == true)
Index: gcc/testsuite/gfortran.dg/dtio_13.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_13.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_13.f90 (working copy)
***************
*** 0 ****
--- 1,144 ----
+ ! { dg-do compile }
+ ! { dg-options -std=legacy }
+ !
+ ! Test elimination of various segfaults and ICEs on error recovery.
+ !
+ ! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fort...@t-online.de>
+ !
+ module m1
+ type t
+ end type
+ interface write(formatted)
+ module procedure s
+ end interface
+ contains
+ subroutine s(dtv,unit,iotype,vlist,extra,iostat,iomsg) ! { dg-error "Too
many dummy arguments" }
+ class(t), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end
+ end
+
+ module m2
+ type t
+ end type
+ interface read(formatted)
+ module procedure s
+ end interface
+ contains
+ subroutine s(dtv,unit,iotype,vlist,iostat,iomsg,extra) ! { dg-error "Too
many dummy arguments" }
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end
+ end
+
+ module m3
+ type t
+ end type
+ interface read(formatted)
+ module procedure s
+ end interface
+ contains
+ subroutine s(dtv,extra,unit,iotype,vlist,iostat,iomsg) ! { dg-error "Too
many dummy arguments" }
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: vlist(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ end
+ end
+
+ module m4
+ type t
+ end type
+ interface write(unformatted)
+ module procedure s
+ end interface
+ contains
+ subroutine s(*) ! { dg-error "Alternate return" }
+ end
+ end
+
+ module m5
+ type t
+ contains
+ procedure :: s
+ generic :: write(unformatted) => s
+ end type
+ contains
+ subroutine s(dtv, *) ! { dg-error "Too few dummy arguments" }
+ class(t), intent(out) :: dtv
+ end
+ end
+
+ module m6
+ type t
+ character(len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pruf
+ generic :: read(unformatted) => pruf
+ end type
+ contains
+ subroutine pruf (dtv,unit,*,iomsg) ! { dg-error "Alternate return" }
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(inout) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end
+ end
+
+ module m7
+ type t
+ character(len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pruf
+ generic :: read(unformatted) => pruf
+ end type
+ contains
+ subroutine pruf (dtv,unit,iostat) ! { dg-error "Too few dummy arguments" }
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=1) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end
+ end
+
+ module m
+ type t
+ character(len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pruf
+ generic :: read(unformatted) => pruf
+ end type
+ contains
+ subroutine pruf (dtv,unit,iostat,iomsg)
+ class(t), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end
+ end
+ program test
+ use m
+ character(3) :: a, b
+ class(t) :: chairman ! { dg-error "must be dummy, allocatable or pointer" }
+ open (unit=71, file='myunformatted_data.dat', form='unformatted')
+ ! The following error is spurious and is eliminated if previous error is
corrected.
+ ! TODO Although better than an ICE, fix me.
+ read (71) a, chairman, b ! { dg-error "cannot be polymorphic" }
+ close (unit=71)
+ end
+
