mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-28 18:56:06 +00:00
217 lines
5.2 KiB
Fortran
217 lines
5.2 KiB
Fortran
! { 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
|