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 26module 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 37type, extends(stack) :: integer_stack 38contains 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 42end type integer_stack 43 44type, extends(integer_stack) :: io_stack 45contains 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 52end type io_stack 53 54contains 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 207end module stack_mod 208 209program 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 2529999 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 STOP 1 273 end if 274 275 close(10) 276 277! Clean up - valgrind indicates no leaks. 278 call stk%delete 279 deallocate (stk) 280end program stack_demo 281