--- /dev/null
+! { dg-do run }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+! Check basic functionality of async I/O
+program main
+ implicit none
+ integer:: i=1, j=2, k, l
+ real :: a, b, c, d
+ character(3), parameter:: yes="yes"
+ character(4) :: str
+ complex :: cc, dd
+ integer, dimension(4):: is = [0, 1, 2, 3]
+ integer, dimension(4):: res
+ character(10) :: inq
+
+ open (10, file='a.dat', asynchronous=yes)
+ cc = (1.5, 0.5)
+ inquire (10,asynchronous=inq)
+ if (inq /= "YES") stop 1
+ write (10,*,asynchronous=yes) 4, 3
+ write (10,*,asynchronous=yes) 2, 1
+ write (10,*,asynchronous=yes) 1.0, 3.0
+ write (10,'(A)', asynchronous=yes) 'asdf'
+ write (10,*, asynchronous=yes) cc
+ close (10)
+ open (20, file='a.dat', asynchronous=yes)
+ read (20, *, asynchronous=yes) i, j
+ read (20, *, asynchronous=yes) k, l
+ read (20, *, asynchronous=yes) a, b
+ read (20,'(A4)',asynchronous=yes) str
+ read (20,*, asynchronous=yes) dd
+ wait (20)
+ if (i /= 4 .or. j /= 3) stop 2
+ if (k /= 2 .or. l /= 1) stop 3
+ if (a /= 1.0 .or. b /= 3.0) stop 4
+ if (str /= 'asdf') stop 5
+ if (cc /= dd) stop 6
+ close (20,status="delete")
+
+ open(10, file='c.dat', asynchronous=yes)
+ write(10, *, asynchronous=yes) is
+ close(10)
+ open(20, file='c.dat', asynchronous=yes)
+ read(20, *, asynchronous=yes) res
+ wait (20)
+ if (any(res /= is)) stop 7
+ close (20,status="delete")
+end program
--- /dev/null
+! { dg-do run }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+program main
+ implicit none
+ integer :: i, ios
+ character(len=100) :: iom
+ open (10,file="tst.dat")
+ write (10,'(A4)') 'asdf'
+ close(10)
+ i = 234
+ open(10,file="tst.dat", asynchronous="yes")
+ read (10,'(I4)',asynchronous="yes") i
+ iom = ' '
+ wait (10,iostat=ios,iomsg=iom)
+ if (iom == ' ') stop 1
+ close(10,status="delete")
+end program main
--- /dev/null
+
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+! { dg-do run }
+program main
+ integer :: i
+ open (10,file="tst.dat")
+ write (10,'(A4)') 'asdf'
+ close(10)
+ i = 234
+ open(10,file="tst.dat", asynchronous="yes")
+ read (10,'(I4)',asynchronous="yes") i
+ wait(10)
+end program main
+! { dg-output "Fortran runtime error: Bad value during integer read" }
+! { dg-final { remote_file build delete "tst.dat" } }
--- /dev/null
+! { dg-do run { target fd_truncate } }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+
+! Test BACKSPACE for synchronous and asynchronous I/O
+program main
+
+ integer i, n, nr
+ real x(10), y(10)
+
+ ! PR libfortran/20068
+ open (20, status='scratch', asynchronous="yes")
+ write (20,*, asynchronous="yes" ) 1
+ write (20,*, asynchronous="yes") 2
+ write (20,*, asynchronous="yes") 3
+ rewind (20)
+ i = 41
+ read (20,*, asynchronous="yes") i
+ wait (20)
+ if (i .ne. 1) STOP 1
+ write (*,*) ' '
+ backspace (20)
+ i = 42
+ read (20,*, asynchronous="yes") i
+ close (20)
+ if (i .ne. 1) STOP 2
+
+ ! PR libfortran/20125
+ open (20, status='scratch', asynchronous="yes")
+ write (20,*, asynchronous="yes") 7
+ backspace (20)
+ read (20,*, asynchronous="yes") i
+ wait (20)
+ if (i .ne. 7) STOP 3
+ close (20)
+
+ open (20, status='scratch', form='unformatted')
+ write (20) 8
+ backspace (20)
+ read (20) i
+ if (i .ne. 8) STOP 4
+ close (20)
+
+ ! PR libfortran/20471
+ do n = 1, 10
+ x(n) = sqrt(real(n))
+ end do
+ open (3, form='unformatted', status='scratch')
+ write (3) (x(n),n=1,10)
+ backspace (3)
+ rewind (3)
+ read (3) (y(n),n=1,10)
+
+ do n = 1, 10
+ if (abs(x(n)-y(n)) > 0.00001) STOP 5
+ end do
+ close (3)
+
+ ! PR libfortran/20156
+ open (3, form='unformatted', status='scratch')
+ do i = 1, 5
+ x(1) = i
+ write (3) n, (x(n),n=1,10)
+ end do
+ nr = 0
+ rewind (3)
+20 continue
+ read (3,end=30,err=90) n, (x(n),n=1,10)
+ nr = nr + 1
+ goto 20
+30 continue
+ if (nr .ne. 5) STOP 6
+
+ do i = 1, nr+1
+ backspace (3)
+ end do
+
+ do i = 1, nr
+ read(3,end=70,err=90) n, (x(n),n=1,10)
+ if (abs(x(1) - i) .gt. 0.001) STOP 7
+ end do
+ close (3)
+ stop
+
+70 continue
+ STOP 8
+90 continue
+ STOP 9
+
+end program
--- /dev/null
+! { dg-do run }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+! PR55818 Reading a REAL from a file which doesn't end in a new line fails
+! Test case from PR reporter.
+implicit none
+integer :: stat
+!integer :: var ! << works
+real :: var ! << fails
+character(len=10) :: cvar ! << fails
+complex :: cval
+logical :: lvar
+
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "1", new_line("")
+write(99) "2", new_line("")
+write(99) "3"
+close(99)
+
+! Test character kind
+open(99, file="test.dat")
+read (99,*, iostat=stat) cvar
+if (stat /= 0 .or. cvar /= "1") STOP 1
+read (99,*, iostat=stat) cvar
+if (stat /= 0 .or. cvar /= "2") STOP 2
+read (99,*, iostat=stat) cvar ! << FAILS: stat /= 0
+if (stat /= 0 .or. cvar /= "3") STOP 3 ! << aborts here
+
+! Test real kind
+rewind(99)
+read (99,*, iostat=stat) var
+if (stat /= 0 .or. var /= 1.0) STOP 4
+read (99,*, iostat=stat) var
+if (stat /= 0 .or. var /= 2.0) STOP 5
+read (99,*, iostat=stat) var ! << FAILS: stat /= 0
+if (stat /= 0 .or. var /= 3.0) STOP 6
+close(99, status="delete")
+
+! Test real kind with exponents
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "1.0e3", new_line("")
+write(99) "2.0e-03", new_line("")
+write(99) "3.0e2"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 7
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 8
+read (99,*) var ! << FAILS: stat /= 0
+if (stat /= 0) STOP 9
+close(99, status="delete")
+
+! Test logical kind
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "Tru", new_line("")
+write(99) "fal", new_line("")
+write(99) "t"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) lvar
+if (stat /= 0 .or. (.not.lvar)) STOP 10
+read (99,*, iostat=stat) lvar
+if (stat /= 0 .or. lvar) STOP 11
+read (99,*) lvar ! << FAILS: stat /= 0
+if (stat /= 0 .or. (.not.lvar)) STOP 12
+close(99, status="delete")
+
+! Test combinations of Inf and Nan
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "infinity", new_line("")
+write(99) "nan", new_line("")
+write(99) "infinity"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 13
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 14
+read (99,*) var ! << FAILS: stat /= 0
+if (stat /= 0) STOP 1! << aborts here
+close(99, status="delete")
+
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "infinity", new_line("")
+write(99) "inf", new_line("")
+write(99) "nan"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 15
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 16
+read (99,*) var ! << FAILS: stat /= 0
+if (stat /= 0) STOP 2! << aborts here
+close(99, status="delete")
+
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "infinity", new_line("")
+write(99) "nan", new_line("")
+write(99) "inf"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 17
+read (99,*, iostat=stat) var
+if (stat /= 0) STOP 18
+read (99,*) var ! << FAILS: stat /= 0
+if (stat /= 0) STOP 3! << aborts here
+close(99, status="delete")
+
+! Test complex kind
+open(99, file="test.dat", access="stream", form="unformatted", status="new")
+write(99) "(1,2)", new_line("")
+write(99) "(2,3)", new_line("")
+write(99) "(4,5)"
+close(99)
+
+open(99, file="test.dat")
+read (99,*, iostat=stat) cval
+if (stat /= 0 .or. cval /= cmplx(1,2)) STOP 19
+read (99,*, iostat=stat) cval
+if (stat /= 0 .or. cval /= cmplx(2,3)) STOP 20
+read (99,*, iostat=stat) cval ! << FAILS: stat /= 0, value is okay
+if (stat /= 0 .or. cval /= cmplx(4,5)) STOP 21
+close(99, status="delete")
+end
--- /dev/null
+! { dg-do run }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+! PR 22390 Implement flush statement
+program flush_1
+
+ character(len=256) msg
+ integer ios
+
+ open (unit=10, access='SEQUENTIAL', status='SCRATCH')
+
+ write (10, *) 42
+ flush 10
+
+ write (10, *) 42
+ flush(10)
+
+ write (10, *) 42
+ flush(unit=10, iostat=ios)
+ if (ios /= 0) STOP 1
+
+ write (10, *) 42
+ flush (unit=10, err=20)
+ goto 30
+20 STOP 2
+30 continue
+
+ call flush(10)
+
+end program flush_1
--- /dev/null
+! { dg-do run }
+!TODO: Move these testcases to gfortran testsuite
+! once compilation with pthreads is supported there
+! PR40008 F2008: Add NEWUNIT= for OPEN statement
+! Contributed by Jerry DeLisle <jvdelisle@gcc.gnu.org>
+program newunit_1
+ character(len=25) :: str
+ integer(1) :: myunit, myunit2
+ myunit = 25
+ str = "bad"
+ open(newunit=myunit, status="scratch")
+ open(newunit = myunit2, file="newunit_1file")
+ write(myunit,'(e24.15e2)') 1.0d0
+ write(myunit2,*) "abcdefghijklmnop"
+ flush(myunit)
+ rewind(myunit)
+ rewind(myunit2)
+ read(myunit2,'(a)') str
+ if (str.ne." abcdefghijklmnop") STOP 1
+ close(myunit)
+ close(myunit2, status="delete")
+end program newunit_1
projects / gcc.git / commitdiff