3 ! Contributed by by Richard Maine
4 ! http://coding.derkeiler.com/Archive/Fortran/comp.lang.fortran/2006-10/msg00104.html
8 !-- Polymorphic lists using type extension.
12 type, public
:: node_type
14 class(node_type
), pointer :: next
=> null()
17 type, public
:: list_type
19 class(node_type
), pointer :: head
=> null(), tail
=> null()
24 subroutine append_node (list
, new_node
)
26 !-- Append a node to a list.
27 !-- Caller is responsible for allocating the node.
29 !---------- interface.
31 type(list_type
), intent(inout
) :: list
32 class(node_type
), target
:: new_node
34 !---------- executable code.
36 if (.not
.associated(list
%head
)) list
%head
=> new_node
37 if (associated(list
%tail
)) list
%tail
%next
=> new_node
40 end subroutine append_node
42 function first_node (list
)
44 !-- Get the first node of a list.
46 !---------- interface.
48 type(list_type
), intent(in
) :: list
49 class(node_type
), pointer :: first_node
51 !---------- executable code.
53 first_node
=> list
%head
55 end function first_node
57 function next_node (node
)
59 !-- Step to the next node of a list.
61 !---------- interface.
63 class(node_type
), target
:: node
64 class(node_type
), pointer :: next_node
66 !---------- executable code.
68 next_node
=> node
%next
70 end function next_node
72 subroutine destroy_list (list
)
74 !-- Delete (and deallocate) all the nodes of a list.
76 !---------- interface.
77 type(list_type
), intent(inout
) :: list
80 class(node_type
), pointer :: node
, next
82 !---------- executable code.
85 do while (associated(node
))
90 nullify(list
%head
, list
%tail
)
92 end subroutine destroy_list
103 type, extends(node_type
) :: real_node_type
105 end type real_node_type
107 type, extends(node_type
) :: integer_node_type
109 end type integer_node_type
111 type, extends(node_type
) :: character_node_type
113 end type character_node_type
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
121 !---------- executable code.
123 !----- Build the list.
127 call append_node(list
, real_node
)
129 allocate(integer_node
)
131 call append_node(list
, integer_node
)
134 call append_node(list
, node
)
136 allocate(character_node
)
137 character_node
%c
= "z"
138 call append_node(list
, character_node
)
142 call append_node(list
, real_node
)
144 !----- Retrieve from it.
146 node
=> first_node(list
)
149 do while (associated(node
))
152 type is (real_node_type
)
154 if (.not
.( (cnt
== 1 .and
. node
%x
== 1.23) &
155 .or
. (cnt
== 5 .and
. node
%x
== 4.56))) then
158 type is (integer_node_type
)
160 if (cnt
/= 2 .or
. node
%i
/= 42) call abort()
162 write (*,*) "Node with no data."
163 if (cnt
/= 3) call abort()
165 Write (*,*) "Some other node type."
166 if (cnt
/= 4) call abort()
169 node
=> next_node(node
)
171 if (cnt
/= 5) call abort()
172 call destroy_list(list
)
175 ! { dg-final { cleanup-modules "poly_list" } }