gcc/testsuite/gfortran.dg/dec_io_2a.f90

   1 ! { dg-do run { target {  *-*-mingw* } } }
   2 ! { dg-options "-fdec" }
   3 !
   4 ! Run-time tests for various carriagecontrol parameters with DEC I/O.
   5 ! Ensures the output is as defined.
   6 !
   7
   8 subroutine write_lines(fd)
   9   implicit none
  10   integer, intent(in) :: fd
  11   write(fd, '(A)') "+ first"
  12   write(fd, '(A)') "-second line"
  13   write(fd, '(A)') "0now you know"
  14   write(fd, '(A)') "1this is the fourth line"
  15   write(fd, '(A)') "$finally we have a new challenger for the final line"
  16   write(fd, '(A)') CHAR(0)//"this is the end"
  17   write(fd, '(A)') " this is a plain old line"
  18 endsubroutine
  19
  20 subroutine check_cc (cc, fname, expected)
  21   implicit none
  22   ! carraigecontrol type, file name to write to
  23   character(*), intent(in) :: cc, fname
  24   ! expected output
  25   character(*), intent(in) :: expected
  26
  27   ! read buffer, line number, unit, status
  28   character(len=:), allocatable :: buf
  29   integer :: i, fd, siz
  30   fd = 3
  31
  32   ! write lines using carriagecontrol setting
  33   open(unit=fd, file=fname, action='write', carriagecontrol=cc)
  34   call write_lines(fd)
  35   close(unit=fd)
  36
  37   open(unit=fd, file=fname, action='readwrite', &
  38        form='unformatted', access='stream')
  39   call fseek(fd, 0, 0)
  40   inquire(file=fname, size=siz)
  41   allocate(character(len=siz) :: buf)
  42   read(unit=fd, pos=1) buf
  43   if (buf .ne. expected) then
  44     print *, '=================> ',cc,' <================='
  45     print *, '*****  actual  *****'
  46     print *, buf
  47     print *, '***** expected *****'
  48     print *, expected
  49     deallocate(buf)
  50     close(unit=fd)
  51     STOP 1
  52   else
  53     deallocate(buf)
  54     close(unit=fd, status='delete')
  55   endif
  56 endsubroutine
  57
  58 implicit none
  59
  60 character(*), parameter :: fname  = 'dec_io_2.txt'
  61
  62 !! In NONE mode, there are no line breaks between records.
  63 character(*), parameter :: output_ccnone = &
  64   "+ first"//&
  65   "-second line"//&
  66   "0now you know"//&
  67   "1this is the fourth line"//&
  68   "$finally we have a new challenger for the final line"//&
  69   CHAR(0)//"this is the end"//&
  70   " this is a plain old line"
  71
  72 !! In LIST mode, each record is terminated with a newline.
  73 character(*), parameter :: output_cclist = &
  74   "+ first"//CHAR(13)//CHAR(10)//&
  75   "-second line"//CHAR(13)//CHAR(10)//&
  76   "0now you know"//CHAR(13)//CHAR(10)//&
  77   "1this is the fourth line"//CHAR(13)//CHAR(10)//&
  78   "$finally we have a new challenger for the final line"//CHAR(13)//CHAR(10)//&
  79   CHAR(0)//"this is the end"//CHAR(13)//CHAR(10)//&
  80   " this is a plain old line"//CHAR(13)//CHAR(10)
  81
  82 !! In FORTRAN mode, the default record break is CR, and the first character
  83 !! implies the start- and end-of-record formatting.
  84 ! '+' Overprinting: <text> CR
  85 ! '-' One line feed: NL <text> CR
  86 ! '0' Two line feeds: NL NL <text> CR
  87 ! '1' Next page: FF <text> CR
  88 ! '$' Prompting: NL <text>
  89 !'\0' Overprinting with no advance: <text>
  90 !     Other: defaults to Overprinting <text> CR
  91 character(*), parameter :: output_ccfort = ""//&
  92   " first"//CHAR(13)//&
  93   CHAR(10)//"second line"//CHAR(13)//&
  94   CHAR(10)//CHAR(10)//"now you know"//CHAR(13)//&
  95   CHAR(12)//"this is the fourth line"//CHAR(13)//&
  96   CHAR(10)//"finally we have a new challenger for the final line"//&
  97   "this is the end"//&
  98   CHAR(10)//"this is a plain old line"//CHAR(13)
  99
 100 call check_cc('none',    fname, output_ccnone)
 101 call check_cc('list',    fname, output_cclist)
 102 call check_cc('fortran', fname, output_ccfort)
 103
 104 end