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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 971c34838148342c8b75f742324827929ed0222a..9f146aa73879ab05a536cc636355de165bf4e134 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+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

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f8a4edb9b6249c45ecc46a621ae7ecc82eeb913b..09f5a539e7c4c2a8f0093e135b511837a40639bf 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index e6480d85374b3f086cc5b3dc262075c6c5e85602..c354612164c109c72b39451116a3149f1bb796b7 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+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

diff --git a/gcc/testsuite/gfortran.dg/dtio_11.f90 b/gcc/testsuite/gfortran.dg/dtio_11.f90
index cf8dd365d3c000a8c312962407cc2c4e8a0700e9..1f148c3b8960116e7dec42cde6aca39f22344d58 100644 (file)
--- a/gcc/testsuite/gfortran.dg/dtio_11.f90
+++ b/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

diff --git a/gcc/testsuite/gfortran.dg/dtio_13.f90 b/gcc/testsuite/gfortran.dg/dtio_13.f90
new file mode 100644 (file)
index 0000000..9b90720
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_13.f90
@@ -0,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.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
+