gcc/testsuite/gfortran.dg/typebound_call_18.f03

   1 ! { dg-do run }
   2 !
   3 ! PR 45271: [OOP] Polymorphic code breaks when changing order of USE statements
   4 !
   5 ! Contributed by Harald Anlauf <anlauf@gmx.de>
   6
   7 module abstract_vector
   8   implicit none
   9   type, abstract :: vector_class
  10   contains
  11     procedure(op_assign_v_v), deferred :: assign
  12   end type vector_class
  13   abstract interface
  14     subroutine op_assign_v_v(this,v)
  15       import vector_class
  16       class(vector_class), intent(inout) :: this
  17       class(vector_class), intent(in)    :: v
  18     end subroutine
  19   end interface
  20 end module abstract_vector
  21
  22 module concrete_vector
  23   use abstract_vector
  24   implicit none
  25   type, extends(vector_class) :: trivial_vector_type
  26   contains
  27     procedure :: assign => my_assign
  28   end type
  29 contains
  30   subroutine my_assign (this,v)
  31     class(trivial_vector_type), intent(inout) :: this
  32     class(vector_class),        intent(in)    :: v
  33     write (*,*) 'Oops in concrete_vector::my_assign'
  34     call abort ()
  35   end subroutine
  36 end module concrete_vector
  37
  38 module concrete_gradient
  39   use abstract_vector
  40   implicit none
  41   type, extends(vector_class) :: trivial_gradient_type
  42   contains
  43     procedure :: assign => my_assign
  44   end type
  45 contains
  46   subroutine my_assign (this,v)
  47     class(trivial_gradient_type), intent(inout) :: this
  48     class(vector_class),          intent(in)    :: v
  49     write (*,*) 'concrete_gradient::my_assign'
  50   end subroutine
  51 end module concrete_gradient
  52
  53 program main
  54   !--- exchange these two lines to make the code work:
  55   use concrete_vector    ! (1)
  56   use concrete_gradient  ! (2)
  57   !---
  58   implicit none
  59   type(trivial_gradient_type)      :: g_initial
  60   class(vector_class),  allocatable :: g
  61   print *, "cg: before g%assign"
  62   allocate(trivial_gradient_type :: g)
  63   call g%assign (g_initial)
  64   print *, "cg: after  g%assign"
  65 end program main