gcc/testsuite/gfortran.dg/unlimited_polymorphic_13.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/58793
   4 !
   5 ! Contributed by  Vladimir Fuka
   6 !
   7 ! Had the wrong value for the storage_size for complex
   8 !
   9 module m
  10   use iso_fortran_env
  11   implicit none
  12   integer, parameter :: c1 = real_kinds(1)
  13   integer, parameter :: c2 = real_kinds(2)
  14   integer, parameter :: c3 = real_kinds(size(real_kinds)-1)
  15   integer, parameter :: c4 = real_kinds(size(real_kinds))
  16   real(c1) :: r1
  17   real(c2) :: r2
  18   real(c3) :: r3
  19   real(c4) :: r4
  20 contains
  21  subroutine s(o, k)
  22     class(*) :: o
  23     integer :: k
  24     integer :: sz
  25
  26     sz = 0
  27     select case (k)
  28      case (4)
  29       sz = storage_size(r1)*2
  30     end select
  31     select case (k)
  32      case (8)
  33       sz = storage_size(r2)*2
  34     end select
  35     select case (k)
  36      case (real_kinds(size(real_kinds)-1))
  37       sz = storage_size(r3)*2
  38     end select
  39     select case (k)
  40      case (real_kinds(size(real_kinds)))
  41       sz = storage_size(r4)*2
  42     end select
  43     if (sz .eq. 0) STOP 1
  44
  45     if (storage_size(o) /= sz) STOP 2
  46
  47 ! Break up the SELECT TYPE to pre-empt collisions in the value of 'cn'
  48     select type (o)
  49       type is (complex(c1))
  50         if (storage_size(o) /= sz) STOP 3
  51     end select
  52     select type (o)
  53       type is (complex(c2))
  54         if (storage_size(o) /= sz) STOP 4
  55     end select
  56     select type (o)
  57       type is (complex(c3))
  58         if (storage_size(o) /= sz) STOP 5
  59      end select
  60     select type (o)
  61      type is (complex(c4))
  62         if (storage_size(o) /= sz) STOP 6
  63     end select
  64   end subroutine s
  65 end module m
  66
  67 program p
  68  use m
  69  call s((1._c1, 2._c1), c1)
  70  call s((1._c2, 2._c2), c2)
  71  call s((1._c3, 2._c3), c3)
  72  call s((1._c4, 2._c4), c4)
  73 end program p