Following a previous question I had (Fortran TYPE inheritance on runtime (declared by user)), I am using a factory method to generate an array of different types. Below is a simplified version of what I'm doing,
module multiarray
use iso_fortran_env, only: real64
implicit none
integer, parameter :: dp = real64
! abstract list type
type, abstract :: list
contains
procedure(in), deferred, pass(self) :: addval ! add a variable
procedure(out), deferred, pass(self) :: getval ! extract variable
end type
abstract interface
subroutine in(self,val)
import :: list
implicit none
class(list), intent(inout) :: self
class(*), intent(in) :: val
end subroutine
subroutine out(self,val)
import :: list
implicit none
class(list), intent(in) :: self
class(*), intent(out) :: val
end subroutine
end interface
! real(dp) element extension
type, extends(list) :: real_num
real(dp) :: var
contains
procedure, pass(self) :: addval => addreal
procedure, pass(self) :: getval => getreal
end type
! similar for character, logical, etc types
...
! wrapper
type wrapper
class(list), ALLOCATABLE :: arg
end type
contains
! real(dp) subroutines
subroutine addreal(self,val)
implicit none
class(real_num), intent(inout) :: self
class(*), intent(in) :: val
select type(val)
type is (real(dp))
self%var = val
end select
end subroutine
subroutine getreal(self,val)
implicit none
class(real_num), intent(in) :: self
class(*), intent(out) :: val
select type(val)
type is (real(dp))
val = self%var
end select
end subroutine
! similar for character, logical, etc types
...
! factory method
function get_list(val) result(pt)
class(*), intent(in) :: val
class(list), allocatable :: pt
select type(val)
type is (real(dp))
allocate(real_num :: pt)
type is (character(*))
...
end select
end function
end module
I use the wrapper type to generate an allocatable array of type list
type(wrapper) :: A(5)
real(dp) :: x
A(1)%arg = get_list(90.d0) ! Set A(1) as type real
call A(1)%arg%addval(90.d0) ! A(1) is a real of value 90
call A(1)%arg%getval(x) ! set x = A(1) to use elsewhere
The variable var is defined as a generic class in the abstract interface, it can be of real, character, logical, etc type. I then use a select type construct to match the addval=>addreal subroutine argument since var is of type class(*) in the abstract interface.
Is there a way to define an interface inside the abstract interface (nested), in a way that I don't need to have the select type in addreal (since I already know it's input needs to be a real type)? Or is there a better way, simpler way, to achieve what I'm trying to do with the variable type array? Thanks!
I think you don't want to have both class(*) inputs and an abstract base class. I think you want to have either one:
class(*)) element types, for example, a key-value pair in a dictionary;In your case it seems you want maximum flexibility, I would vote for having a unique container class and making usage of class(*), like in the following example I've just made up:
! FP 2022-07-25
module myList
use iso_fortran_env
implicit none
type, public :: listElement
class(*), allocatable :: x
contains
procedure :: set
procedure :: get_any
procedure :: get_typed
procedure, private :: print
generic :: write(formatted) => print
end type listElement
contains
! Map accepted types
elemental logical function isAccepted(val)
class(*), intent(in) :: val
select type (input=>val)
type is (real(real32)); isAccepted = .true.
type is (character(*)); isAccepted = .true.
class default; isAccepted = .false.
end select
end function isAccepted
! Print value
subroutine print(this, unit, iotype, v_list, iostat, iomsg)
class(listElement), intent(in) :: this
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
if (.not.allocated(this%x)) then
write(unit,*,iostat=iostat) 'null'
else
select type (myVar => this%x)
type is (real(real32)); write(unit,*,iostat=iostat) myVar
type is (character(*)); write(unit,*,iostat=iostat) myVar
class default; write(unit,*,iostat=iostat) "ERROR"
end select
endif
end subroutine print
subroutine set(this,val)
class(listElement), intent(inout) :: this
class(*), intent(in) :: val
integer :: ierr
deallocate(this%x,stat=ierr) ! force deallocate
allocate(this%x,source=val)
end subroutine set
! Can be anything, but "val" must be declared "class(*), allocatable"
subroutine get_any(this,val)
class(listElement), intent(in) :: this
class(*), intent(out), allocatable :: val
allocate(val,source=this%x)
end subroutine get_any
subroutine get_typed(this,val)
class(listElement), intent(in) :: this
class(*), intent(out) :: val ! has a type that can't change
if (.not.isAccepted(val)) stop ' trying to return value to a class thats not supported '
if (.not.allocated(this%x)) return ! will return garbage
select type (outVal => val)
type is (real(real32));
select type (thisVal => this%x)
type is (real(real32)); outVal = thisVal
type is (real(real64)); outVal = real(thisVal,real32)
class default; stop 'error trying to convert list element to real32'
end select
type is (character(*));
select type (thisVal => this%x)
type is (character(*)); outVal = trim(thisVal)
class default; stop 'error trying to convert list element to character'
end select
class default
stop 'trying to return value to a class thats not accepted '
end select
end subroutine get_typed
end module myList
program tryList
use myList
implicit none
type(listElement) :: A(5)
integer :: i
character(255) myChar
real(real32) :: r32
real(real64) :: r64
call A(1)%set(123.45)
call A(2)%set("hello world!")
call A(3)%set(123.45d0)
do i=1,3
print *, 'A(',i,')=',A(i)
end do
call A(1)%get_typed(r64); print *, 'r64=',r64
call A(1)%get_typed(r32); print *, 'r32=',r32
call A(2)%get_typed(myChar); print *, 'myChar=',myChar
call A(2)%get_typed(r32) ! stop on error
end program
Notice that:
class(*)), but if you want to use the fully polymorphic interface, the input variable must be defined as class(*), allocatable anywhere else, so, not exactly handy.enumerator type that help you map/handle all types you want to be contained, this example is just a stub.