Why even use select type at all? If you find yourself reaching for select type, it typically means the type hierarchy doesn’t fulfil the Liskov Substitution Principle. In this particular case I think there are better options available:
For the polymorphic “container” type that @rwmsu showed,
type, abstract :: base_t
! some basic data
contains
! a small number of deferred procedures
end type
type :: base_array_t
class(base_t), allocatable :: vals ! polymorphic component (!)
end type
if the goal is to copy the polymorphic %vals component, select type is not needed for example to swap two values, and intrinsic assignment can be used instead:
type(base_array_t), allocatable :: base_array(`:`)
type(child1_t) :: achild1
type(child2_t) :: achild2
allocate(base_array(2))
allocate(base_array(1)%vals, source=achild1)
allocate(base_array(2)%vals, source=achild2)
! Swap the contents of elements 1 and 2
tmp = array(1)%vals
array(1)%vals = array(2)%vals
array(2)%vals = tmp
! The dynamic types have changed
print *, same_type_as(array(1)%vals, achild2), same_type_as(array(2)%vals, achild1)
Imagine there were three elements, two of which had the same type,
allocate(base_array(1)%vals, source=achild1) ! child1_t
allocate(base_array(2)%vals, source=achild2) ! child2_t
allocate(base_array(3)%vals, source=child1_t(...)) ! child1_t
! copy value of element 3 into element 1
base_array(1)%vals = base_array(3)%vals
According to MRC (“the red book”), Section 15.5, page 300, this is permitted and on top
if the variable is already allocated with the correct type (and shape and deferred type parameter values, if applicable), no reallocation is done; …
The copy itself occurs (second paragraph of Section 15.5)
just as in normal assignment (with shallow copying for any pointer components and deep copying for any allocatable components)
In addition, in section 6.11, page 114, on allocatable components of derived types, it is stated that
if the component of a variable is already allocated with the same shape, the compiler may choose to avoid the overheads of deallocation and reallocation. (emphasis mine)
So in theory, if the type and dimensions match, this should not be that expensive. You can verify this “runtime” invariant on the dynamic type holds using the intrinsic same_type_as(a,b) function and issue an error stop if it fails.
In the more complicated case, where the types in the hierarchy may contain pointer components, and deep copies are desired, introducing an abstract copy operation, as in the prototype pattern, is one of the possible solutions:
type, abstract :: base_t
! some basic data
contains
! a small number of deferred procedures
procedure(base_clone), deferred :: clone ! <- prototype pattern
end type
interface
function base_clone(this) result(clone)
import base_t
class(base_t), intent(in) :: this
class(base_t), allocatable :: clone
end function
end interface
You’d use it like this:
class(base_t), allocatable :: a, b
a = child1_t(...)
b = a%clone() ! a knows how to make a deep copy of itself
A good compiler should be able to elide unnecessary allocations or assignments (copies) of the type components in this case (one caveat is if you also need a finalizer, then things will be slightly different).
In contrast to select type, where the types must be known in advance, the prototype pattern would allow you to dynamically load a plug-in. Here is a rough sketch:
module base_module
implicit none
public
type, abstract :: base_t
! some basic data
contains
! a small number of deferred procedures
procedure(base_clone), deferred :: clone ! <- prototype pattern
end type
interface
function base_clone(this) result(clone)
import base_t
class(base_t), intent(in) :: this
class(base_t), allocatable :: clone
end function
end interface
end module
module extension
use, intrinsic :: iso_c_binding
use base_module, only: base_t
implicit none
private
public :: create_from_plugin
type, extends(base_t) :: child3
type(c_ptr) :: handle = c_null_ptr
contains
! deferred procedures which call strategies
! implemented in the dynamically loaded plugin
procedure :: clone => plugin_clone
end type
contains
function create_from_plugin(name) result(this)
character(len=*), intent(in) :: name
class(base_t), allocatable :: this
interface
function dlopen(name,flags) bind(c,name="dlopen")
import c_char, c_ptr, c_int
character(kind=c_char), intent(in) :: name(*)
integer(c_int), value :: flags
type(c_ptr) :: dlopen
end function
end interface
this = child3(dlopen(trim(name)//c_null_char, flags=0_c_int))
end function
function plugin_clone(this) result(clone)
class(child3), intent(in) :: this
class(base_t), allocatable :: clone
type(child3), allocatable :: tmp
interface
function dlsym(handle,symbol) bind(c,name="dlsym")
import c_char, c_ptr, c_int, c_funptr
type(c_ptr), value :: handle
character(kind=c_char), intent(in) :: symbol(*)
type(c_funptr) :: dlsym
end function
end interface
! Call procedure in libhandle
type(c_funptr) :: func
procedure(), pointer :: ffunc
print *, "mock clone method"
func = dlsym(this%handle,"__clone_procedure")
! call c_f_procpointer(func,ffunc)
! call ffunc(...)
! Use "copy and swap" idiom to populate the object
allocate(tmp)
tmp%handle = this%handle ! shallow copy library handle
call move_alloc(from=tmp,to=clone)
end function
end module
program main
use base_module
use extension
implicit none
class(base_t), allocatable :: a, b
a = create_from_plugin("my_plugin.so") ! the dynamic type is private (!)
b = a%clone()
end program