gcc/testsuite/gfortran.dg/namelist_28.f90

   1 ! { dg-do run }
   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, parameter :: nmlunit = 12    ! Namelist unit
   7   integer            :: stat
   8
   9   open (nmlunit, status="scratch")
  10   write(nmlunit, '(a)') "&REPORT type='report1' /"
  11   write(nmlunit, '(a)') "&REPORT type='report2' /"
  12   write(nmlunit, '(a)') "!"
  13   rewind (nmlunit)
  14
  15 ! The call to position_nml is contained in the subroutine
  16   call read_report (nmlunit, stat)
  17   rewind (nmlunit)
  18   call position_nml (nmlunit, 'MISSING', stat)
  19   rewind (nmlunit)
  20   call read_report (nmlunit, stat)              ! gfortran fails here
  21
  22 contains
  23
  24   subroutine position_nml (unit, name, status)
  25     ! Check for presence of namelist 'name'
  26     integer                      :: unit, status
  27     character(len=*), intent(in) :: name
  28
  29     character(len=255) :: line
  30     integer            :: ios, idx, k
  31     logical            :: first
  32
  33     first = .true.
  34     status = 0
  35     do k=1,25
  36        line = ""
  37        read (unit,'(a)',iostat=ios) line
  38        if (ios < 0) then
  39           ! EOF encountered!
  40           backspace (unit)
  41           status = -1
  42           return
  43        else if (ios > 0) then
  44           ! Error encountered!
  45           status = +1
  46           return
  47        end if
  48        idx = index (line, "&"//trim (name))
  49        if (idx > 0) then
  50           backspace (unit)
  51           return
  52        end if
  53     end do
  54     if (k.gt.10) call abort
  55   end subroutine position_nml
  56
  57   subroutine read_report (unit, status)
  58     integer :: unit, status
  59
  60     integer            :: iuse, ios, k
  61     !------------------
  62     ! Namelist 'REPORT'
  63     !------------------
  64     character(len=12) :: type
  65     namelist /REPORT/ type
  66     !-------------------------------------
  67     ! Loop to read namelist multiple times
  68     !-------------------------------------
  69     iuse = 0
  70     do k=1,25
  71        !----------------------------------------
  72        ! Preset namelist variables with defaults
  73        !----------------------------------------
  74        type      = ''
  75        !--------------
  76        ! Read namelist
  77        !--------------
  78        call position_nml (unit, "REPORT", status)
  79        if (stat /= 0) then
  80           ios = status
  81           if (iuse /= 2) call abort()
  82           return
  83        end if
  84        read (unit, nml=REPORT, iostat=ios)
  85        if (ios /= 0) exit
  86        iuse = iuse + 1
  87     end do
  88     if (k.gt.10) call abort
  89     status = ios
  90   end subroutine read_report
  91
  92 end program gfcbug61