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