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   end type t1
  16
  17   type, extends(t1) :: t2
  18     integer :: j = 99
  19   contains
  20     procedure, pass :: real => make_real2
  21     procedure, pass :: make_integer => make_integer_2
  22     procedure, pass :: prod => i_m_j_2
  23   end type t2
  24 contains
  25   real function make_real (arg)
  26     class(t1), intent(in) :: arg
  27     make_real = real (arg%i)
  28   end function make_real
  29
  30   real function make_real2 (arg)
  31     class(t2), intent(in) :: arg
  32     make_real2 = real (arg%j)
  33   end function make_real2
  34
  35   integer function make_integer (arg, arg2)
  36     class(t1), intent(in) :: arg
  37     integer :: arg2
  38     make_integer = arg%i * arg2
  39   end function make_integer
  40
  41   integer function make_integer_2 (arg, arg2)
  42     class(t2), intent(in) :: arg
  43     integer :: arg2
  44     make_integer_2 = arg%j * arg2
  45   end function make_integer_2
  46
  47   integer function i_m_j (arg)
  48     class(t1), intent(in) :: arg
  49         i_m_j = arg%i
  50   end function i_m_j
  51
  52   integer function i_m_j_2 (arg)
  53     class(t2), intent(in) :: arg
  54         i_m_j_2 = arg%j
  55   end function i_m_j_2
  56 end module m
  57
  58   use m
  59   type, extends(t1) :: l1
  60     character(16) :: chr
  61   end type l1
  62   class(t1), pointer :: a !=> NULL()
  63   type(t1), target :: b
  64   type(t2), target :: c
  65   type(l1), target :: d
  66   a => b                                   ! declared type
  67   if (a%real() .ne. real (42)) STOP 1
  68   if (a%prod() .ne. 42) STOP 2
  69   if (a%extract (2) .ne. 84) STOP 3
  70   a => c                                   ! extension in module
  71   if (a%real() .ne. real (99)) STOP 4
  72   if (a%prod() .ne. 99) STOP 5
  73   if (a%extract (3) .ne. 297) STOP 6
  74   a => d                                   ! extension in main
  75   if (a%real() .ne. real (42)) STOP 7
  76   if (a%prod() .ne. 42) STOP 8
  77   if (a%extract (4) .ne. 168) STOP 9
  78 end