FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/48298 ([F03] User-Defined Derived-Type IO (DTIO))

Browse source 
2016-10-17  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/48298
	* io/io.h: Move size_used from dtp to unit structure. Add bool
	has_size to unit structure.
	* read.c (read_x): Use has_size and size_used.
	* transfer.c (read_sf_internal,read_sf,read_block_form,
	read_block_form4): Likewise.
	(data_transfer_init): If parent, initialize the size variables.
	(finalize_transfer): Set the size variable using size_used in
	gfc_unit. (write_block): Delete bogus/dead code.

	* gfortran.dg/dtio_17.f90: New test.

From-SVN: r241294
This commit is contained in:
Jerry DeLisle 2016-10-18 04:14:25 +00:00
parent b78027d1a3
commit c680ada5f5
6 changed files with 126 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,7 @@
2016-10-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* gfortran.dg/dtio_17.f90: New test.
2016-10-18 Kugan Vivekanandarajah <kuganv@linaro.org>
* gcc.dg/ipa/vrp4.c: Adjust testcase.

77
gcc/testsuite/gfortran.dg/dtio_17.f90 Normal file
View file

@ -0,0 +1,77 @@
! { dg-do run }
! PR48298, this tests function of size= specifier with DTIO.
MODULE p
USE ISO_FORTRAN_ENV
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
CONTAINS
procedure :: pwf
procedure :: prf
GENERIC :: WRITE(FORMATTED) => pwf
GENERIC :: READ(FORMATTED) => prf
END TYPE person
CONTAINS
SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), 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
CHARACTER (LEN=30) :: udfmt
INTEGER :: myios
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
if (iotype.eq."LISTDIRECTED") then
WRITE(unit, '(*(g0))', IOSTAT=iostat) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
END SUBROUTINE pwf
SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), 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
CHARACTER (LEN=30) :: udfmt
INTEGER :: myios
real :: areal
udfmt='(*(g0))'
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
READ(unit, FMT = '(a20,i2)', IOSTAT=iostat) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
END SUBROUTINE prf
END MODULE p
PROGRAM test
USE p
implicit none
TYPE (person) :: chairman
integer(4) :: rl, tl, kl, thesize
chairman%name="Charlie"
chairman%age=62
open(28, status='scratch')
write(28, '(i10,i10,DT,i15,DT,i12)') rl, kl, chairman, rl, chairman, tl
rewind(28)
chairman%name="bogus"
chairman%age=99
!print *, chairman
read(28, '(i10,i10,DT,i15,DT,i12)', advance='no', size=thesize) rl, &
& kl, chairman, rl, chairman, tl
if (thesize.ne.91) call abort
close(28)
END PROGRAM test

12
libgfortran/ChangeLog
View file

@ -1,3 +1,15 @@
2016-10-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298
* io/io.h: Move size_used from dtp to unit structure. Add bool
has_size to unit structure.
* read.c (read_x): Use has_size and size_used.
* transfer.c (read_sf_internal,read_sf,read_block_form,
read_block_form4): Likewise.
(data_transfer_init): If parent, initialize the size variables.
(finalize_transfer): Set the size variable using size_used in
gfc_unit. (write_block): Delete bogus/dead code.
2016-10-16 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/48587

3
libgfortran/io/io.h
View file

@ -514,7 +514,6 @@ typedef struct st_parameter_dt
large enough to hold a complex value (two reals) of the
largest kind. */
char value[32];
GFC_IO_INT size_used;
formatted_dtio fdtio_ptr;
unformatted_dtio ufdtio_ptr;
} p;
@ -650,6 +649,8 @@ typedef struct gfc_unit
/* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
int child_dtio;
int last_char;
bool has_size;
GFC_IO_INT size_used;
}
gfc_unit;

5
libgfortran/io/read.c
View file

@ -1282,8 +1282,9 @@ read_x (st_parameter_dt *dtp, int n)
}
done:
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) n;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
dtp->u.p.current_unit->bytes_left -= n;
dtp->u.p.current_unit->strm_pos += (gfc_offset) n;
}

42
libgfortran/io/transfer.c
View file

@ -267,8 +267,9 @@ read_sf_internal (st_parameter_dt *dtp, int * length)
dtp->u.p.current_unit->bytes_left -= *length;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) *length;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length;
return base;
@ -397,8 +398,9 @@ read_sf (st_parameter_dt *dtp, int * length)
dtp->u.p.current_unit->bytes_left -= n;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) n;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
/* We can't call fbuf_getptr before the loop doing fbuf_getc, because
fbuf_getc might reallocate the buffer. So return current pointer
@ -478,8 +480,9 @@ read_block_form (st_parameter_dt *dtp, int * nbytes)
source = fbuf_read (dtp->u.p.current_unit, nbytes);
fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
if (norig != *nbytes)
{
@ -536,8 +539,9 @@ read_block_form4 (st_parameter_dt *dtp, int * nbytes)
dtp->u.p.current_unit->bytes_left -= *nbytes;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) *nbytes;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
return source;
}
@ -770,8 +774,9 @@ write_block (st_parameter_dt *dtp, int length)
}
}
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
dtp->u.p.current_unit->has_size)
dtp->u.p.current_unit->size_used += (GFC_IO_INT) length;
dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
@ -2596,9 +2601,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used = 0; /* Initialize the count. */
dtp->u.p.current_unit = get_unit (dtp, 1);
if (dtp->u.p.current_unit == NULL)
@ -2674,6 +2676,18 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
if (dtp->u.p.current_unit->child_dtio == 0)
{
if ((cf & IOPARM_DT_HAS_SIZE) != 0)
{
dtp->u.p.current_unit->has_size = true;
/* Initialize the count. */
dtp->u.p.current_unit->size_used = 0;
}
else
dtp->u.p.current_unit->has_size = false;
}
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@ -3772,7 +3786,7 @@ finalize_transfer (st_parameter_dt *dtp)
return;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
*dtp->size = dtp->u.p.size_used;
*dtp->size = dtp->u.p.current_unit->size_used;
if (dtp->u.p.eor_condition)
{