[gfortran] Patch for PR 14901 Internal writes do not pad with blanks

[Bud Davis]

Items not filled with format data items where filled with '\n', plus a
'\n' was being written at the end of the transfer.


Here are 2 reported examples of this problem, with the output shown
after applying this patch:


subroutine x (a)
  implicit none
  character(*) a
  print *,len(a),"[",a,"]"
end subroutine x
  
character s*10
write (s, '("hello")')
call x (trim(s))
write (s, '("hello     ")')
call x (trim(s))
end program
$ gfc xx.f90
$ ./a.out
           5 [hello]
           5 [hello]


and the second:


program z
   implicit none
   character(len=20) fmt1, fmt2
   write(fmt1,'(A)') '(ES12.4)'
   fmt2 = '(I12.4)'
   print*,fmt1
   print *,'fmt1 = ', trim(fmt1), len_trim(fmt1)
   print *,'fmt2 = ', trim(fmt2), len_trim(fmt2)
   print *,'fmt1//fmt2 = ', trim(fmt1//fmt2), len_trim(fmt1//fmt2)
end program z
$ gfc x.f90
$ ./a.out
(ES12.4)
fmt1 = (ES12.4)            8
fmt2 = (I12.4)            7
fmt1//fmt2 = (ES12.4)            (I12.4)           27

tested on i686/gnu/linux with no additional test suite failures.  



regards,
bud davis



Index: gcc/gcc/testsuite/ChangeLog.tree-ssa
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/Attic/ChangeLog.tree-ssa,v
retrieving revision 1.1.2.218
diff -c -3 -p -r1.1.2.218 ChangeLog.tree-ssa
*** gcc/gcc/testsuite/ChangeLog.tree-ssa        8 Apr 2004 15:02:47 -0000       1.1.2.218
--- gcc/gcc/testsuite/ChangeLog.tree-ssa        10 Apr 2004 02:18:45 -0000
***************
*** 1,3 ****
--- 1,8 ----
+ 2004-04-09  Bud Davis  <bdavis9659@comcast.net>
+
+       PR gfortran/14901
+       * gfortran.fortran-torture/execute/internal_write.f90 : New test.
+
  2004-04-08  Brian Booth  <bbooth@redhat.com>
                                                                                            
        * gcc.dg/tree-ssa/20040408-1.c: New test.
Index: gcc/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90
===================================================================
RCS file: gcc/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90
diff -N gcc/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90
*** /dev/null   1 Jan 1970 00:00:00 -0000
--- gcc/gcc/testsuite/gfortran.fortran-torture/execute/internal_write.f90       10 Apr 2004 02:18:54 -0000
***************
*** 0 ****
--- 1,11 ----
+ ! PR 14901
+ ! Internal writes were appending CR after the last char
+ ! written by the format statement.
+        CHARACTER*10 A
+        WRITE(A,'(3HGCC)')
+        IF (A.NE.'GCC       ') THEN
+           PRINT*,'A was not filled correctly by internal write'
+           PRINT*,' A = ',A
+           CALL ABORT
+        ENDIF
+        END
Index: gcc/libgfortran/ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/Attic/ChangeLog,v
retrieving revision 1.1.2.41
diff -c -3 -p -r1.1.2.41 ChangeLog
*** gcc/libgfortran/ChangeLog   4 Apr 2004 03:06:56 -0000       1.1.2.41
--- gcc/libgfortran/ChangeLog   10 Apr 2004 02:18:55 -0000
***************
*** 1,3 ****
--- 1,9 ----
+ 2004-04-09  Bud Davis  <bdavis9659@comcast.net>
+
+       PR gfortran/14901
+       * io/transfer.c (next_record_w) : No '\n' if internal.
+       * io/unix.c (empty_internal_buffer) : Init to spaces, not '\n'.
+
  2004-04-03  Bud Davis  <bdavis9659@comcast.net>
   
        PR gfortran/14762
Index: gcc/libgfortran/io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/Attic/transfer.c,v
retrieving revision 1.1.2.12
diff -c -3 -p -r1.1.2.12 transfer.c
*** gcc/libgfortran/io/transfer.c       4 Apr 2004 03:06:57 -0000       1.1.2.12
--- gcc/libgfortran/io/transfer.c       10 Apr 2004 02:18:55 -0000
*************** next_record_w (int done)
*** 1258,1270 ****
        length = 1;
        p = salloc_w (current_unit->s, &length);
   
!       if (!(is_internal_unit()) && p == NULL)
          {
!            goto io_error;
          }
-
-       if (p != NULL)
-          *p = '\n';
   
        if (sfree (current_unit->s) == FAILURE)
        goto io_error;
--- 1258,1270 ----
        length = 1;
        p = salloc_w (current_unit->s, &length);
   
!       if (!is_internal_unit())
          {
!           if (p)
!             *p = '\n'; /* no CR for internal writes */
!           else
!             goto io_error;
          }
   
        if (sfree (current_unit->s) == FAILURE)
        goto io_error;
Index: gcc/libgfortran/io/unix.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/Attic/unix.c,v
retrieving revision 1.1.2.5
diff -c -3 -p -r1.1.2.5 unix.c
*** gcc/libgfortran/io/unix.c   4 Apr 2004 00:17:19 -0000       1.1.2.5
--- gcc/libgfortran/io/unix.c   10 Apr 2004 02:18:55 -0000
*************** void
*** 808,814 ****
  empty_internal_buffer(stream *strm)
  {
     unix_stream * s = (unix_stream *) strm;
!    memset(s->buffer, '\n', s->file_length);
  }
   
  /* open_internal()-- Returns a stream structure from an internal file */
--- 808,814 ----
  empty_internal_buffer(stream *strm)
  {
     unix_stream * s = (unix_stream *) strm;
!    memset(s->buffer, ' ', s->file_length);
  }
   
  /* open_internal()-- Returns a stream structure from an internal file */