gcc/testsuite/gfortran.dg/unlimited_polymorphic_24.f03

! { dg-do run }
!
! Copyright 2015 NVIDIA Corporation
!
! Test case for unlimited polymorphism that is derived from the article
! by Mark Leair, in the 'PGInsider':
! https://www.pgroup.com/lit/articles/insider/v3n2a2.htm
! Note that 'addValue' has been removed from the generic 'add' because
! gfortran asserts that this is ambiguous. See
! https://gcc.gnu.org/ml/fortran/2015-03/msg00002.html for a discussion.
!
module link_mod
  private
  public :: link, output, index
  character(6) :: output (14)
  integer :: index = 0
  type link
     private
     class(*), pointer :: value => null() ! value stored in link
     type(link), pointer :: next => null()! next link in list
     contains
     procedure :: getValue    ! return value pointer
     procedure :: printLinks  ! print linked list starting with this link
     procedure :: nextLink    ! return next pointer
     procedure :: setNextLink ! set next pointer
  end type link

  interface link
   procedure constructor ! construct/initialize a link
  end interface

contains

  function nextLink(this)
  class(link) :: this
  class(link), pointer :: nextLink
    nextLink => this%next
  end function nextLink

  subroutine setNextLink(this,next)
  class(link) :: this
  class(link), pointer :: next
     this%next => next
  end subroutine setNextLink

  function getValue(this)
  class(link) :: this
  class(*), pointer :: getValue
  getValue => this%value
  end function getValue

  subroutine printLink(this)
  class(link) :: this

  index = index + 1

  select type(v => this%value)
  type is (integer)
    write (output(index), '(i6)') v
  type is (character(*))
    write (output(index), '(a6)') v
  type is (real)
    write (output(index), '(f6.2)') v
  class default
    stop 'printLink: unexepected type for link'
  end select

  end subroutine printLink

  subroutine printLinks(this)
  class(link) :: this
  class(link), pointer :: curr

  call printLink(this)
  curr => this%next
  do while(associated(curr))
    call printLink(curr)
    curr => curr%next
  end do

  end subroutine

  function constructor(value, next)
    class(link),pointer :: constructor
    class(*) :: value
    class(link), pointer :: next
    allocate(constructor)
    constructor%next => next
    allocate(constructor%value, source=value)
  end function constructor

end module link_mod

module list_mod
  use link_mod
  private
  public :: list
  type list
     private
     class(link),pointer :: firstLink => null() ! first link in list
     class(link),pointer :: lastLink => null()  ! last link in list
   contains
     procedure :: printValues ! print linked list
     procedure :: addInteger  ! add integer to linked list
     procedure :: addChar     ! add character to linked list
     procedure :: addReal     ! add real to linked list
     procedure :: addValue    ! add class(*) to linked list
     procedure :: firstValue  ! return value associated with firstLink
     procedure :: isEmpty     ! return true if list is empty
     generic :: add => addInteger, addChar, addReal
  end type list

contains

  subroutine printValues(this)
    class(list) :: this

    if (.not.this%isEmpty()) then
       call this%firstLink%printLinks()
    endif
  end subroutine printValues

  subroutine addValue(this, value)
    class(list) :: this
    class(*) :: value
    class(link), pointer :: newLink

    if (.not. associated(this%firstLink)) then
       this%firstLink => link(value, this%firstLink)
       this%lastLink => this%firstLink
    else
       newLink => link(value, this%lastLink%nextLink())
       call this%lastLink%setNextLink(newLink)
       this%lastLink => newLink
    end if

  end subroutine addValue

  subroutine addInteger(this, value)
   class(list) :: this
    integer value
    class(*), allocatable :: v
    allocate(v,source=value)
    call this%addValue(v)
  end subroutine addInteger

  subroutine addChar(this, value)
    class(list) :: this
    character(*) :: value
    class(*), allocatable :: v

    allocate(v,source=value)
    call this%addValue(v)
  end subroutine addChar

  subroutine addReal(this, value)
    class(list) :: this
    real value
    class(*), allocatable :: v

    allocate(v,source=value)
    call this%addValue(v)
  end subroutine addReal

  function firstValue(this)
    class(list) :: this
    class(*), pointer :: firstValue

    firstValue => this%firstLink%getValue()

  end function firstValue

  function isEmpty(this)
    class(list) :: this
    logical isEmpty

    if (associated(this%firstLink)) then
       isEmpty = .false.
    else
       isEmpty = .true.
    endif
  end function isEmpty

end module list_mod

program main
  use link_mod, only : output
  use list_mod
  implicit none
  integer i, j
  type(list) :: my_list

  do i=1, 10
     call my_list%add(i)
  enddo
  call my_list%add(1.23)
  call my_list%add('A')
  call my_list%add('BC')
  call my_list%add('DEF')
  call my_list%printvalues()
  do i = 1, 14
    select case (i)
      case (1:10)
        read (output(i), '(i6)') j
        if (j .ne. i) STOP 1
      case (11)
        if (output(i) .ne. "  1.23") STOP 2
      case (12)
        if (output(i) .ne. "     A") STOP 3
      case (13)
        if (output(i) .ne. "    BC") STOP 4
      case (14)
        if (output(i) .ne. "   DEF") STOP 5
    end select
  end do
end program main