[patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[Jerry DeLisle]

[-- Attachment #1: Type: text/plain, Size: 1244 bytes --]

Hi all,

The attached patch resolves this problem by moving the code that invokes the 
child I/O procedure into nml_read_obj where it belongs.  This allows the normal 
flow of code that parses the namelist decorations before attempting to read the 
object data.

One new test case is provided. Test case dtio_25.f90 is updated to fix it. One 
minor tweak on dtio_4.f90. (tests are in the patch)

As a followup, I will be testing for arrays of derived types in namelists. If 
any problems there I will open a new PR.

Regression tested on x86-64-linux.

OK for trunk?

Regards,

Jerry

2017-03-28  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  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.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr78670.diff --]
[-- Type: text/x-patch; name="pr78670.diff", Size: 7934 bytes --]

diff --git a/gcc/testsuite/gfortran.dg/dtio_25.f90 b/gcc/testsuite/gfortran.dg/dtio_25.f90
index 6e66a312..a90a238e 100644
--- a/gcc/testsuite/gfortran.dg/dtio_25.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_25.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/dtio_28.f03 b/gcc/testsuite/gfortran.dg/dtio_28.f03
new file mode 100644
index 00000000..c70dc344
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dtio_28.f03
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/dtio_4.f90 b/gcc/testsuite/gfortran.dg/dtio_4.f90
index 5323194a..44352c1b 100644
--- a/gcc/testsuite/gfortran.dg/dtio_4.f90
+++ b/gcc/testsuite/gfortran.dg/dtio_4.f90
@@ -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
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 5514d19e..76eafa80 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -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)

Re: [patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[Jerry DeLisle]

Dominique reports works for him.

I will commit later today if no problems show up.

Jerry
On 03/28/2017 05:59 PM, Jerry DeLisle wrote:
> Hi all,
> 
> The attached patch resolves this problem by moving the code that invokes the
> child I/O procedure into nml_read_obj where it belongs.  This allows the normal
> flow of code that parses the namelist decorations before attempting to read the
> object data.
> 
> One new test case is provided. Test case dtio_25.f90 is updated to fix it. One
> minor tweak on dtio_4.f90. (tests are in the patch)
> 
> As a followup, I will be testing for arrays of derived types in namelists. If
> any problems there I will open a new PR.
> 
> Regression tested on x86-64-linux.
> 
> OK for trunk?
> 
> Regards,
> 
> Jerry
> 
> 2017-03-28  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  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.
> 

Re: [patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[Janus Weil]

Hi Jerry,

looks good. Ok to commit from my side!

However, it seems your patch only handles the case of TYPE variables,
but is not sufficient for reading CLASS variables, right? I guess we
need to take care of that as well, but it can go into a follow-up
patch if you prefer to commit this as is ...

Thanks,
Janus



2017-03-29 19:17 GMT+02:00 Jerry DeLisle <jvdelisle@charter.net>:
> Dominique reports works for him.
>
> I will commit later today if no problems show up.
>
> Jerry
> On 03/28/2017 05:59 PM, Jerry DeLisle wrote:
>> Hi all,
>>
>> The attached patch resolves this problem by moving the code that invokes the
>> child I/O procedure into nml_read_obj where it belongs.  This allows the normal
>> flow of code that parses the namelist decorations before attempting to read the
>> object data.
>>
>> One new test case is provided. Test case dtio_25.f90 is updated to fix it. One
>> minor tweak on dtio_4.f90. (tests are in the patch)
>>
>> As a followup, I will be testing for arrays of derived types in namelists. If
>> any problems there I will open a new PR.
>>
>> Regression tested on x86-64-linux.
>>
>> OK for trunk?
>>
>> Regards,
>>
>> Jerry
>>
>> 2017-03-28  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  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.
>>

Re: [patch, libgfortran] [F03] Incorrect file position with namelist read under DTIO

[Jerry DeLisle]

On 03/29/2017 10:40 AM, Janus Weil wrote:
> Hi Jerry,
> 
> looks good. Ok to commit from my side!
> 
> However, it seems your patch only handles the case of TYPE variables,
> but is not sufficient for reading CLASS variables, right? I guess we
> need to take care of that as well, but it can go into a follow-up
> patch if you prefer to commit this as is ...
> 
> Thanks,
> Janus
> 

We can deal with CLASS as a followup.

	A	gcc/testsuite/gfortran.dg/dtio_28.f03
	M	gcc/testsuite/ChangeLog
	M	gcc/testsuite/gfortran.dg/dtio_25.f90
	M	gcc/testsuite/gfortran.dg/dtio_4.f90
	M	libgfortran/ChangeLog
	M	libgfortran/io/list_read.c
Committed r246576