URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [namelist_27.f90] - Blame information for rev 704

Go to most recent revision | Details | Compare with Previous | View Log


! { dg-do run }
! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF.
! Patch derived from PR, submitted by Jerry DeLisle 
program gfcbug61
  implicit none
  integer            :: stat
 
  open (12, status="scratch")
  write (12, '(a)')"!================"
  write (12, '(a)')"! Namelist REPORT"
  write (12, '(a)')"!================"
  write (12, '(a)')" &REPORT type     = 'SYNOP' "
  write (12, '(a)')"         use      = 'active'"
  write (12, '(a)')"         max_proc = 20"
  write (12, '(a)')" /"
  write (12, '(a)')"! Other namelists..."
  write (12, '(a)')" &OTHER  i = 1 /"
  rewind (12)
 
  ! Read /REPORT/ the first time
  rewind (12)
  call position_nml (12, "REPORT", stat)
  if (stat.ne.0) call abort()
  if (stat == 0)  call read_report (12, stat)
 
  ! Comment out the following lines to hide the bug
  rewind (12)
  call position_nml (12, "MISSING", stat)
  if (stat.ne.-1)  call abort ()
 
  ! Read /REPORT/ again
  rewind (12)
  call position_nml (12, "REPORT", stat)
  if (stat.ne.0)  call abort()
 
contains
 
  subroutine position_nml (unit, name, status)
    ! Check for presence of namelist 'name'
    integer                      :: unit, status
    character(len=*), intent(in) :: name
 
    character(len=255) :: line
    integer            :: ios, idx, k
    logical            :: first
 
    first = .true.
    status = 0
    ios = 0
    line = ""
    do k=1,10
       read (unit,'(a)',iostat=ios) line
       if (first) then
          first = .false.
       end if
       if (ios < 0) then
          ! EOF encountered!
          backspace (unit)
          status = -1
          return
       else if (ios > 0) then
          ! Error encountered!
          status = +1
          return
       end if
       idx = index (line, "&"//trim (name))
       if (idx > 0) then
          backspace (unit)
          return
       end if
    end do
  end subroutine position_nml
 
  subroutine read_report (unit, status)
    integer :: unit, status
 
    integer            :: iuse, ios, k
    !------------------
    ! Namelist 'REPORT'
    !------------------
    character(len=12) :: type, use
    integer           :: max_proc
    namelist /REPORT/ type, use, max_proc
    !-------------------------------------
    ! Loop to read namelist multiple times
    !-------------------------------------
    iuse = 0
    do k=1,5
       !----------------------------------------
       ! Preset namelist variables with defaults
       !----------------------------------------
       type      = ''
       use       = ''
       max_proc  = -1
       !--------------
       ! Read namelist
       !--------------
       read (unit, nml=REPORT, iostat=ios)
       if (ios /= 0) exit
       iuse = iuse + 1
    end do
    if (iuse.ne.1) call abort()
    status = ios
  end subroutine read_report
 
end program gfcbug61

Line No.	Rev	Author	Line
1	694	jeremybenn	`! { dg-do run }`
2			`! PR31052 Bad IOSTAT values when readings NAMELISTs past EOF.`
3			`! Patch derived from PR, submitted by Jerry DeLisle`
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, k`
45			`logical :: first`
46
47			`first = .true.`
48			`status = 0`
49			`ios = 0`
50			`line = ""`
51			`do k=1,10`
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, k`
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 k=1,5`
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`

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [namelist_27.f90] - Blame information for rev 704