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