gcc/testsuite/gfortran.dg/select_type_4.f90

   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 !
   6 module 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
  22 contains
  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
  94 end module poly_list
  95
  96 program 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
 174 end program main