gcc/testsuite/gfortran.dg/unlimited_polymorphic_17.f90

   1 ! { dg-do run }
   2 ! Tests fix for PR60717 in which offsets in recursive calls below
   3 ! were not being set correctly.
   4 !
   5 ! Reported on comp.lang.fortran by Thomas Schnurrenberger
   6 !
   7 module m
   8   implicit none
   9   real :: chksum0 = 0, chksum1 = 0, chksum2 = 0
  10 contains
  11   recursive subroutine show_real(a)
  12     real, intent(in) :: a(:)
  13     if (size (a) > 0) then
  14       chksum0 = a(1) + chksum0
  15       call show_real (a(2:))
  16     end if
  17     return
  18   end subroutine show_real
  19   recursive subroutine show_generic1(a)
  20     class(*), intent(in) :: a(:)
  21     if (size (a) > 0) then
  22       select type (a)
  23       type is (real)
  24         chksum1 = a(1) + chksum1
  25       end select
  26       call show_generic1 (a(2:)) ! recursive call outside SELECT TYPE
  27     end if
  28     return
  29   end subroutine show_generic1
  30   recursive subroutine show_generic2(a)
  31     class(*), intent(in) :: a(:)
  32     if (size (a) > 0) then
  33       select type (a)
  34       type is (real)
  35         chksum2 = a(1) + chksum2
  36         call show_generic2 (a(2:)) ! recursive call inside SELECT TYPE
  37       end select
  38     end if
  39     return
  40   end subroutine show_generic2
  41 end module m
  42 program test
  43   use :: m
  44   implicit none
  45   real :: array(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
  46   call show_real (array)
  47   call show_generic1 (array)
  48   call show_generic2 (array)
  49   if (chksum0 .ne. chksum1) STOP 1
  50   if (chksum0 .ne. chksum2) STOP 2
  51 end program test