gcc/testsuite/gfortran.dg/use_27.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/45900
   4 ! The BTYPEINSTANCE%CALLBACK() typebound call was resolved incorrectly to
   5 ! A's CALLBACK procedure instead of B's because the CALLBACK name is ambiguous
   6 ! in the MAIN namespace.
   7 !
   8 ! Original testcase by someone <ortp21@gmail.com>
   9
  10 module A
  11 implicit none
  12     type :: aType
  13     contains
  14         procedure :: callback
  15     end type aType
  16     contains
  17         subroutine callback( callback_, i )
  18             implicit none
  19             class(aType) :: callback_
  20             integer :: i
  21
  22             i = 3
  23         end subroutine callback
  24
  25         subroutine solver( callback_, i )
  26             implicit none
  27             class(aType) :: callback_
  28             integer :: i
  29
  30             call callback_%callback(i)
  31         end subroutine solver
  32 end module A
  33
  34 module B
  35 use A, only: aType
  36 implicit none
  37     type, extends(aType) :: bType
  38         integer :: i
  39     contains
  40         procedure :: callback
  41     end type bType
  42     contains
  43         subroutine callback( callback_, i )
  44             implicit none
  45             class(bType) :: callback_
  46             integer :: i
  47
  48             i = 7
  49         end subroutine callback
  50 end module B
  51
  52 program main
  53   call test1()
  54   call test2()
  55
  56 contains
  57
  58   subroutine test1
  59     use A
  60     use B
  61     implicit none
  62     type(aType) :: aTypeInstance
  63     type(bType) :: bTypeInstance
  64     integer :: iflag
  65
  66     bTypeInstance%i = 4
  67
  68     iflag = 0
  69     call bTypeInstance%callback(iflag)
  70     if (iflag /= 7) call abort
  71     iflag = 1
  72     call solver( bTypeInstance, iflag )
  73     if (iflag /= 7) call abort
  74
  75     iflag = 2
  76     call aTypeInstance%callback(iflag)
  77     if (iflag /= 3) call abort
  78   end subroutine test1
  79
  80   subroutine test2
  81     use B
  82     use A
  83     implicit none
  84     type(aType) :: aTypeInstance
  85     type(bType) :: bTypeInstance
  86     integer :: iflag
  87
  88     bTypeInstance%i = 4
  89
  90     iflag = 0
  91     call bTypeInstance%callback(iflag)
  92     if (iflag /= 7) call abort
  93     iflag = 1
  94     call solver( bTypeInstance, iflag )
  95     if (iflag /= 7) call abort
  96
  97     iflag = 2
  98     call aTypeInstance%callback(iflag)
  99     if (iflag /= 3) call abort
 100   end subroutine test2
 101 end program main
 102
 103