gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03

   1 ! { dg-do run }
   2 !
   3 ! Copyright 2015 NVIDIA Corporation
   4 !
   5 ! Test case for unlimited polymorphism that is derived from the article
   6 ! by Mark Leair, in the 'PGInsider':
   7 ! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
   8 ! Note that 'addValue' has been removed from the generic 'add' because
   9 ! gfortran asserts that this is ambiguous. See
  10 ! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
  11 !
  12 module link_mod
  13   private
  14   public :: link, output, index
  15   character(6) :: output (14)
  16   integer :: index = 0
  17   type link
  18      private
  19      class(*), pointer :: value => null() ! value stored in link
  20      type(link), pointer :: next => null()! next link in list
  21      contains
  22      procedure :: getValue    ! return value pointer
  23      procedure :: printLinks  ! print linked list starting with this link
  24      procedure :: nextLink    ! return next pointer
  25      procedure :: setNextLink ! set next pointer
  26   end type link
  27
  28   interface link
  29    procedure constructor ! construct/initialize a link
  30   end interface
  31
  32 contains
  33
  34   function nextLink(this)
  35   class(link) :: this
  36   class(link), pointer :: nextLink
  37     nextLink => this%next
  38   end function nextLink
  39
  40   subroutine setNextLink(this,next)
  41   class(link) :: this
  42   class(link), pointer :: next
  43      this%next => next
  44   end subroutine setNextLink
  45
  46   function getValue(this)
  47   class(link) :: this
  48   class(*), pointer :: getValue
  49   getValue => this%value
  50   end function getValue
  51
  52   subroutine printLink(this)
  53   class(link) :: this
  54
  55   index = index + 1
  56
  57   select type(v => this%value)
  58   type is (integer)
  59     write (output(index), '(i6)') v
  60   type is (character(*))
  61     write (output(index), '(a6)') v
  62   type is (real)
  63     write (output(index), '(f6.2)') v
  64   class default
  65     stop 'printLink: unexepected type for link'
  66   end select
  67
  68   end subroutine printLink
  69
  70   subroutine printLinks(this)
  71   class(link) :: this
  72   class(link), pointer :: curr
  73
  74   call printLink(this)
  75   curr => this%next
  76   do while(associated(curr))
  77     call printLink(curr)
  78     curr => curr%next
  79   end do
  80
  81   end subroutine
  82
  83   function constructor(value, next)
  84     class(link),pointer :: constructor
  85     class(*) :: value
  86     class(link), pointer :: next
  87     allocate(constructor)
  88     constructor%next => next
  89     allocate(constructor%value, source=value)
  90   end function constructor
  91
  92 end module link_mod
  93
  94 module list_mod
  95   use link_mod
  96   private
  97   public :: list
  98   type list
  99      private
 100      class(link),pointer :: firstLink => null() ! first link in list
 101      class(link),pointer :: lastLink => null()  ! last link in list
 102    contains
 103      procedure :: printValues ! print linked list
 104      procedure :: addInteger  ! add integer to linked list
 105      procedure :: addChar     ! add character to linked list
 106      procedure :: addReal     ! add real to linked list
 107      procedure :: addValue    ! add class(*) to linked list
 108      procedure :: firstValue  ! return value associated with firstLink
 109      procedure :: isEmpty     ! return true if list is empty
 110      generic :: add => addInteger, addChar, addReal
 111   end type list
 112
 113 contains
 114
 115   subroutine printValues(this)
 116     class(list) :: this
 117
 118     if (.not.this%isEmpty()) then
 119        call this%firstLink%printLinks()
 120     endif
 121   end subroutine printValues
 122
 123   subroutine addValue(this, value)
 124     class(list) :: this
 125     class(*) :: value
 126     class(link), pointer :: newLink
 127
 128     if (.not. associated(this%firstLink)) then
 129        this%firstLink => link(value, this%firstLink)
 130        this%lastLink => this%firstLink
 131     else
 132        newLink => link(value, this%lastLink%nextLink())
 133        call this%lastLink%setNextLink(newLink)
 134        this%lastLink => newLink
 135     end if
 136
 137   end subroutine addValue
 138
 139   subroutine addInteger(this, value)
 140    class(list) :: this
 141     integer value
 142     class(*), allocatable :: v
 143     allocate(v,source=value)
 144     call this%addValue(v)
 145   end subroutine addInteger
 146
 147   subroutine addChar(this, value)
 148     class(list) :: this
 149     character(*) :: value
 150     class(*), allocatable :: v
 151
 152     allocate(v,source=value)
 153     call this%addValue(v)
 154   end subroutine addChar
 155
 156   subroutine addReal(this, value)
 157     class(list) :: this
 158     real value
 159     class(*), allocatable :: v
 160
 161     allocate(v,source=value)
 162     call this%addValue(v)
 163   end subroutine addReal
 164
 165   function firstValue(this)
 166     class(list) :: this
 167     class(*), pointer :: firstValue
 168
 169     firstValue => this%firstLink%getValue()
 170
 171   end function firstValue
 172
 173   function isEmpty(this)
 174     class(list) :: this
 175     logical isEmpty
 176
 177     if (associated(this%firstLink)) then
 178        isEmpty = .false.
 179     else
 180        isEmpty = .true.
 181     endif
 182   end function isEmpty
 183
 184 end module list_mod
 185
 186 program main
 187   use link_mod, only : output
 188   use list_mod
 189   implicit none
 190   integer i, j
 191   type(list) :: my_list
 192
 193   do i=1, 10
 194      call my_list%add(i)
 195   enddo
 196   call my_list%add(1.23)
 197   call my_list%add('A')
 198   call my_list%add('BC')
 199   call my_list%add('DEF')
 200   call my_list%printvalues()
 201   do i = 1, 14
 202     select case (i)
 203       case (1:10)
 204         read (output(i), '(i6)') j
 205         if (j .ne. i) STOP 1
 206       case (11)
 207         if (output(i) .ne. "  1.23") STOP 2
 208       case (12)
 209         if (output(i) .ne. "     A") STOP 3
 210       case (13)
 211         if (output(i) .ne. "    BC") STOP 4
 212       case (14)
 213         if (output(i) .ne. "   DEF") STOP 5
 214     end select
 215   end do
 216 end program main