Re: [libgfortran, patch] PR25545 internal file and dollar edit descriptor

[Jerry DeLisle <jvdelisle at verizon dot net>]

:ADDPATCH fortran:

Forgot the add patch and here is a correct test case.  I was testing the 
testsuite and had the previous version failing deliberately.

2006-11-04  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR libgfortran/25545
	* io/transfer.c (write_block): Cleanup code paths between
	stream and non-stream I/O.
	(write_buf):  Cleanup.
	(read_block): Cleanup.
	(finalize_transfer): Call next_record for '$' edit descriptor handling
	of internal unit. Cleanup code for readability.

c     { dg-do run }
c     PR25545 internal file and dollar edit descriptor.
      program main
      character*20 line
      line = '1234567890ABCDEFGHIJ'
      write (line, '(A$)') 'asdf'
      if (line.ne.'asdf') call abort()
      end

Index: transfer.c
===================================================================
*** transfer.c	(revision 118461)
--- transfer.c	(working copy)
*************** read_block (st_parameter_dt *dtp, int *l
*** 263,269 ****
    char *source;
    int nread;
  
!   if (!is_stream_io (dtp))
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
  	{
--- 263,278 ----
    char *source;
    int nread;
  
!   if (is_stream_io (dtp))
!     {
!       if (sseek (dtp->u.p.current_unit->s,
! 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
! 	{
! 	  generate_error (&dtp->common, ERROR_END, NULL);
! 	  return NULL;
! 	}
!     }
!   else
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
  	{
*************** read_block (st_parameter_dt *dtp, int *l
*** 291,355 ****
  
  	  *length = dtp->u.p.current_unit->bytes_left;
  	}
  
!       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
! 	dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
! 	  return read_sf (dtp, length, 0);	/* Special case.  */
! 
!       dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
! 
!       nread = *length;
!       source = salloc_r (dtp->u.p.current_unit->s, &nread);
! 
!       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! 	dtp->u.p.size_used += (gfc_offset) nread;
! 
!       if (nread != *length)
! 	{				/* Short read, this shouldn't happen.  */
! 	  if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! 	    *length = nread;
! 	  else
! 	    {
! 	      generate_error (&dtp->common, ERROR_EOR, NULL);
! 	      source = NULL;
! 	    }
! 	}
      }
!   else
!     {
!       if (sseek (dtp->u.p.current_unit->s,
! 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
! 	{
! 	  generate_error (&dtp->common, ERROR_END, NULL);
! 	  return NULL;
! 	}
  
!       if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
  	{
! 	  source = read_sf (dtp, length, 0);
! 	  dtp->u.p.current_unit->strm_pos +=
! 	    (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
! 	  return source;
! 	}
!       nread = *length;
!       source = salloc_r (dtp->u.p.current_unit->s, &nread);
! 
!       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
! 	dtp->u.p.size_used += (gfc_offset) nread;
! 
!       if (nread != *length)
! 	{				/* Short read, this shouldn't happen.  */
! 	  if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! 	    *length = nread;
! 	  else
! 	    {
! 	      generate_error (&dtp->common, ERROR_END, NULL);
! 	      source = NULL;
! 	    }
  	}
- 
-       dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
      }
    return source;
  }
  
--- 300,337 ----
  
  	  *length = dtp->u.p.current_unit->bytes_left;
  	}
+     }
  
!   if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
!       (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
!        dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
!     {
!       source = read_sf (dtp, length, 0);
!       dtp->u.p.current_unit->strm_pos +=
! 	(gfc_offset) (*length + dtp->u.p.sf_seen_eor);
!       return source;
      }
!   dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
  
!   nread = *length;
!   source = salloc_r (dtp->u.p.current_unit->s, &nread);
! 
!   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
!     dtp->u.p.size_used += (gfc_offset) nread;
! 
!   if (nread != *length)
!     {				/* Short read, this shouldn't happen.  */
!       if (dtp->u.p.current_unit->flags.pad == PAD_YES)
! 	*length = nread;
!       else
  	{
! 	  generate_error (&dtp->common, ERROR_EOR, NULL);
! 	  source = NULL;
  	}
      }
+ 
+   dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
+ 
    return source;
  }
  
*************** write_block (st_parameter_dt *dtp, int l
*** 440,446 ****
  {
    char *dest;
  
!   if (!is_stream_io (dtp))
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
  	{
--- 422,437 ----
  {
    char *dest;
  
!   if (is_stream_io (dtp))
!     {
!       if (sseek (dtp->u.p.current_unit->s,
! 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
! 	{
! 	  generate_error (&dtp->common, ERROR_OS, NULL);
! 	  return NULL;
! 	}
!     }
!   else
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
  	{
*************** write_block (st_parameter_dt *dtp, int l
*** 458,498 ****
  	}
  
        dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
  
  
!       dest = salloc_w (dtp->u.p.current_unit->s, &length);
!   
!       if (dest == NULL)
! 	{
! 	  generate_error (&dtp->common, ERROR_END, NULL);
! 	  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;
!     }
!   else
      {
!       if (sseek (dtp->u.p.current_unit->s,
! 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
! 	{
! 	  generate_error (&dtp->common, ERROR_OS, NULL);
! 	  return NULL;
! 	}
  
!       dest = salloc_w (dtp->u.p.current_unit->s, &length);
  
!       if (dest == NULL)
! 	{
! 	  generate_error (&dtp->common, ERROR_END, NULL);
! 	  return NULL;
! 	}
  
!       dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
!     }
  
    return dest;
  }
--- 449,471 ----
  	}
  
        dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
+     }
  
+   dest = salloc_w (dtp->u.p.current_unit->s, &length);
  
!   if (dest == NULL)
      {
!       generate_error (&dtp->common, ERROR_END, NULL);
!       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;
  
!   dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
  
    return dest;
  }
*************** write_block (st_parameter_dt *dtp, int l
*** 503,509 ****
  static try
  write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
  {
!   if (!is_stream_io (dtp))
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
  	{
--- 476,491 ----
  static try
  write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
  {
!   if (is_stream_io (dtp))
!     {
!       if (sseek (dtp->u.p.current_unit->s,
! 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
! 	{
! 	  generate_error (&dtp->common, ERROR_OS, NULL);
! 	  return FAILURE;
! 	}
!     }
!   else
      {
        if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
  	{
*************** write_buf (st_parameter_dt *dtp, void *b
*** 526,540 ****
  
        dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
      }
-   else
-     {
-       if (sseek (dtp->u.p.current_unit->s,
- 		 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
- 	{
- 	  generate_error (&dtp->common, ERROR_OS, NULL);
- 	  return FAILURE;
- 	}
-     }
  
    if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
      {
--- 508,513 ----
*************** write_buf (st_parameter_dt *dtp, void *b
*** 542,554 ****
        return FAILURE;
      }
  
!   if (!is_stream_io (dtp))
!     {
!       if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
  	dtp->u.p.size_used += (gfc_offset) nbytes;
!     }
!   else
!     dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; 
  
    return SUCCESS;
  }
--- 515,524 ----
        return FAILURE;
      }
  
!   if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
  	dtp->u.p.size_used += (gfc_offset) nbytes;
! 
!   dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes; 
  
    return SUCCESS;
  }
*************** next_record_w (st_parameter_dt *dtp, int
*** 2244,2250 ****
  		  else
  		    length = (int) dtp->u.p.current_unit->bytes_left;
  		}
! 	      if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_END, NULL);
  		  return;
--- 2214,2221 ----
  		  else
  		    length = (int) dtp->u.p.current_unit->bytes_left;
  		}
! 
! 	if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
  		{
  		  generate_error (&dtp->common, ERROR_END, NULL);
  		  return;
*************** finalize_transfer (st_parameter_dt *dtp)
*** 2371,2398 ****
      }
  
    if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
-     finish_list_read (dtp);
-   else if (!is_stream_io (dtp))
      {
!       dtp->u.p.current_unit->current_record = 0;
!       if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
! 	{
! 	  /* Most systems buffer lines, so force the partial record
! 	     to be written out.  */
! 	  if (!is_internal_unit (dtp))
! 	    flush (dtp->u.p.current_unit->s);
! 	  dtp->u.p.seen_dollar = 0;
! 	  return;
! 	}
!       next_record (dtp, 1);
      }
!   else
      {
        if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
  	next_record (dtp, 1);
        flush (dtp->u.p.current_unit->s);
      }
  
    sfree (dtp->u.p.current_unit->s);
  }
  
--- 2342,2375 ----
      }
  
    if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
      {
!       finish_list_read (dtp);
!       sfree (dtp->u.p.current_unit->s);
!       return;
      }
! 
!   if (is_stream_io (dtp))
      {
        if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
  	next_record (dtp, 1);
        flush (dtp->u.p.current_unit->s);
+       sfree (dtp->u.p.current_unit->s);
+       return;
+     }
+ 
+   dtp->u.p.current_unit->current_record = 0;
+ 
+   if (dtp->u.p.advance_status == ADVANCE_NO)
+     return;
+ 
+   if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
+     {
+       dtp->u.p.seen_dollar = 0;
+       sfree (dtp->u.p.current_unit->s);
+       return;
      }
  
+   next_record (dtp, 1);
    sfree (dtp->u.p.current_unit->s);
  }