gcc/testsuite/gfortran.dg/dtio_5.f90

   1 ! { dg-do run }
   2 !
   3 ! This test is based on the second case in the PGInsider article at
   4 ! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
   5 !
   6 ! The complete original code is at:
   7 ! https://www.pgroup.com/lit/samples/pginsider/stack.f90
   8 !
   9 ! Thanks to Mark LeAir.
  10 !
  11 !     Copyright (c) 2015, NVIDIA CORPORATION.  All rights reserved.
  12 !
  13 ! NVIDIA CORPORATION and its licensors retain all intellectual property
  14 ! and proprietary rights in and to this software, related documentation
  15 ! and any modifications thereto.  Any use, reproduction, disclosure or
  16 ! distribution of this software and related documentation without an express
  17 ! license agreement from NVIDIA CORPORATION is strictly prohibited.
  18 !
  19
  20 !          THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
  21 !   WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
  22 !   NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
  23 !   FITNESS FOR A PARTICULAR PURPOSE.
  24 !
  25
  26 module stack_mod
  27
  28   type, abstract :: stack
  29      private
  30      class(*), allocatable :: item           ! an item on the stack
  31      class(stack), pointer :: next=>null()   ! next item on the stack
  32    contains
  33      procedure :: empty                      ! returns true if stack is empty
  34      procedure :: delete                     ! empties the stack
  35   end type stack
  36
  37 type, extends(stack) :: integer_stack
  38 contains
  39   procedure :: push => push_integer ! add integer item to stack
  40   procedure :: pop => pop_integer   ! remove integer item from stack
  41   procedure :: compare => compare_integer   ! compare with an integer array
  42 end type integer_stack
  43
  44 type, extends(integer_stack) :: io_stack
  45 contains
  46   procedure,private :: wio_stack
  47   procedure,private :: rio_stack
  48   procedure,private :: dump_stack
  49   generic :: write(unformatted) => wio_stack ! write stack item to file
  50   generic :: read(unformatted) => rio_stack  ! push item from file
  51   generic :: write(formatted) => dump_stack  ! print all items from stack
  52 end type io_stack
  53
  54 contains
  55
  56   subroutine rio_stack (dtv, unit, iostat, iomsg)
  57
  58     ! read item from file and add it to stack
  59
  60     class(io_stack), intent(inout) :: dtv
  61     integer, intent(in) :: unit
  62     integer, intent(out) :: iostat
  63     character(len=*), intent(inout) :: iomsg
  64
  65     integer :: item
  66
  67     read(unit,IOSTAT=iostat,IOMSG=iomsg) item
  68
  69     if (iostat .ne. 0) then
  70       call dtv%push(item)
  71     endif
  72
  73   end subroutine rio_stack
  74
  75   subroutine wio_stack(dtv, unit, iostat, iomsg)
  76
  77     ! pop an item from stack and write it to file
  78
  79     class(io_stack), intent(in) :: dtv
  80     integer, intent(in) :: unit
  81     integer, intent(out) :: iostat
  82     character(len=*), intent(inout) :: iomsg
  83     integer :: item
  84
  85     item = dtv%pop()
  86     write(unit,IOSTAT=iostat,IOMSG=iomsg) item
  87
  88   end subroutine wio_stack
  89
  90   subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
  91
  92     ! Pop all items off stack and write them out to unit
  93     ! Assumes default LISTDIRECTED output
  94
  95     class(io_stack), intent(in) :: dtv
  96     integer, intent(in) :: unit
  97     character(len=*), intent(in) :: iotype
  98     integer, intent(in) :: v_list(:)
  99     integer, intent(out) :: iostat
 100     character(len=*), intent(inout) :: iomsg
 101     character(len=80) :: buffer
 102     integer :: item
 103
 104     if (iotype .ne. 'LISTDIRECTED') then
 105        ! Error
 106        iomsg = 'dump_stack: unsupported iotype'
 107        iostat = 1
 108     else
 109        iostat = 0
 110        do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
 111          item = dtv%pop()
 112           write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
 113        enddo
 114     endif
 115   end subroutine dump_stack
 116
 117   logical function empty(this)
 118     class(stack) :: this
 119     if (.not.associated(this%next)) then
 120        empty = .true.
 121     else
 122        empty = .false.
 123     end if
 124   end function empty
 125
 126   subroutine push_integer(this,item)
 127     class(integer_stack) :: this
 128     integer :: item
 129     type(integer_stack), allocatable :: new_item
 130
 131     allocate(new_item)
 132     allocate(new_item%item, source=item)
 133     new_item%next => this%next
 134     allocate(this%next, source=new_item)
 135   end subroutine push_integer
 136
 137   function pop_integer(this) result(item)
 138     class(integer_stack) :: this
 139     class(stack), pointer :: dealloc_item
 140     integer item
 141
 142     if (this%empty()) then
 143        stop 'Error! pop_integer invoked on empty stack'
 144     endif
 145     select type(top=>this%next)
 146     type is (integer_stack)
 147        select type(i => top%item)
 148        type is(integer)
 149           item = i
 150           class default
 151           stop 'Error #1! pop_integer encountered non-integer stack item'
 152        end select
 153        dealloc_item => this%next
 154        this%next => top%next
 155        deallocate(dealloc_item)
 156        class default
 157        stop 'Error #2! pop_integer encountered non-integer_stack item'
 158     end select
 159   end function pop_integer
 160
 161 ! gfortran addition to check read/write
 162   logical function compare_integer (this, array, error)
 163     class(integer_stack), target :: this
 164     class(stack), pointer :: ptr, next
 165     integer :: array(:), i, j, error
 166     compare_integer = .true.
 167     ptr => this
 168     do j = 0, size (array, 1)
 169       if (compare_integer .eqv. .false.) return
 170       select type (ptr)
 171         type is (integer_stack)
 172           select type(k => ptr%item)
 173             type is(integer)
 174               if (k .ne. array(j)) error = 1
 175             class default
 176               error = 2
 177               compare_integer = .false.
 178           end select
 179         class default
 180           if (j .ne. 0) then
 181             error = 3
 182             compare_integer = .false.
 183           end if
 184       end select
 185       next => ptr%next
 186       if (associated (next)) then
 187         ptr => next
 188       else if (j .ne. size (array, 1)) then
 189         error = 4
 190         compare_integer = .false.
 191       end if
 192     end do
 193   end function
 194
 195   subroutine delete (this)
 196     class(stack), target :: this
 197     class(stack), pointer :: ptr1, ptr2
 198     ptr1 => this%next
 199     ptr2 => ptr1%next
 200     do while (associated (ptr1))
 201       deallocate (ptr1)
 202       ptr1 => ptr2
 203       if (associated (ptr1)) ptr2 => ptr1%next
 204     end do
 205   end subroutine
 206
 207 end module stack_mod
 208
 209 program stack_demo
 210
 211   use stack_mod
 212   implicit none
 213
 214   integer i, k(10), error
 215   class(io_stack), allocatable :: stk
 216   allocate(stk)
 217
 218   k = [3,1,7,0,2,9,4,8,5,6]
 219
 220   ! step 1: set up an 'output' file > changed to 'scratch'
 221
 222   open(10, status='scratch', form='unformatted')
 223
 224   ! step 2: add values to stack
 225
 226   do i=1,10
 227 !     write(*,*) 'Adding ',i,' to the stack'
 228      call stk%push(k(i))
 229   enddo
 230
 231   ! step 3: pop values from stack and write them to file
 232
 233 !  write(*,*)
 234 !  write(*,*) 'Removing each item from stack and writing it to file.'
 235 !  write(*,*)
 236   do while(.not.stk%empty())
 237      write(10) stk
 238   enddo
 239
 240   ! step 4: close file and reopen it for read > changed to rewind.
 241
 242   rewind(10)
 243
 244   ! step 5: read values back into stack
 245 !  write(*,*) 'Reading each value from file and adding it to stack:'
 246   do while(.true.)
 247      read(10,END=9999) i
 248 !     write(*,*), 'Reading ',i,' from file. Adding it to stack'
 249      call stk%push(i)
 250   enddo
 251
 252 9999 continue
 253
 254   ! step 6: Dump stack to standard out
 255
 256 !  write(*,*)
 257 !  write(*,*), 'Removing every element from stack and writing it to screen:'
 258 !  write(*,*) stk
 259
 260 ! gfortran addition to check read/write
 261   if (.not. stk%compare (k, error)) then
 262     select case (error)
 263       case(1)
 264         print *, "values do not match"
 265       case(2)
 266         print *, "non integer found in stack"
 267       case(3)
 268         print *, "type mismatch in stack"
 269       case(4)
 270         print *, "too few values in stack"
 271     end select
 272     call abort
 273   end if
 274
 275   close(10)
 276
 277 ! Clean up - valgrind indicates no leaks.
 278   call stk%delete
 279   deallocate (stk)
 280 end program stack_demo