gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03

   1 ! { dg-do run }
   2 ! Tests dynamic dispatch of class functions.
   3 !
   4 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
   5 !
   6 module m
   7   type :: t1
   8     integer :: i = 42
   9     procedure(make_real), pointer :: ptr
  10   contains
  11     procedure, pass :: real => make_real
  12     procedure, pass :: make_integer
  13     procedure, pass :: prod => i_m_j
  14     generic, public :: extract => real, make_integer
  15     generic, public :: base_extract => real, make_integer
  16   end type t1
  17
  18   type, extends(t1) :: t2
  19     integer :: j = 99
  20   contains
  21     procedure, pass :: real => make_real2
  22     procedure, pass :: make_integer_2
  23     procedure, pass :: prod => i_m_j_2
  24     generic, public :: extract => real, make_integer_2
  25   end type t2
  26 contains
  27   real function make_real (arg)
  28     class(t1), intent(in) :: arg
  29     make_real = real (arg%i)
  30   end function make_real
  31
  32   real function make_real2 (arg)
  33     class(t2), intent(in) :: arg
  34     make_real2 = real (arg%j)
  35   end function make_real2
  36
  37   integer function make_integer (arg, arg2)
  38     class(t1), intent(in) :: arg
  39     integer :: arg2
  40     make_integer = arg%i * arg2
  41   end function make_integer
  42
  43   integer function make_integer_2 (arg, arg2)
  44     class(t2), intent(in) :: arg
  45     integer :: arg2
  46     make_integer_2 = arg%j * arg2
  47   end function make_integer_2
  48
  49   integer function i_m_j (arg)
  50     class(t1), intent(in) :: arg
  51         i_m_j = arg%i
  52   end function i_m_j
  53
  54   integer function i_m_j_2 (arg)
  55     class(t2), intent(in) :: arg
  56         i_m_j_2 = arg%j
  57   end function i_m_j_2
  58 end module m
  59
  60   use m
  61   type, extends(t1) :: l1
  62     character(16) :: chr
  63   end type l1
  64   class(t1), pointer :: a !=> NULL()
  65   type(t1), target :: b
  66   type(t2), target :: c
  67   type(l1), target :: d
  68   a => b                                   ! declared type
  69   if (a%real() .ne. real (42)) call abort
  70   if (a%prod() .ne. 42) call abort
  71   if (a%extract (2) .ne. 84) call abort
  72   if (a%base_extract (2) .ne. 84) call abort
  73   a => c                                   ! extension in module
  74   if (a%real() .ne. real (99)) call abort
  75   if (a%prod() .ne. 99) call abort
  76   if (a%extract (3) .ne. 297) call abort
  77   if (a%base_extract (3) .ne. 126) call abort
  78   a => d                                   ! extension in main
  79   if (a%real() .ne. real (42)) call abort
  80   if (a%prod() .ne. 42) call abort
  81   if (a%extract (4) .ne. 168) call abort
  82   if (a%base_extract (4) .ne. 168) call abort
  83 end
  84 ! { dg-final { cleanup-modules "m" } }