interface.c (check_dtio_interface1): Introduce errors for alternate returns and…

interface.c (check_dtio_interface1): Introduce errors for alternate returns and incorrect numbers of arguments.

2016-09-22  Paul Thomas  <pault@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-22  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/dtio_11.f90: Correct for changed error messages.
	* gfortran.dg/dtio_13.f90: New test.

From-SVN: r240342

gcc/fortran/ChangeLog

+2016-09-22  Paul Thomas  <pault@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  Louis Krupp  <louis.krupp@zoho.com>
 
 	PR fortran/66107

gcc/fortran/interface.c

@@ -4629,7 +4629,7 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
 
       for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
 	{
-	  if (intr->sym && intr->sym->formal
+	  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)
@@ -4639,6 +4639,12 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
 	      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)
@@ -4647,9 +4653,28 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
 
   gcc_assert (dtio_sub);
   if (!dtio_sub->attr.subroutine)
-    gfc_error ("DTIO procedure %s at %L must be a 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++)
@@ -4657,6 +4682,14 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
       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  */
@@ -4823,6 +4856,9 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
   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)

gcc/testsuite/ChangeLog

+2016-09-22  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.dg/dtio_11.f90: Correct for changed error messages.
+	* gfortran.dg/dtio_13.f90: New test.
+
 2016-09-21  Louis Krupp  <louis.krupp@zoho.com>
 
 	PR fortran/66107

gcc/testsuite/gfortran.dg/dtio_11.f90

@@ -25,7 +25,7 @@ contains
    end
 end
 
-! PR77533 comment #1 - gave warning that
+! PR77533 comment #1 - gave error 'KIND = 0'
 module m3
    type t
    contains
@@ -33,7 +33,20 @@ module m3
       generic :: write(formatted) => s
    end type
 contains
-   subroutine s(x) ! { dg-error "must be of type CLASS" }
+   subroutine s(x) ! { dg-error "Too few dummy arguments" }
       class(t), intent(in) : x ! { dg-error "Invalid character in name" }
    end
 end
+
+! PR77534
+module m4
+   type t
+   end type
+   interface read(unformatted)
+      module procedure s
+   end interface
+contains
+   subroutine s(dtv) ! { dg-error "Too few dummy arguments" }
+      type(t), intent(inout) :: dtv
+   end
+end

gcc/testsuite/gfortran.dg/dtio_13.f90

+! { dg-do compile }
+! { dg-options -std=legacy }
+!
+! Test elimination of various segfaults and ICEs on error recovery.
+!
+! Contributed by Gerhard Steinmetz  <gerhard.steinmetz.fortran@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
+