OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/78670 ([F03] Incorrect file position with namelist read under DTIO)

Browse Source 
2017-03-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/78670
	* io/list_read.c (nml_get_obj_data): Delete code which calls the
	child read procedure. (nml_read_obj): Insert the code which
	calls the child procedure. Don't need to touch nodes if using
	dtio since parent will not be traversing the components.

	PR libgfortran/78670
	* gfortran.dg/dtio_25.f90: Use 'a1' format when trying to read
	a character of length 1. Update test for success.
	* gfortran.dg/dtio_28.f03: New test.
	* gfortran.dg/dtio_4.f90: Update to open test file with status =
	'scratch' to delete the file when done.

From-SVN: r246576
This commit is contained in:
Jerry DeLisle 2017-03-29 21:37:45 +00:00
parent 533c0b6943
commit fdc54f39c1
6 changed files with 152 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2017-03-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/78670
* gfortran.dg/dtio_25.f90: Use 'a1' format when trying to read
a character of length 1. Update test for success.
* gfortran.dg/dtio_28.f03: New test.
* gfortran.dg/dtio_4.f90: Update to open test file with status =
'scratch' to delete the file when done.
2017-03-29 Segher Boessenkool <segher@kernel.crashing.org>
PR rtl-optimization/80233

6
gcc/testsuite/gfortran.dg/dtio_25.f90
View File

@ -20,7 +20,7 @@ contains
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
if (iotype.eq."NAMELIST") then
write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k
write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k
else
write (unit,*) dtv%c, dtv%k
end if
@ -34,7 +34,7 @@ contains
character(*), intent(inout) :: iomsg
character :: comma
if (iotype.eq."NAMELIST") then
read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k ! FIXME: need a4 here, with a3 above
read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k
else
read (unit,*) dtv%c, comma, dtv%k
end if
@ -50,7 +50,7 @@ program p
namelist /nml/ x
x = t('a', 5)
write (buffer, nml)
if (buffer.ne.'&NML X= a, 5 /') call abort
if (buffer.ne.'&NML X=a, 5 /') call abort
x = t('x', 0)
read (buffer, nml)
if (x%c.ne.'a'.or. x%k.ne.5) call abort

74
gcc/testsuite/gfortran.dg/dtio_28.f03 Normal file
View File

@ -0,0 +1,74 @@
! { dg-do run }
! PR78670 Incorrect file position with namelist read under DTIO
MODULE m
IMPLICIT NONE
TYPE :: t
CHARACTER :: c
CONTAINS
PROCEDURE :: read_formatted
GENERIC :: READ(FORMATTED) => read_formatted
PROCEDURE :: write_formatted
GENERIC :: WRITE(FORMATTED) => write_formatted
END TYPE t
CONTAINS
SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
CLASS(t), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER(*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: v_list(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER(*), INTENT(INOUT) :: iomsg
write(unit,'(a)', iostat=iostat, iomsg=iomsg) dtv%c
END SUBROUTINE write_formatted
SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
CLASS(t), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER(*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: v_list(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER(*), INTENT(INOUT) :: iomsg
CHARACTER :: ch
dtv%c = ''
DO
READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) ch
IF (iostat /= 0) RETURN
! Store first non-blank
IF (ch /= ' ') THEN
dtv%c = ch
RETURN
END IF
END DO
END SUBROUTINE read_formatted
END MODULE m
PROGRAM p
USE m
IMPLICIT NONE
TYPE(t) :: x
TYPE(t) :: y
TYPE(t) :: z
integer :: j, k
NAMELIST /nml/ j, x, y, z, k
INTEGER :: unit, iostatus
OPEN(NEWUNIT=unit, STATUS='SCRATCH', ACTION='READWRITE')
x%c = 'a'
y%c = 'b'
z%c = 'c'
j=1
k=2
WRITE(unit, nml)
REWIND (unit)
x%c = 'x'
y%c = 'y'
z%c = 'x'
j=99
k=99
READ (unit, nml, iostat=iostatus)
if (iostatus.ne.0) call abort
if (j.ne.1 .or. k.ne.2 .or. x%c.ne.'a' .or. y%c.ne.'b' .or. z%c.ne.'c') call abort
!WRITE(*, nml)
END PROGRAM p

2
gcc/testsuite/gfortran.dg/dtio_4.f90
View File

@ -96,7 +96,7 @@ program test1
if (iomsg.ne.'SUCCESS') call abort
if (any(udt1%myarray.ne.result_array)) call abort
close(10)
open (10, form='formatted')
open (10, form='formatted', status='scratch')
write (10, '(dt)') more1
rewind(10)
more1%myarray = 99

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2017-03-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/78670
* io/list_read.c (nml_get_obj_data): Delete code which calls the
child read procedure. (nml_read_obj): Insert the code which
calls the child procedure. Don't need to touch nodes if using
dtio since parent will not be traversing the components.
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661

110
libgfortran/io/list_read.c
View File

@ -2958,6 +2958,61 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info * nl, index_type offset,
break;
case BT_DERIVED:
/* If this object has a User Defined procedure, call it. */
if (nl->dtio_sub != NULL)
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "NAMELIST";
gfc_charlen_type iotype_len = 8;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
list_obj.data = (void *)nl->mem_pos;
list_obj.vptr = nl->vtable;
list_obj.len = 0;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* If reading from an internal unit, stash it to allow
the child procedure to access it. */
if (is_internal_unit (dtp))
stash_internal_unit (dtp);
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.child_saved_iostat = *child_iostat;
dtp->u.p.current_unit->child_dtio--;
goto incr_idx;
}
/* Must be default derived type namelist read. */
obj_name_len = strlen (nl->var_name) + 1;
obj_name = xmalloc (obj_name_len+1);
memcpy (obj_name, nl->var_name, obj_name_len-1);
@ -3268,58 +3323,6 @@ get_name:
goto nml_err_ret;
}
else if (nl->dtio_sub != NULL)
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "NAMELIST";
gfc_charlen_type iotype_len = 8;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
list_obj.data = (void *)nl->mem_pos;
list_obj.vptr = nl->vtable;
list_obj.len = 0;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* If reading from an internal unit, stash it to allow
the child procedure to access it. */
if (is_internal_unit (dtp))
stash_internal_unit (dtp);
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return true;
}
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */
@ -3466,11 +3469,12 @@ get_name:
nl->var_name);
goto nml_err_ret;
}
/* If a derived type, touch its components and restore the root
namelist_info if we have parsed a qualified derived type
component. */
if (nl->type == BT_DERIVED)
if (nl->type == BT_DERIVED && nl->dtio_sub == NULL)
nml_touch_nodes (nl);
if (first_nl)