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