gcc/testsuite/gfortran.dg/class_array_9.f03

   1 ! { dg-do run }
   2 ! Test typebound elemental functions on class arrays
   3 !
   4 module m
   5   type :: t1
   6     integer :: i
   7   contains
   8     procedure, pass :: disp => disp_t1
   9   end type t1
  10
  11   type, extends(t1) :: t2
  12     real :: r
  13   contains
  14     procedure, pass :: disp => disp_t2
  15   end type t2
  16
  17 contains
  18   integer elemental function disp_t1 (q)
  19     class(t1), intent(in) :: q
  20     disp_t1 = q%i
  21   end function
  22
  23   integer elemental function disp_t2 (q)
  24     class(t2), intent(in) :: q
  25     disp_t2 = int (q%r)
  26   end function
  27 end module
  28
  29   use m
  30   class(t1), allocatable :: x(:)
  31   allocate (x(4), source = [(t1 (i), i=1,4)])
  32   if (any (x%disp () .ne. [1,2,3,4])) call abort
  33   if (any (x(2:3)%disp () .ne. [2,3])) call abort
  34   if (any (x(4:3:-1)%disp () .ne. [4,3])) call abort
  35   if (x(4)%disp () .ne. 4) call abort
  36
  37   deallocate (x)
  38   allocate (x(4), source = [(t2 (2 * i, real (i) + 0.333), i=1,4)])
  39   if (any (x%disp () .ne. [1,2,3,4])) call abort
  40   if (any (x(2:3)%disp () .ne. [2,3])) call abort
  41   if (any (x(4:3:-1)%disp () .ne. [4,3])) call abort
  42   if (x(4)%disp () .ne. 4) call abort
  43
  44 end