[patch,libgfortran] PR28339 gfortran misses a record from a format statement

[Jerry DeLisle <jvdelisle at verizon dot net>]

:ADDPATCH fortran:

This problem actually has nothing to do with format statements.  In fact, I 
could reproduce this with:

  character*8   rec(3)
  write(rec,'(a)') "12345678",/,"record1",/,"records3"

In next_record_w we (I) failed to advance to the next record when the entire 
first record was filled.  This caused the second record to be written twice, 
making it look like "record2" was missing.

To correct this it is necessary to complete next_record_w but not generate an 
ERROR_END until later.  if an attempt is made to write again to the internal 
unit (character array) after the last record is reached, an error is generated.

I used the existing endfile enumerator to accomplish this. I verified that we 
still get an ERROR_END on a scaler string.

Bootstrapped and Regression tested.  NIST tested.

OK for 4.2 trunk?  New test case attached.

Regards,

Jerry


2006-07-19  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/28339
	* io/transfer.c (next_record_w): Use next_array_record result to set
	END_FILE. (write_block): Test for END_FILE before the next write occurs.
	* io/init.c (get_internal_unit): Initialize iunit->endfile for internal
	unit.


Index: io/transfer.c
===================================================================
*** io/transfer.c	(revision 115605)
--- io/transfer.c	(working copy)
*************** write_block (st_parameter_dt *dtp, int l
*** 414,419 ****
--- 414,422 ----
        return NULL;
      }
  
+   if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
+     generate_error (&dtp->common, ERROR_END, NULL);
+ 
    if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
      dtp->u.p.size_used += (gfc_offset) length;
  
*************** next_record_w (st_parameter_dt *dtp, int
*** 2052,2060 ****
  
      case FORMATTED_SEQUENTIAL:
  
-       if (dtp->u.p.current_unit->bytes_left == 0)
- 	break;
- 	
        if (is_internal_unit (dtp))
  	{
  	  if (is_array_io (dtp))
--- 2055,2060 ----
*************** next_record_w (st_parameter_dt *dtp, int
*** 2083,2089 ****
  	      /* Now that the current record has been padded out,
  		 determine where the next record in the array is. */
  	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
! 
  	      /* Now seek to this record */
  	      record = record * dtp->u.p.current_unit->recl;
  
--- 2083,2091 ----
  	      /* Now that the current record has been padded out,
  		 determine where the next record in the array is. */
  	      record = next_array_record (dtp, dtp->u.p.current_unit->ls);
! 	      if (record == 0)
! 		dtp->u.p.current_unit->endfile = AT_ENDFILE;
! 	      
  	      /* Now seek to this record */
  	      record = record * dtp->u.p.current_unit->recl;
  
*************** next_record_w (st_parameter_dt *dtp, int
*** 2124,2129 ****
--- 2126,2134 ----
  	}
        else
  	{
+ 	  if (dtp->u.p.current_unit->bytes_left == 0)
+ 	    break;
+ 
  	  /* If this is the last call to next_record move to the farthest
  	  position reached in preparation for completing the record.
  	  (for file unit) */
Index: io/unit.c
===================================================================
*** io/unit.c	(revision 115605)
--- io/unit.c	(working copy)
*************** get_internal_unit (st_parameter_dt *dtp)
*** 420,425 ****
--- 420,426 ----
    iunit->flags.form = FORM_FORMATTED;
    iunit->flags.pad = PAD_YES;
    iunit->flags.status = STATUS_UNSPECIFIED;
+   iunit->endfile = NO_ENDFILE;
  
    /* Initialize the data transfer parameters.  */
  

! { dg-do run }
! PR28339, This test checks that internal unit array I/O handles a full record
! and and advances to th enext record properly.  Test case derived from PR
! Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
      program main
      integer          i
      character*8      rec(3)
      rec = ""
      write (rec,fmt=99999)
      if (rec(1).ne.'12345678') call abort()
      if (rec(2).ne.'record2') call abort()
      if (rec(3).ne.'record3') call abort()
99999 format ('12345678',/'record2',/'record3')
      end