138 lines
3.0 KiB
Fortran
138 lines
3.0 KiB
Fortran
!{ dg-do run }
|
|
!{ dg-options "-std=legacy" }
|
|
!
|
|
! Test namelist error trapping.
|
|
! provided by Paul Thomas - pault@gcc.gnu.org
|
|
|
|
program namelist_19
|
|
character*80 wrong, right
|
|
|
|
! "=" before any object name
|
|
wrong = "&z = i = 1,2 /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! &* instead of &end for termination
|
|
wrong = "&z i = 1,2 &xxx"
|
|
right = "&z i = 1,2 &end"
|
|
call test_err(wrong, right)
|
|
|
|
! bad data
|
|
wrong = "&z i = 1,q /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! object name not matched
|
|
wrong = "&z j = 1,2 /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! derived type component for intrinsic type
|
|
wrong = "&z i%j = 1,2 /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! step other than 1 for substring qualifier
|
|
wrong = "&z ch(1:2:2) = 'a'/"
|
|
right = "&z ch(1:2) = 'ab' /"
|
|
call test_err(wrong, right)
|
|
|
|
! qualifier for scalar
|
|
wrong = "&z k(2) = 1 /"
|
|
right = "&z k = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! no '=' after object name
|
|
wrong = "&z i 1,2 /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! repeat count too large
|
|
wrong = "&z i = 3*2 /"
|
|
right = "&z i = 2*2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! too much data
|
|
wrong = "&z i = 1 2 3 /"
|
|
right = "&z i = 1 2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! no '=' after object name
|
|
wrong = "&z i 1,2 /"
|
|
right = "&z i = 1,2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! bad number of index fields
|
|
wrong = "&z i(1,2) = 1 /"
|
|
right = "&z i(1) = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! bad character in index field
|
|
wrong = "&z i(x) = 1 /"
|
|
right = "&z i(1) = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! null index field
|
|
wrong = "&z i( ) = 1 /"
|
|
right = "&z i(1) = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! null index field
|
|
wrong = "&z i(1::) = 1 2/"
|
|
right = "&z i(1:2:1) = 1 2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! null index field
|
|
wrong = "&z i(1:2:) = 1 2/"
|
|
right = "&z i(1:2:1) = 1 2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! index out of range
|
|
wrong = "&z i(10) = 1 /"
|
|
right = "&z i(1) = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! index out of range
|
|
wrong = "&z i(0:1) = 1 /"
|
|
right = "&z i(1:1) = 1 /"
|
|
call test_err(wrong, right)
|
|
|
|
! bad range
|
|
wrong = "&z i(1:2:-1) = 1 2 /"
|
|
right = "&z i(1:2: 1) = 1 2 /"
|
|
call test_err(wrong, right)
|
|
|
|
! bad range
|
|
wrong = "&z i(2:1: 1) = 1 2 /"
|
|
right = "&z i(2:1:-1) = 1 2 /"
|
|
call test_err(wrong, right)
|
|
|
|
contains
|
|
subroutine test_err(wrong, right)
|
|
character*80 wrong, right
|
|
integer :: i(2) = (/0, 0/)
|
|
integer :: k =0
|
|
character*2 :: ch = " "
|
|
namelist /z/ i, k, ch
|
|
|
|
! Check that wrong namelist input gives an error
|
|
|
|
open (10, status = "scratch")
|
|
write (10, '(A)') wrong
|
|
rewind (10)
|
|
read (10, z, iostat = ier)
|
|
close(10)
|
|
if (ier == 0) call abort ()
|
|
|
|
! Check that right namelist input gives no error
|
|
|
|
open (10, status = "scratch")
|
|
write (10, '(A)') right
|
|
rewind (10)
|
|
read (10, z, iostat = ier)
|
|
close(10)
|
|
if (ier /= 0) call abort ()
|
|
end subroutine test_err
|
|
|
|
end program namelist_19
|