Dear All,
The fix for the original bug is tested in dtio_24.f90. It is triggered
by the PRIVATE statement in the module and occurs because there is no
such generic interface in the module. Note, however, that there is a
typebound generic interface, which should not be affected by the
PRIVATE statement. The fix looks for the interface and issues an error
if it is not present.
It was found that the absence of a DTIO procedure in a formatted
transfer, where a DT descriptor is present, caused a segfault. The fix
in transfer.c was to check if a reference to the DTIO procedure is
present and to issue an error if it is not. Unfortunately, since
trans-io.c transfers the components of derived types, in the absence
of a DTIO procedure, this negates the type check and requires that the
test in dtio_10.f90 be changed. I think that it would be a good idea
in the future to flag passing of components so that the type test can
be recovered. For this reason, I have left the calls in place.
Bootstrapped and regtested on FC23/x86_64 - OK for trunk and 6-branch?
I am building up a backlog of approved patches: Including this one (if
approved :-) ), PRs79402, 79434 & 79447. Would it be OK to commit
these to trunk, even though it is in stage 4?
Paul
2017-02-16 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/79382
* decl.c (access_attr_decl): Test for presence of generic DTIO
interface and emit error if not present.
(gfc_match_end): Catch case where a procedure is contained in
a module procedure and ensure that 'end procedure' is the
correct termination.
2017-02-16 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/79382
* io/transfer.c (check_dtio_proc): New function.
(formatted_transfer_scalar_read): Use it.
(formatted_transfer_scalar_write): ditto.
2017-02-16 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/79382
* gfortran.dg/dtio_10.f90 : Change test of error message.
* gfortran.dg/dtio_23.f90 : New test.
* gfortran.dg/dtio_24.f90 : New test.
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 245196)
--- gcc/fortran/decl.c (working copy)
*************** gfc_set_constant_character_len (int len,
*** 1499,1505 ****
if (expr->ts.type != BT_CHARACTER)
return;
!
if (expr->expr_type != EXPR_CONSTANT)
{
gfc_error_now ("CHARACTER length must be a constant at %L",
&expr->where);
--- 1499,1505 ----
if (expr->ts.type != BT_CHARACTER)
return;
!
if (expr->expr_type != EXPR_CONSTANT)
{
gfc_error_now ("CHARACTER length must be a constant at %L",
&expr->where);
*************** access_attr_decl (gfc_statement st)
*** 7566,7571 ****
--- 7566,7586 ----
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
+
+ if (type == INTERFACE_DTIO
+ && gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_find_symbol (name, gfc_current_ns, 0, &sym);
+ if (sym == NULL)
+ {
+ gfc_error ("The GENERIC DTIO INTERFACE at %C is not "
+ "present in the MODULE '%s'",
+ gfc_current_ns->proc_name->name);
+ return MATCH_ERROR;
+ }
+ }
+
if (gfc_get_symbol (name, NULL, &sym))
goto done;
Index: libgfortran/io/transfer.c
===================================================================
*** libgfortran/io/transfer.c (revision 245196)
--- libgfortran/io/transfer.c (working copy)
*************** require_type (st_parameter_dt *dtp, bt e
*** 1244,1249 ****
--- 1244,1269 ----
}
+ /* Check that the dtio procedure required for formatted IO is present. */
+
+ static int
+ check_dtio_proc (st_parameter_dt *dtp, const fnode *f)
+ {
+ char buffer[BUFLEN];
+
+ if (dtp->u.p.fdtio_ptr != NULL)
+ return 0;
+
+ snprintf (buffer, BUFLEN,
+ "Missing DTIO procedure or intrinsic type passed for item %d "
+ "in formatted transfer",
+ dtp->u.p.item_count - 1);
+
+ format_error (dtp, f, buffer);
+ return 1;
+ }
+
+
static int
require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
{
*************** formatted_transfer_scalar_read (st_param
*** 1436,1441 ****
--- 1456,1464 ----
case FMT_DT:
if (n == 0)
goto need_read_data;
+
+ if (check_dtio_proc (dtp, f))
+ return;
if (require_type (dtp, BT_CLASS, type, f))
return;
int unit = dtp->u.p.current_unit->unit_number;
*************** formatted_transfer_scalar_write (st_para
*** 1938,1945 ****
--- 1961,1972 ----
child_iomsg_len = IOMSG_LEN;
}
+ if (check_dtio_proc (dtp, f))
+ return;
+
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
+
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
Index: gcc/testsuite/gfortran.dg/dtio_10.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_10.f90 (revision 245196)
--- gcc/testsuite/gfortran.dg/dtio_10.f90 (working copy)
*************** program test1
*** 23,27 ****
read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
& iomsg=errormsg) i, udt1
if (ios.ne.5006) call abort
! if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
end program test1
--- 23,27 ----
read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
& iomsg=errormsg) i, udt1
if (ios.ne.5006) call abort
! if (errormsg(27:47).ne."intrinsic type passed") call abort
end program test1
Index: gcc/testsuite/gfortran.dg/dtio_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_23.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/dtio_23.f90 (working copy)
***************
*** 0 ****
--- 1,37 ----
+ ! { dg-do compile }
+ !
+ ! Test fix for the original in PR79832.
+ !
+ ! Contributed by Walt Brainerd <walt.brain...@gmail.com>
+ !
+ module dollar_mod
+
+ implicit none
+ private
+
+ type, public :: dollar_type
+ real :: amount
+ contains
+ procedure :: Write_dollar
+ generic :: write(formatted) => Write_dollar
+ end type dollar_type
+
+ PRIVATE :: write (formatted) ! { dg-error "is not present" }
+
+ contains
+
+ subroutine Write_dollar &
+
+ (dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg)
+
+ class (dollar_type), intent(in) :: dollar_value
+ integer, intent(in) :: unit
+ character (len=*), intent(in) :: b_edit_descriptor
+ integer, dimension(:), intent(in) :: v_list
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount
+
+ end subroutine Write_dollar
+
+ end module dollar_mod
Index: gcc/testsuite/gfortran.dg/dtio_24.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_24.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/dtio_24.f90 (working copy)
***************
*** 0 ****
--- 1,51 ----
+ ! { dg-do run }
+ !
+ ! Test fix for the additional bug that was found in fixing PR79832.
+ !
+ ! Contributed by Walt Brainerd <walt.brain...@gmail.com>
+ !
+ module dollar_mod
+
+ implicit none
+ private
+
+ type, public :: dollar_type
+ real :: amount
+ end type dollar_type
+
+ interface write(formatted)
+ module procedure Write_dollar
+ end interface
+
+ private :: write (formatted)
+
+ contains
+
+ subroutine Write_dollar &
+
+ (dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg)
+
+ class (dollar_type), intent(in) :: dollar_value
+ integer, intent(in) :: unit
+ character (len=*), intent(in) :: b_edit_descriptor
+ integer, dimension(:), intent(in) :: v_list
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount
+
+ end subroutine Write_dollar
+
+ end module dollar_mod
+
+ program test_dollar
+
+ use :: dollar_mod
+ implicit none
+ integer :: ios
+ character(100) :: errormsg
+
+ type (dollar_type), parameter :: wage = dollar_type(15.10)
+ write (unit=*, fmt="(DT)", iostat=ios, iomsg=errormsg) wage
+ if (ios.ne.5006) call abort
+ if (errormsg(1:22).ne."Missing DTIO procedure") call abort
+ end program test_dollar
