gcc/testsuite/gfortran.dg/advance_6.f90

   1 ! { dg-do run { target fd_truncate } }
   2 ! PR 34370 - file positioning after non-advancing I/O didn't add
   3 ! a record marker.
   4
   5 program main
   6   implicit none
   7   character(len=3) :: c
   8   character(len=80), parameter :: fname = "advance_backspace_1.dat"
   9
  10   call write_file
  11   close (95)
  12   call check_end_record
  13
  14   call write_file
  15   backspace 95
  16   c = 'xxx'
  17   read (95,'(A)') c
  18   if (c /= 'ab ') call abort
  19   close (95)
  20   call check_end_record
  21
  22   call write_file
  23   backspace 95
  24   close (95)
  25   call check_end_record
  26
  27   call write_file
  28   endfile 95
  29   close (95)
  30   call check_end_record
  31
  32   call write_file
  33   endfile 95
  34   rewind 95
  35   c = 'xxx'
  36   read (95,'(A)') c
  37   if (c /= 'ab ') call abort
  38   close (95)
  39   call check_end_record
  40
  41   call write_file
  42   rewind 95
  43   c = 'xxx'
  44   read (95,'(A)') c
  45   if (c /= 'ab ') call abort
  46   close (95)
  47   call check_end_record
  48
  49 contains
  50
  51   subroutine write_file
  52     open(95, file=fname, status="replace", form="formatted")
  53     write (95, '(A)', advance="no") 'a'
  54     write (95, '(A)', advance="no") 'b'
  55   end subroutine write_file
  56
  57 ! Checks for correct end record, then deletes the file.
  58
  59   subroutine check_end_record
  60     character(len=1) :: x
  61     open(2003, file=fname, status="old", access="stream", form="unformatted")
  62     read(2003) x
  63     if (x /= 'a') call abort
  64     read(2003) x
  65     if (x /= 'b') call abort
  66     read(2003) x
  67     if (x /= achar(10)) then
  68        read(2003) x
  69        if (x /= achar(13)) then
  70        else
  71           call abort
  72        end if
  73     end if
  74     close(2003,status="delete")
  75   end subroutine check_end_record
  76 end program main