gcc/testsuite/gfortran.dg/typebound_assignment_7.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 57843: [OOP] Type-bound assignment is resolved to non-polymorphic procedure call
   4 !
   5 ! Contributed by John <jwmwalrus@gmail.com>
   6
   7 module mod1
   8   implicit none
   9   type :: itemType
  10   contains
  11     procedure :: the_assignment => assign_itemType
  12     generic :: assignment(=) => the_assignment
  13   end type
  14 contains
  15   subroutine assign_itemType(left, right)
  16     class(itemType), intent(OUT) :: left
  17     class(itemType), intent(IN) :: right
  18   end subroutine
  19 end module
  20
  21 module mod2
  22   use mod1
  23   implicit none
  24   type, extends(itemType) :: myItem
  25     character(3) :: name = ''
  26   contains
  27     procedure :: the_assignment => assign_myItem
  28   end type
  29 contains
  30   subroutine assign_myItem(left, right)
  31     class(myItem), intent(OUT) :: left
  32     class(itemType), intent(IN) :: right
  33     select type (right)
  34     type is (myItem)
  35       left%name = right%name
  36     end select
  37   end subroutine
  38 end module
  39
  40
  41 program test_assign
  42
  43   use mod2
  44   implicit none
  45
  46   class(itemType), allocatable :: item1, item2
  47
  48   allocate (myItem :: item1)
  49   select type (item1)
  50     type is (myItem)
  51       item1%name = 'abc'
  52   end select
  53
  54   allocate (myItem :: item2)
  55   item2 = item1
  56
  57   select type (item2)
  58     type is (myItem)
  59       if (item2%name /= 'abc') STOP 1
  60     class default
  61       STOP 2
  62   end select
  63
  64 end