1! { dg-do run }
2!
3! Copyright 2015 NVIDIA Corporation
4!
5! Test case for unlimited polymorphism that is derived from the article
6! by Mark Leair, in the 'PGInsider':
7! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
8! Note that 'addValue' has been removed from the generic 'add' because
9! gfortran asserts that this is ambiguous. See
10! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
11!
12module link_mod
13  private
14  public :: link, output, index
15  character(6) :: output (14)
16  integer :: index = 0
17  type link
18     private
19     class(*), pointer :: value => null() ! value stored in link
20     type(link), pointer :: next => null()! next link in list
21     contains
22     procedure :: getValue    ! return value pointer
23     procedure :: printLinks  ! print linked list starting with this link
24     procedure :: nextLink    ! return next pointer
25     procedure :: setNextLink ! set next pointer
26  end type link
27
28  interface link
29   procedure constructor ! construct/initialize a link
30  end interface
31
32contains
33
34  function nextLink(this)
35  class(link) :: this
36  class(link), pointer :: nextLink
37    nextLink => this%next
38  end function nextLink
39
40  subroutine setNextLink(this,next)
41  class(link) :: this
42  class(link), pointer :: next
43     this%next => next
44  end subroutine setNextLink
45
46  function getValue(this)
47  class(link) :: this
48  class(*), pointer :: getValue
49  getValue => this%value
50  end function getValue
51
52  subroutine printLink(this)
53  class(link) :: this
54
55  index = index + 1
56
57  select type(v => this%value)
58  type is (integer)
59    write (output(index), '(i6)') v
60  type is (character(*))
61    write (output(index), '(a6)') v
62  type is (real)
63    write (output(index), '(f6.2)') v
64  class default
65    stop 'printLink: unexepected type for link'
66  end select
67
68  end subroutine printLink
69
70  subroutine printLinks(this)
71  class(link) :: this
72  class(link), pointer :: curr
73
74  call printLink(this)
75  curr => this%next
76  do while(associated(curr))
77    call printLink(curr)
78    curr => curr%next
79  end do
80
81  end subroutine
82
83  function constructor(value, next)
84    class(link),pointer :: constructor
85    class(*) :: value
86    class(link), pointer :: next
87    allocate(constructor)
88    constructor%next => next
89    allocate(constructor%value, source=value)
90  end function constructor
91
92end module link_mod
93
94module list_mod
95  use link_mod
96  private
97  public :: list
98  type list
99     private
100     class(link),pointer :: firstLink => null() ! first link in list
101     class(link),pointer :: lastLink => null()  ! last link in list
102   contains
103     procedure :: printValues ! print linked list
104     procedure :: addInteger  ! add integer to linked list
105     procedure :: addChar     ! add character to linked list
106     procedure :: addReal     ! add real to linked list
107     procedure :: addValue    ! add class(*) to linked list
108     procedure :: firstValue  ! return value associated with firstLink
109     procedure :: isEmpty     ! return true if list is empty
110     generic :: add => addInteger, addChar, addReal
111  end type list
112
113contains
114
115  subroutine printValues(this)
116    class(list) :: this
117
118    if (.not.this%isEmpty()) then
119       call this%firstLink%printLinks()
120    endif
121  end subroutine printValues
122
123  subroutine addValue(this, value)
124    class(list) :: this
125    class(*) :: value
126    class(link), pointer :: newLink
127
128    if (.not. associated(this%firstLink)) then
129       this%firstLink => link(value, this%firstLink)
130       this%lastLink => this%firstLink
131    else
132       newLink => link(value, this%lastLink%nextLink())
133       call this%lastLink%setNextLink(newLink)
134       this%lastLink => newLink
135    end if
136
137  end subroutine addValue
138
139  subroutine addInteger(this, value)
140   class(list) :: this
141    integer value
142    class(*), allocatable :: v
143    allocate(v,source=value)
144    call this%addValue(v)
145  end subroutine addInteger
146
147  subroutine addChar(this, value)
148    class(list) :: this
149    character(*) :: value
150    class(*), allocatable :: v
151
152    allocate(v,source=value)
153    call this%addValue(v)
154  end subroutine addChar
155
156  subroutine addReal(this, value)
157    class(list) :: this
158    real value
159    class(*), allocatable :: v
160
161    allocate(v,source=value)
162    call this%addValue(v)
163  end subroutine addReal
164
165  function firstValue(this)
166    class(list) :: this
167    class(*), pointer :: firstValue
168
169    firstValue => this%firstLink%getValue()
170
171  end function firstValue
172
173  function isEmpty(this)
174    class(list) :: this
175    logical isEmpty
176
177    if (associated(this%firstLink)) then
178       isEmpty = .false.
179    else
180       isEmpty = .true.
181    endif
182  end function isEmpty
183
184end module list_mod
185
186program main
187  use link_mod, only : output
188  use list_mod
189  implicit none
190  integer i, j
191  type(list) :: my_list
192
193  do i=1, 10
194     call my_list%add(i)
195  enddo
196  call my_list%add(1.23)
197  call my_list%add('A')
198  call my_list%add('BC')
199  call my_list%add('DEF')
200  call my_list%printvalues()
201  do i = 1, 14
202    select case (i)
203      case (1:10)
204        read (output(i), '(i6)') j
205        if (j .ne. i) STOP 1
206      case (11)
207        if (output(i) .ne. "  1.23") STOP 2
208      case (12)
209        if (output(i) .ne. "     A") STOP 3
210      case (13)
211        if (output(i) .ne. "    BC") STOP 4
212      case (14)
213        if (output(i) .ne. "   DEF") STOP 5
214    end select
215  end do
216end program main
217