Deep copy of unlimited polymorphism

Deep copy of unlimited polymorphism

I would like clone (deep copy) instance of some object to unlimited polymorphic object.

I am using sourced allocation but it does not do a deep copy. I have tried to overload assignment operator on type but it did not help.

Here is an example program:

module A_m

	  implicit none

	  private
  type, public :: A_t

	  private

	    real, pointer :: r1 => null()

	  contains

	    procedure :: SetR1

	    procedure :: GetR1

	    procedure :: ChangeR1

	    procedure :: AssignmentOperator

	    generic   ::  assignment(=) => AssignmentOperator

	  end type A_t
  integer, protected, public, save :: counter = 0
contains
  subroutine SetR1(this, r1)

	    class(A_t), intent(inout) :: this

	    real, target, intent(in)  :: r1
    if (associated(this%r1)) deallocate(this%r1)

	    allocate(this%r1, source=r1)
  end subroutine SetR1
  function GetR1(this) result(r1)

	    class(A_t), intent(inout) :: this

	    real                      :: r1
    r1 = -1

	    if (associated(this%r1)) r1 = this%r1
  end function GetR1
  subroutine ChangeR1(this, r1)

	    class(A_t), intent(inout) :: this

	    real, target, intent(in)  :: r1
    if (associated(this%r1)) this%r1 = r1
  end subroutine ChangeR1
  subroutine AssignmentOperator(dest, source)

	    class(A_t), intent(out) :: dest

	    class(A_t), intent(in)  :: source
    counter = counter + 1

	    if (associated(source%r1)) call dest%SetR1(source%r1)
  end subroutine AssignmentOperator
end module A_m

	  
program ClonningClassStar

	  use A_m

	  implicit none
  real, target      :: r1

	  real, target      :: anotherR1
  type(A_t), target :: a

	  type(A_t), target :: b

	  class(*), pointer :: cUnlimited
  r1 = 10

	  anotherR1 = 9

	  call a%SetR1(r1)
  call DeepCopyAttempt(cUnlimited, a)
  ! WORKAROUND 1: workaround to make a deep copy. Yet would like to avoid it..

	  ! allocate(cUnlimited, mold=a)

	  ! select type(cUnlimited)

	  !   type is (A_t)

	  !     cUnlimited = a

	  ! end select

	  

	  b = a

	  

	  call a%ChangeR1(anotherR1)
  if (a%GetR1() /= 9)  print *, 'error: a value expected to be 9, actual value = ', a%GetR1()

	  if (b%GetR1() /= 10) print *, 'error: b value expected to be 10, actual value = ', b%GetR1()
  select type(c => cUnlimited)

	    type is (A_t)

	      if (c%GetR1() /= 10) print *, 'error: c value expected to be 10, actual value = ', c%GetR1()

	  end select
  if (counter /= 2) print *, 'error: assignment operator counter expected to be 2, actual value = ', counter
  contains

	  

	    subroutine DeepCopyAttempt(dst, source)

	      class(*), pointer, intent(out)  :: dst

	      class(*), intent(in)            :: source

	      allocate(dst, source=source)

	    end subroutine DeepCopyAttempt
end program ClonningClassStar

The program prints two "error" messages, compiler's version is 13.1.3.198 Build 20130607

Is it possible to call user-defined assignment operator when using sourced allocation (see DeepCopyAttempt subroutine, for example)?

One of the option is to use "WORKAROUND 1" from the example program. But it does not work for unlimited polymorphic objects. Say, I want to implement generic container using unlimited polymorphism. I do not know types which will be used in the container, so it is not possible to make deep copies using "WORKAROUND 1". 

 

 

2 posts / novo 0
Último post
Para obter mais informações sobre otimizações de compiladores, consulte Aviso sobre otimizações.

I think it does make the deep copy, However, you seem to be expecting that your defined assignment procedure will be called as a result of the ALLOCATE with SOURCE= - that's not what the standard says. I admit that the wording here is rather obscure, but it says "the value of allocate-object becomes the value provided". Note that it does not say "according to the rules of intrinsic assignment" nor that defined assignment is used. It literally makes a copy, including a copy of any pointers.

I tried this program with 14.0.2 and got the results I expected.

Steve

Faça login para deixar um comentário.