[Bug fortran/57843] [OOP] Polymorphic assignment for derived type is resolved with parent's generic instead of its own

["janus at gcc dot gnu.org" <gcc-bugzilla at gcc dot gnu dot org>]

http://gcc.gnu.org/bugzilla/show_bug.cgi?id=57843

janus at gcc dot gnu.org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
             Status|UNCONFIRMED                 |NEW
   Last reconfirmed|                            |2013-08-20
     Ever confirmed|0                           |1

--- Comment #4 from janus at gcc dot gnu.org ---
(In reply to janus from comment #3)
> Unfortunately it gives the same output as comment 2, which I think may
> indeed be a bug in gfortran!

Looking at the dump produced by -fdump-tree-original, it seems the problem is
that the assignments are translated into static calls to 'assign_itemtype'
instead of polymorphic calls to 'table._vptr->the_assignment (...)'.

I also checked that the problem seems to be specific to the assignment
operator. Using a generic type-bound procedure 'assign' (as below) gives the
expected output:


module mod1
  implicit none
  type :: itemType
  contains
    procedure :: the_assignment => assign_itemType
    generic :: assign => the_assignment
  end type
contains
  subroutine assign_itemType(left, right)
    class(itemType), intent(OUT) :: left
    class(itemType), intent(IN) :: right
    print *, 'what am I doing here?'
  end subroutine
end module

module mod2
  use mod1
  implicit none
  type, extends(itemType) :: myItem
    character(3) :: name = ''
  contains
    procedure :: the_assignment => assign_myItem
  end type
contains
  subroutine assign_myItem(left, right)
    class(myItem), intent(OUT) :: left
    class(itemType), intent(IN) :: right
    print *, 'this is right'
    select type (right)
    type is (myItem)
      left%name = right%name
    end select
  end subroutine
end module


program test_assign

  use mod2
  implicit none

  integer :: i, j, n
  class(itemType), allocatable :: table(:), item, aux(:)

  ! process
  do i = 1, 2
    print '(/,"item ",I0)', i
    call setItem('abc', item)

    if (ALLOCATED(table)) then
      n = SIZE(table)
      call MOVE_ALLOC(table, aux)
      allocate (table(n+1), MOLD = item)
      print *, 'table is same type as aux?:', SAME_TYPE_AS(table, aux)

      do j = 1, n
    call table(j)%assign(aux(j))
      enddo
      call table(n+1)%assign(item)
    else
      allocate (table(1), SOURCE = item)
    endif
    print *, 'table is same type as item?:', SAME_TYPE_AS(table, item)
    print *, 'table is same type as itemType?:', SAME_TYPE_AS(table,
itemType())
    print *, 'table extends type itemType?:', EXTENDS_TYPE_OF(table,
itemType())
  enddo

  ! output
  do i = 1, SIZE(table)
    select type (item => table(i))
      type is (myItem)
    print *, i, item%name
    end select
  enddo

contains

  subroutine setItem(name, item)
    character(*), intent(IN) :: name
    class(itemType), allocatable, intent(OUT) :: item

    allocate (myItem :: item)
    select type (item)
      type is (myItem)
    print *, 'setting...'
    item%name = name
    end select
  end subroutine

end


Here the output is:


item 1
 setting...
 table is same type as item?: T
 table is same type as itemType?: F
 table extends type itemType?: T

item 2
 setting...
 table is same type as aux?: T
 this is right
 this is right
 table is same type as item?: T
 table is same type as itemType?: F
 table extends type itemType?: T
           1 abc
           2 abc