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     integer item
 140
 141     if (this%empty()) then
 142        stop 'Error! pop_integer invoked on empty stack'
 143     endif
 144     select type(top=>this%next)
 145     type is (integer_stack)
 146        select type(i => top%item)
 147        type is(integer)
 148           item = i
 149           class default
 150           stop 'Error #1! pop_integer encountered non-integer stack item'
 151        end select
 152        this%next => top%next
 153        deallocate(top)
 154        class default
 155        stop 'Error #2! pop_integer encountered non-integer_stack item'
 156     end select
 157   end function pop_integer
 158
 159 ! gfortran addition to check read/write
 160   logical function compare_integer (this, array, error)
 161     class(integer_stack), target :: this
 162     class(stack), pointer :: ptr, next
 163     integer :: array(:), i, j, error
 164     compare_integer = .true.
 165     ptr => this
 166     do j = 0, size (array, 1)
 167       if (compare_integer .eqv. .false.) return
 168       select type (ptr)
 169         type is (integer_stack)
 170           select type(k => ptr%item)
 171             type is(integer)
 172               if (k .ne. array(j)) error = 1
 173             class default
 174               error = 2
 175               compare_integer = .false.
 176           end select
 177         class default
 178           if (j .ne. 0) then
 179             error = 3
 180             compare_integer = .false.
 181           end if
 182       end select
 183       next => ptr%next
 184       if (associated (next)) then
 185         ptr => next
 186       else if (j .ne. size (array, 1)) then
 187         error = 4
 188         compare_integer = .false.
 189       end if
 190     end do
 191   end function
 192
 193   subroutine delete (this)
 194     class(stack), target :: this
 195     class(stack), pointer :: ptr1, ptr2
 196     ptr1 => this%next
 197     ptr2 => ptr1%next
 198     do while (associated (ptr1))
 199       deallocate (ptr1)
 200       ptr1 => ptr2
 201       if (associated (ptr1)) ptr2 => ptr1%next
 202     end do
 203   end subroutine
 204
 205 end module stack_mod
 206
 207 program stack_demo
 208
 209   use stack_mod
 210   implicit none
 211
 212   integer i, k(10), error
 213   class(io_stack), allocatable :: stk
 214   allocate(stk)
 215
 216   k = [3,1,7,0,2,9,4,8,5,6]
 217
 218   ! step 1: set up an 'output' file > changed to 'scratch'
 219
 220   open(10, status='scratch', form='unformatted')
 221
 222   ! step 2: add values to stack
 223
 224   do i=1,10
 225 !     write(*,*) 'Adding ',i,' to the stack'
 226      call stk%push(k(i))
 227   enddo
 228
 229   ! step 3: pop values from stack and write them to file
 230
 231 !  write(*,*)
 232 !  write(*,*) 'Removing each item from stack and writing it to file.'
 233 !  write(*,*)
 234   do while(.not.stk%empty())
 235      write(10) stk
 236   enddo
 237
 238   ! step 4: close file and reopen it for read > changed to rewind.
 239
 240   rewind(10)
 241
 242   ! step 5: read values back into stack
 243 !  write(*,*) 'Reading each value from file and adding it to stack:'
 244   do while(.true.)
 245      read(10,END=9999) i
 246 !     write(*,*), 'Reading ',i,' from file. Adding it to stack'
 247      call stk%push(i)
 248   enddo
 249
 250 9999 continue
 251
 252   ! step 6: Dump stack to standard out
 253
 254 !  write(*,*)
 255 !  write(*,*), 'Removing every element from stack and writing it to screen:'
 256 !  write(*,*) stk
 257
 258 ! gfortran addition to check read/write
 259   if (.not. stk%compare (k, error)) then
 260     select case (error)
 261       case(1)
 262         print *, "values do not match"
 263       case(2)
 264         print *, "non integer found in stack"
 265       case(3)
 266         print *, "type mismatch in stack"
 267       case(4)
 268         print *, "too few values in stack"
 269     end select
 270     call abort
 271   end if
 272
 273   close(10)
 274
 275 ! Clean up - valgrind indicates no leaks.
 276   call stk%delete
 277   deallocate (stk)
 278 end program stack_demo