1! { dg-do run } 2! 3! Contributed by by Richard Maine 4! http://coding.derkeiler.com/Archive/Fortran/comp.lang.fortran/2006-10/msg00104.html 5! 6module poly_list 7 8 !-- Polymorphic lists using type extension. 9 10 implicit none 11 12 type, public :: node_type 13 private 14 class(node_type), pointer :: next => null() 15 end type node_type 16 17 type, public :: list_type 18 private 19 class(node_type), pointer :: head => null(), tail => null() 20 end type list_type 21 22contains 23 24 subroutine append_node (list, new_node) 25 26 !-- Append a node to a list. 27 !-- Caller is responsible for allocating the node. 28 29 !---------- interface. 30 31 type(list_type), intent(inout) :: list 32 class(node_type), target :: new_node 33 34 !---------- executable code. 35 36 if (.not.associated(list%head)) list%head => new_node 37 if (associated(list%tail)) list%tail%next => new_node 38 list%tail => new_node 39 return 40 end subroutine append_node 41 42 function first_node (list) 43 44 !-- Get the first node of a list. 45 46 !---------- interface. 47 48 type(list_type), intent(in) :: list 49 class(node_type), pointer :: first_node 50 51 !---------- executable code. 52 53 first_node => list%head 54 return 55 end function first_node 56 57 function next_node (node) 58 59 !-- Step to the next node of a list. 60 61 !---------- interface. 62 63 class(node_type), target :: node 64 class(node_type), pointer :: next_node 65 66 !---------- executable code. 67 68 next_node => node%next 69 return 70 end function next_node 71 72 subroutine destroy_list (list) 73 74 !-- Delete (and deallocate) all the nodes of a list. 75 76 !---------- interface. 77 type(list_type), intent(inout) :: list 78 79 !---------- local. 80 class(node_type), pointer :: node, next 81 82 !---------- executable code. 83 84 node => list%head 85 do while (associated(node)) 86 next => node%next 87 deallocate(node) 88 node => next 89 end do 90 nullify(list%head, list%tail) 91 return 92 end subroutine destroy_list 93 94end module poly_list 95 96program main 97 98 use poly_list 99 100 implicit none 101 integer :: cnt 102 103 type, extends(node_type) :: real_node_type 104 real :: x 105 end type real_node_type 106 107 type, extends(node_type) :: integer_node_type 108 integer :: i 109 end type integer_node_type 110 111 type, extends(node_type) :: character_node_type 112 character(1) :: c 113 end type character_node_type 114 115 type(list_type) :: list 116 class(node_type), pointer :: node 117 type(integer_node_type), pointer :: integer_node 118 type(real_node_type), pointer :: real_node 119 type(character_node_type), pointer :: character_node 120 121 !---------- executable code. 122 123 !----- Build the list. 124 125 allocate(real_node) 126 real_node%x = 1.23 127 call append_node(list, real_node) 128 129 allocate(integer_node) 130 integer_node%i = 42 131 call append_node(list, integer_node) 132 133 allocate(node) 134 call append_node(list, node) 135 136 allocate(character_node) 137 character_node%c = "z" 138 call append_node(list, character_node) 139 140 allocate(real_node) 141 real_node%x = 4.56 142 call append_node(list, real_node) 143 144 !----- Retrieve from it. 145 146 node => first_node(list) 147 148 cnt = 0 149 do while (associated(node)) 150 cnt = cnt + 1 151 select type (node) 152 type is (real_node_type) 153 write (*,*) node%x 154 if (.not.( (cnt == 1 .and. node%x == 1.23) & 155 .or. (cnt == 5 .and. node%x == 4.56))) then 156 call abort() 157 end if 158 type is (integer_node_type) 159 write (*,*) node%i 160 if (cnt /= 2 .or. node%i /= 42) call abort() 161 type is (node_type) 162 write (*,*) "Node with no data." 163 if (cnt /= 3) call abort() 164 class default 165 Write (*,*) "Some other node type." 166 if (cnt /= 4) call abort() 167 end select 168 169 node => next_node(node) 170 end do 171 if (cnt /= 5) call abort() 172 call destroy_list(list) 173 stop 174end program main 175