gcc/testsuite/gfortran.dg/namelist_27.f90

   1 ! { dg-do run { target fd_truncate } }
   2 ! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF.
   3 ! Patch derived from PR, submitted by Jerry DeLisle <jvdelisle@gcc.gnu.org>
   4 program gfcbug61
   5   implicit none
   6   integer            :: stat
   7
   8   open (12, status="scratch")
   9   write (12, '(a)')"!================"
  10   write (12, '(a)')"! Namelist REPORT"
  11   write (12, '(a)')"!================"
  12   write (12, '(a)')" &REPORT type     = 'SYNOP' "
  13   write (12, '(a)')"         use      = 'active'"
  14   write (12, '(a)')"         max_proc = 20"
  15   write (12, '(a)')" /"
  16   write (12, '(a)')"! Other namelists..."
  17   write (12, '(a)')" &OTHER  i = 1 /"
  18   rewind (12)
  19
  20   ! Read /REPORT/ the first time
  21   rewind (12)
  22   call position_nml (12, "REPORT", stat)
  23   if (stat.ne.0) call abort()
  24   if (stat == 0)  call read_report (12, stat)
  25
  26   ! Comment out the following lines to hide the bug
  27   rewind (12)
  28   call position_nml (12, "MISSING", stat)
  29   if (stat.ne.-1)  call abort ()
  30
  31   ! Read /REPORT/ again
  32   rewind (12)
  33   call position_nml (12, "REPORT", stat)
  34   if (stat.ne.0)  call abort()
  35
  36 contains
  37
  38   subroutine position_nml (unit, name, status)
  39     ! Check for presence of namelist 'name'
  40     integer                      :: unit, status
  41     character(len=*), intent(in) :: name
  42
  43     character(len=255) :: line
  44     integer            :: ios, idx
  45     logical            :: first
  46
  47     first = .true.
  48     status = 0
  49     ios = 0
  50     line = ""
  51     do
  52        read (unit,'(a)',iostat=ios) line
  53        if (first) then
  54           first = .false.
  55        end if
  56        if (ios < 0) then
  57           ! EOF encountered!
  58           backspace (unit)
  59           status = -1
  60           return
  61        else if (ios > 0) then
  62           ! Error encountered!
  63           status = +1
  64           return
  65        end if
  66        idx = index (line, "&"//trim (name))
  67        if (idx > 0) then
  68           backspace (unit)
  69           return
  70        end if
  71     end do
  72   end subroutine position_nml
  73
  74   subroutine read_report (unit, status)
  75     integer :: unit, status
  76
  77     integer            :: iuse, ios
  78     !------------------
  79     ! Namelist 'REPORT'
  80     !------------------
  81     character(len=12) :: type, use
  82     integer           :: max_proc
  83     namelist /REPORT/ type, use, max_proc
  84     !-------------------------------------
  85     ! Loop to read namelist multiple times
  86     !-------------------------------------
  87     iuse = 0
  88     do
  89        !----------------------------------------
  90        ! Preset namelist variables with defaults
  91        !----------------------------------------
  92        type      = ''
  93        use       = ''
  94        max_proc  = -1
  95        !--------------
  96        ! Read namelist
  97        !--------------
  98        read (unit, nml=REPORT, iostat=ios)
  99        if (ios /= 0) exit
 100        iuse = iuse + 1
 101     end do
 102     if (iuse.ne.1) call abort()
 103     status = ios
 104   end subroutine read_report
 105
 106 end program gfcbug61