gcc/testsuite/gfortran.dg/dynamic_dispatch_8.f03

   1 ! { dg-do run }
   2 !
   3 ! PR 41829: [OOP] Runtime error with dynamic dispatching.  Tests
   4 ! dynamic dispatch in a case where the caller knows nothing about
   5 ! the dynamic type at compile time.
   6 !
   7 ! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
   8 !
   9 module foo_mod
  10   type foo
  11     integer :: i
  12   contains
  13     procedure, pass(a) :: doit
  14     procedure, pass(a) :: getit
  15   end type foo
  16
  17   private doit,getit
  18 contains
  19   subroutine  doit(a)
  20     class(foo) :: a
  21
  22     a%i = 1
  23 !    write(*,*) 'FOO%DOIT base version'
  24   end subroutine doit
  25   function getit(a) result(res)
  26     class(foo) :: a
  27     integer :: res
  28
  29     res = a%i
  30   end function getit
  31
  32 end module foo_mod
  33 module foo2_mod
  34   use foo_mod
  35
  36   type, extends(foo) :: foo2
  37     integer :: j
  38   contains
  39     procedure, pass(a) :: doit  => doit2
  40     procedure, pass(a) :: getit => getit2
  41   end type foo2
  42
  43   private doit2, getit2
  44
  45 contains
  46
  47   subroutine  doit2(a)
  48     class(foo2) :: a
  49
  50     a%i = 2
  51     a%j = 3
  52 !    write(*,*) 'FOO2%DOIT derived version'
  53   end subroutine doit2
  54   function getit2(a) result(res)
  55     class(foo2) :: a
  56     integer :: res
  57
  58     res = a%j
  59   end function getit2
  60
  61 end module foo2_mod
  62
  63 module bar_mod
  64   use foo_mod
  65   type bar
  66     class(foo), allocatable :: a
  67   contains
  68     procedure, pass(a) :: doit
  69     procedure, pass(a) :: getit
  70   end type bar
  71   private doit,getit
  72
  73 contains
  74   subroutine doit(a)
  75     class(bar) :: a
  76
  77     call a%a%doit()
  78   end subroutine doit
  79   function getit(a) result(res)
  80     class(bar) :: a
  81     integer :: res
  82
  83     res = a%a%getit()
  84   end function getit
  85 end module bar_mod
  86
  87
  88 program testd10
  89   use foo_mod
  90   use foo2_mod
  91   use bar_mod
  92
  93   type(bar) :: a
  94
  95   allocate(foo :: a%a)
  96   call a%doit()
  97 !  write(*,*) 'Getit value : ', a%getit()
  98   if (a%getit() .ne. 1) call abort
  99   deallocate(a%a)
 100   allocate(foo2 :: a%a)
 101   call a%doit()
 102 !  write(*,*) 'Getit value : ', a%getit()
 103   if (a%getit() .ne. 3) call abort
 104
 105 end program testd10
 106
 107 ! { dg-final { cleanup-modules "foo_mod foo2_mod bar_mod" } }
 108