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