From a8de3002f19eb09cf95d36f1a97e30f234df7d9e Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 22 Sep 2016 07:46:07 +0000 Subject: [PATCH] interface.c (check_dtio_interface1): Introduce errors for alternate returns and incorrect numbers of arguments. 2016-09-22 Paul Thomas * 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 * gfortran.dg/dtio_11.f90: Correct for changed error messages. * gfortran.dg/dtio_13.f90: New test. From-SVN: r240342 --- gcc/fortran/ChangeLog | 7 ++ gcc/fortran/interface.c | 40 ++++++- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/dtio_11.f90 | 17 ++- gcc/testsuite/gfortran.dg/dtio_13.f90 | 144 ++++++++++++++++++++++++++ 5 files changed, 209 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/dtio_13.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 971c3483814..9f146aa7387 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2016-09-22 Paul Thomas + + * 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 PR fortran/66107 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index f8a4edb9b62..09f5a539e7c 100644 --- 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 e6480d85374..c354612164c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-09-22 Paul Thomas + + * gfortran.dg/dtio_11.f90: Correct for changed error messages. + * gfortran.dg/dtio_13.f90: New test. + 2016-09-21 Louis Krupp PR fortran/66107 diff --git a/gcc/testsuite/gfortran.dg/dtio_11.f90 b/gcc/testsuite/gfortran.dg/dtio_11.f90 index cf8dd365d3c..1f148c3b896 100644 --- 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 index 00000000000..9b907201afc --- /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 +! +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 + -- 2.30.2