|
111
|
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 !
|
|
|
12 module 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
|
|
|
32 contains
|
|
|
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
|
|
|
92 end module link_mod
|
|
|
93
|
|
|
94 module 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
|
|
|
113 contains
|
|
|
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
|
|
|
184 end module list_mod
|
|
|
185
|
|
|
186 program 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
|
|
131
|
205 if (j .ne. i) STOP 1
|
|
111
|
206 case (11)
|
|
131
|
207 if (output(i) .ne. " 1.23") STOP 2
|
|
111
|
208 case (12)
|
|
131
|
209 if (output(i) .ne. " A") STOP 3
|
|
111
|
210 case (13)
|
|
131
|
211 if (output(i) .ne. " BC") STOP 4
|
|
111
|
212 case (14)
|
|
131
|
213 if (output(i) .ne. " DEF") STOP 5
|
|
111
|
214 end select
|
|
|
215 end do
|
|
|
216 end program main
|
