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
8subroutine 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"
18endsubroutine
19
20subroutine 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
56endsubroutine
57
58implicit none
59
60character(*), parameter :: fname  = 'dec_io_2.txt'
61
62!! In NONE mode, there are no line breaks between records.
63character(*), 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.
73character(*), parameter :: output_cclist = &
74  "+ first"//CHAR(10)//&
75  "-second line"//CHAR(10)//&
76  "0now you know"//CHAR(10)//&
77  "1this is the fourth line"//CHAR(10)//&
78  "$finally we have a new challenger for the final line"//CHAR(10)//&
79  CHAR(0)//"this is the end"//CHAR(10)//&
80  " this is a plain old line"//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
91character(*), 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
100call check_cc('none',    fname, output_ccnone)
101call check_cc('list',    fname, output_cclist)
102call check_cc('fortran', fname, output_ccfort)
103
104end
105