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

Subversion Repositories openrisc

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

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, parameter :: nmlunit = 12    ! Namelist unit
  integer            :: stat
 
  open (nmlunit, status="scratch")
  write(nmlunit, '(a)') "&REPORT type='report1' /"
  write(nmlunit, '(a)') "&REPORT type='report2' /"
  write(nmlunit, '(a)') "!"
  rewind (nmlunit)
 
! The call to position_nml is contained in the subroutine
  call read_report (nmlunit, stat)
  rewind (nmlunit)
  call position_nml (nmlunit, 'MISSING', stat)
  rewind (nmlunit)
  call read_report (nmlunit, stat)              ! gfortran fails here
 
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
    do k=1,25
       line = ""
       read (unit,'(a)',iostat=ios) line
       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
    if (k.gt.10) call abort
  end subroutine position_nml
 
  subroutine read_report (unit, status)
    integer :: unit, status
 
    integer            :: iuse, ios, k
    !------------------
    ! Namelist 'REPORT'
    !------------------
    character(len=12) :: type
    namelist /REPORT/ type
    !-------------------------------------
    ! Loop to read namelist multiple times
    !-------------------------------------
    iuse = 0
    do k=1,25
       !----------------------------------------
       ! Preset namelist variables with defaults
       !----------------------------------------
       type      = ''
       !--------------
       ! Read namelist
       !--------------
       call position_nml (unit, "REPORT", status)
       if (stat /= 0) then
          ios = status
          if (iuse /= 2) call abort()
          return
       end if
       read (unit, nml=REPORT, iostat=ios)
       if (ios /= 0) exit
       iuse = iuse + 1
    end do
    if (k.gt.10) 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, 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`

Browse

Tools

Subversion Repositories openrisc

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