*
Den Thread habe ich irgend wie übersehen.
Da ich keine Motivation hatte, den x-ten Aufguss in C zu machen. Das ganze einmal in Fortran. Das auskommentierte ist untested.
module doubly_linked_list
use iso_fortran_env
implicit none
private
public :: node, list, node_create
type :: node
class(*), allocatable, public :: value
class (node), pointer, private :: prevptr => null(), nextptr => null()
contains
procedure, pass, non_overridable :: next => node_next
procedure, pass, non_overridable :: prev => node_prev
final :: node_destruct
end type node
type :: list
class (node), pointer, private :: headptr => null(), tailptr => null()
contains
procedure, pass, non_overridable :: add_tail => list_add_tail
procedure, pass, non_overridable :: add_head => list_add_head
procedure, pass, non_overridable :: delete => list_delete
!procedure, pass, non_overridable :: add_before_node => list_add_before_node
!procedure, pass, non_overridable :: add_after_node => list_add_after_node
procedure, pass, non_overridable :: head => list_head
procedure, pass, non_overridable :: tail => list_tail
final :: list_destruct
end type list
contains
function node_create (data) result (new_node)
class (node), pointer :: new_node
class (*), intent(in) :: data
integer :: error
new_node => null()
allocate (new_node, STAT=error)
if (0 /= error) then
write (error_unit,*) 'cannot allocate'
stop
end if
allocate (new_node%value, STAT=error, SOURCE=data)
if (0 /= error) then
write (error_unit,*) 'cannot allocate'
stop
end if
end function node_create
function node_next (this) result (next_node)
class (node), pointer :: next_node
class (node) :: this
next_node => this%nextptr
end function node_next
function node_prev (this) result (prev_node)
class (node), pointer :: prev_node
class (node) :: this
prev_node => this%prevptr
end function node_prev
subroutine node_destruct (this)
type (node) :: this
this%nextptr => null()
this%prevptr => null()
deallocate(this%value)
end subroutine node_destruct
subroutine list_add_tail (this, node_pointer)
class (list) :: this
class (node), pointer, intent(in) :: node_pointer
if (.NOT.associated(this%tailptr)) then
this%tailptr => node_pointer
this%headptr => node_pointer
else
node_pointer%prevptr => this%tailptr
node_pointer%nextptr => null()
this%tailptr => node_pointer
end if
end subroutine list_add_tail
subroutine list_add_head (this, node_pointer)
class (list) :: this
class (node), pointer, intent (in) :: node_pointer
if (.NOT.associated(this%headptr)) then
this%headptr => node_pointer
this%tailptr => node_pointer
else
node_pointer%nextptr => this%headptr
node_pointer%prevptr => null()
this%headptr => node_pointer
end if
end subroutine list_add_head
subroutine list_delete (this)
class (list) :: this
type (node), pointer :: p1 => null(), p2 => null()
p1 => this%headptr
if (associated(p1)) then
do
p2 => p1%nextptr
p1%nextptr => null()
p1%prevptr => null()
deallocate (p1)
if (.NOT.associated(p2)) then
exit
end if
p1 => p2
end do
this%headptr => null()
this%tailptr => null()
end if
end subroutine list_delete
subroutine list_destruct (this)
type (list) :: this
call this%delete
end subroutine list_destruct
! subroutine list_add_before_node (this, position, object)
! class (list) :: this
! class (node), pointer, intent(in) :: position, object
! object%prevptr => position%prevptr
! object%nextptr => position
! if (.NOT.associated(position%prevptr)) then
! this%headptr => object
! end if
! position%prevptr => object
! end subroutine list_add_before_node
! subroutine list_add_after_node (this, position, object)
! class (list) :: this
! class (node), pointer, intent(in) :: position, object
! object%nextptr => position%nextptr
! object%prevptr => position
! if (.NOT.associated(position%nextptr)) then
! this%tailptr => object
! end if
! position%nextptr => object
! end subroutine list_add_after_node
function list_head (this) result (node_ptr)
class (list) :: this
class (node), pointer :: node_ptr
node_ptr => this%headptr
end function list_head
function list_tail (this) result (node_ptr)
class (list) :: this
class (node), pointer :: node_ptr
node_ptr => this%tailptr
end function list_tail
end module doubly_linked_list
Und ein kurzes Testprogramm was die Nuutzung des Moduls verdeutlicht bzw. es rudimentär testet.
program doubly_linked_list_test
implicit none
type :: my_data
integer :: number
integer :: serial
end type my_data
type :: my_data2
integer:: code
end type my_data2
call main
contains
subroutine main
use doubly_linked_list
use iso_fortran_env
implicit none
type (my_data) :: data1, data2
type (my_data2) :: data3
type (list) :: my_list
type (node), pointer :: a_node
data1%number = 1
data1%serial = 1
data2%number = 1
data2%serial = 2
data3%code = -5
a_node => node_create (data1)
call my_list%add_head (a_node)
a_node => null()
a_node => node_create (data2)
call my_list%add_head (a_node)
a_node => null()
a_node => node_create (data3)
call my_list%add_head (a_node)
a_node => my_list%head ()
a_node => null()
data1%serial = 3
a_node => node_create (data1)
call my_list%add_tail (a_node)
end subroutine main
end program doubly_linked_list_test
