gcc/testsuite/gfortran.dg/namelist_19.f90

   1 !{ dg-do run }
   2 !{ dg-options "-std=legacy" }
   3 !
   4 ! Test namelist error trapping.
   5 ! provided by Paul Thomas - pault@gcc.gnu.org
   6
   7 program namelist_19
   8   character*80 wrong, right
   9
  10 ! "=" before any object name
  11   wrong = "&z = i = 1,2 /"
  12   right = "&z i = 1,2 /"
  13   call test_err(wrong, right)
  14
  15 ! &* instead of &end for termination
  16   wrong = "&z i = 1,2 &xxx"
  17   right = "&z i = 1,2 &end"
  18   call test_err(wrong, right)
  19
  20 ! bad data
  21   wrong = "&z i = 1,q /"
  22   right = "&z i = 1,2 /"
  23   call test_err(wrong, right)
  24
  25 ! object name not matched
  26   wrong = "&z j = 1,2 /"
  27   right = "&z i = 1,2 /"
  28   call test_err(wrong, right)
  29
  30 ! derived type component for intrinsic type
  31   wrong = "&z i%j = 1,2 /"
  32   right = "&z i = 1,2 /"
  33   call test_err(wrong, right)
  34
  35 ! step other than 1 for substring qualifier
  36   wrong = "&z ch(1:2:2) = 'a'/"
  37   right = "&z ch(1:2) = 'ab' /"
  38   call test_err(wrong, right)
  39
  40 ! qualifier for scalar
  41   wrong = "&z k(2) = 1 /"
  42   right = "&z k    = 1 /"
  43   call test_err(wrong, right)
  44
  45 ! no '=' after object name
  46   wrong = "&z i   1,2 /"
  47   right = "&z i = 1,2 /"
  48   call test_err(wrong, right)
  49
  50 ! repeat count too large
  51   wrong = "&z i = 3*2 /"
  52   right = "&z i = 2*2 /"
  53   call test_err(wrong, right)
  54
  55 ! too much data
  56   wrong = "&z i = 1 2 3 /"
  57   right = "&z i = 1 2 /"
  58   call test_err(wrong, right)
  59
  60 ! no '=' after object name
  61   wrong = "&z i   1,2 /"
  62   right = "&z i = 1,2 /"
  63   call test_err(wrong, right)
  64
  65 ! bad number of index fields
  66   wrong = "&z i(1,2) = 1 /"
  67   right = "&z i(1)   = 1 /"
  68   call test_err(wrong, right)
  69
  70 ! bad character in index field
  71   wrong = "&z i(x) = 1 /"
  72   right = "&z i(1) = 1 /"
  73   call test_err(wrong, right)
  74
  75 ! null index field
  76   wrong = "&z i( ) = 1 /"
  77   right = "&z i(1) = 1 /"
  78   call test_err(wrong, right)
  79
  80 ! null index field
  81   wrong = "&z i(1::)   = 1 2/"
  82   right = "&z i(1:2:1) = 1 2 /"
  83   call test_err(wrong, right)
  84
  85 ! null index field
  86   wrong = "&z i(1:2:)  = 1 2/"
  87   right = "&z i(1:2:1) = 1 2 /"
  88   call test_err(wrong, right)
  89
  90 ! index out of range
  91   wrong = "&z i(10) = 1 /"
  92   right = "&z i(1)  = 1 /"
  93   call test_err(wrong, right)
  94
  95 ! index out of range
  96   wrong = "&z i(0:1) = 1 /"
  97   right = "&z i(1:1) = 1 /"
  98   call test_err(wrong, right)
  99
 100 ! bad range
 101   wrong = "&z i(1:2:-1) = 1 2 /"
 102   right = "&z i(1:2: 1) = 1 2 /"
 103   call test_err(wrong, right)
 104
 105 ! bad range
 106   wrong = "&z i(2:1: 1) = 1 2 /"
 107   right = "&z i(2:1:-1) = 1 2 /"
 108   call test_err(wrong, right)
 109
 110 contains
 111   subroutine test_err(wrong, right)
 112     character*80 wrong, right
 113     integer            :: i(2) = (/0, 0/)
 114     integer            :: k =0
 115     character*2        :: ch = "  "
 116     namelist /z/ i, k, ch
 117
 118 ! Check that wrong namelist input gives an error
 119
 120     open (10, status = "scratch")
 121     write (10, '(A)') wrong
 122     rewind (10)
 123     read (10, z, iostat = ier)
 124     close(10)
 125     if (ier == 0) call abort ()
 126
 127 ! Check that right namelist input gives no error
 128
 129     open (10, status = "scratch")
 130     write (10, '(A)') right
 131     rewind (10)
 132     read (10, z, iostat = ier)
 133     close(10)
 134     if (ier /= 0) call abort ()
 135   end subroutine test_err
 136
 137 end program namelist_19