Fortran 95 による1方向リンクト・リスト (singly linked list)

Fortran 95 で1方向リンクト・リスト (singly linked list) を書く場合、 データを持たないルートノードを用いて、それを「list」とするのが便利。


Contents:

凡例

□□□  … データフィールド
   P … ポインタ (リンク)
□□□P … ノード
空空空P … データフィールドに意味のあるものが入っていないノード
□□□N … ポインタがnullifyされているノード

初期状態

空空空N … ルートノード「list」

リスト

空空空P … ルートノード「list」
┌──┘
↓
□□□P … ノードその1
┌──┘
↓
□□□P … ノードその2
┌──┘
↓
□□□N … ノードその3

node_module.f

! node_module.f -*-f90-*-
! Time-stamp: <2007-01-05 18:35:10 t-nissie>
! Author: Takeshi NISHIMATSU
! Disadvantage: Copy in list_unshift() and list_push().
!!
module Node_module
  implicit none
  type Node_type
     character(len=100)       :: str100 = ''
     type(Node_type), pointer :: next => null()
  end type Node_type

!!! Fortran 2003 feature
! type extends(Node_type) :: List_type
! contains
!    final :: list_destruct
! end type List_type

contains
  ! destructor
  subroutine list_destruct(list)
    implicit none
    type(Node_type), intent(inout) :: list
    type(Node_type), pointer :: current_node, next_node
    next_node => list%next
    do while (associated(next_node))
       current_node => next_node
       next_node => next_node%next
       deallocate(current_node)
    end do
    nullify(list%next)   ! For reuse of the list.
  end subroutine list_destruct

  ! add a node to the head of the list
  subroutine list_unshift(list, unshift)
    implicit none
    type(Node_type), intent(inout) :: list
    type(Node_type), intent(in)    :: unshift
    type(Node_type), pointer :: tmp
    allocate(tmp)
    tmp = unshift   ! Copy.
    tmp%next => list%next
    list%next => tmp
  end subroutine list_unshift

  ! add a node to the tail of the list
  subroutine list_push(list, push)
    implicit none
    type(Node_type), target, intent(inout) :: list
    type(Node_type), intent(in) :: push
    type(Node_type), pointer :: p_node
    p_node => list
    do while (associated(p_node%next))
       p_node => p_node%next
    end do
    allocate(p_node%next)     ! Insert a new node.
    p_node%next = push        ! Copy.
    nullify(p_node%next%next)
  end subroutine list_push
!

  ! remove a node from the head of the list
  function list_shift(list)
    implicit none
    type(Node_type), pointer :: list_shift
    type(Node_type), intent(inout) :: list
    if (.not.associated(list%next)) then
       nullify(list_shift)
    else
       list_shift => list%next
       list%next => list%next%next
    end if
  end function list_shift

  ! remove a node from the tail of the list
  function list_pop(list)
    implicit none
    type(Node_type), pointer :: list_pop
    type(Node_type), target, intent(in)  :: list
    type(Node_type), pointer :: p_node
    if (.not.associated(list%next)) then
       nullify(list_pop)
    else
       p_node => list
       do while (associated(p_node%next%next))
          p_node => p_node%next
       end do
       list_pop => p_node%next
       nullify(p_node%next)
    end if
  end function list_pop

  ! returns length of the list
  function list_count(list)
    implicit none
    integer list_count
    type(Node_type), intent(in) :: list
    type(Node_type), pointer :: p_node
    list_count = 0
    p_node => list%next
    do while (associated(p_node))
       list_count = list_count + 1
       p_node => p_node%next
    end do
  end function list_count
!
  ! iterator
  ! usage:
  !   p => list
  !   do while(list_each(p))
  !      :
  !   end do
  logical function list_each(p_node)
    implicit none
    type(Node_type), pointer, intent(inout) :: p_node
    p_node => p_node%next
    list_each = associated(p_node)
  end function list_each

  ! iterator
  ! usage:
  !   i_node => list
  !   i=0
  !   do while(list_each_with_index(i_node,i))
  !      :
  !   end do
  logical function list_each_with_index(i_node,i)
    implicit none
    type(Node_type), pointer, intent(inout) :: i_node
    integer, intent(inout) :: i
    i_node => i_node%next
    i = i + 1
    list_each_with_index = associated(i_node)
  end function list_each_with_index
end module Node_module

linkedlist.f

使用例 兼 unit testing

! linkedlist.f -*-f90-*-
! Time-stamp: <2007-01-05 18:37:16 t-nissie>
! Author: Takeshi NISHIMATSU
!!
program linkedlist
  use Node_module
  implicit none
  type(Node_type), target  :: list
  type(Node_type), pointer :: p_node, i_node, j_node
  integer i,j

  write(6,'(a,i1)') 'list_count = ', list_count(list)

  p_node => list_pop(list)
  if (associated(p_node)) stop 'There is something wrong in list_pop.'

  p_node => list_shift(list)
  if (associated(p_node)) stop 'There is something wrong in list_shift.'

  call list_push(list, Node_type('abcdefg'))
  call list_push(list, Node_type('hijklmn'))
  call list_push(list, Node_type('opqrstu'))

  write(6,'(a,i1)') 'list_count = ', list_count(list)

  p_node => list
  do while(list_each(p_node))
     write(6,'(a)') trim(p_node%str100)
  end do

  p_node => list_pop(list)
  write(6,'(2a)') 'popped node = ', trim(p_node%str100)
  deallocate(p_node)

  j_node => list
  j=0
  do while(list_each_with_index(j_node,j))
     i_node => list
     i=0
     do while(list_each_with_index(i_node,i))
        write(6,'(i1i2,4a)') i, j, &
             ' ', trim(i_node%str100), &
             ' ', trim(j_node%str100)
     end do
  end do

  call list_unshift(list, Node_type('ABCDEFG'))

  i_node => list
  i=0
  do while(list_each_with_index(i_node,i))
     write(6,'(i1,2a)') i, ' ', trim(i_node%str100)
  end do

  p_node => list_shift(list)
  write(6,'(2a)') 'shifted node = ', trim(p_node%str100)
  deallocate(p_node)

  call list_destruct(list)

  write(6,'(a,i1)') 'list_count = ', list_count(list)
  call list_push(list, Node_type('123456'))
  call list_destruct(list)   ! For Fortran 2003, remove this line and check 'final'.
end program linkedlist

Makefile

# Makefile for list
# Time-stamp: <2007-01-07 09:39:44 t-nissie>
# Author: Takeshi NISHIMATSU
##

FC = g95
FFLAGS = -Wall -ffree-form -g -O1

#FC = ifort
#FFLAGS = -FR

linkedlist: linkedlist.o node_module.o
	$(FC) $(FFLAGS) -o $@ $^

linkedlist.o: node_module.o

index.html: README style.css
	ulwmul2html.rb $< > $@


# Additional rules for the pretty printing:
%.pdf: %.ps
	ps2pdf -sPAPERSIZE=letter $< $@

%.ps: %.f
	LANG=C a2ps --prologue=color --portrait --columns=1 \
	--margin=3 --borders=off --medium=Letter\
	-f 10.5 --pretty-print=for90-free -o - $< | PsDuplex > $@

clean:
	rm -f *.ps *.pdf core *.o *.mod linkedlist