gcc/testsuite/gfortran.dg/storage_size_7.f90

   1 ! { dg-do run }
   2 ! Fix STORAGE_SIZE intrinsic for polymorphic arguments PR84006 and PR100027.
   3 ! Contributed by Steve Kargl  <kargls@comcast.net>
   4 !            and José Rui Faustino de Sousa  <jrfsousa@gcc.gnu.org>
   5 program p
   6   use, intrinsic :: ISO_FORTRAN_ENV, only: int64
   7   type t
   8     integer i
   9   end type
  10   type s
  11     class(t), allocatable :: c(:)
  12   end type
  13   integer :: rslt, class_rslt
  14   integer(kind=int64), target :: tgt
  15   class(t), allocatable, target :: t_alloc(:)
  16   class(s), allocatable, target :: s_alloc(:)
  17   character(:), allocatable, target :: chr(:)
  18   class(*), pointer :: ptr_s, ptr_a(:)
  19
  20   allocate (t_alloc(2), source=t(1))
  21   rslt = storage_size(t_alloc(1))      ! Scalar arg - the original testcase
  22   if (rslt .ne. 32) stop 1
  23
  24   rslt = storage_size(t_alloc)         ! Array arg
  25   if (rslt .ne. 32) stop 2
  26
  27   call pr100027
  28
  29   allocate (s_alloc(2), source=s([t(1), t(2)]))
  30 ! This, of course, is processor dependent: gfortran gives 576, NAG 448
  31 ! and Intel 1216.
  32   class_rslt = storage_size(s_alloc)   ! Type with a class component
  33   ptr_s => s_alloc(2)
  34 ! However, the unlimited polymorphic result should be the same
  35   if (storage_size (ptr_s) .ne. class_rslt) stop 3
  36   ptr_a => s_alloc
  37   if (storage_size (ptr_a) .ne. class_rslt) stop 4
  38
  39   rslt = storage_size(s_alloc(1)%c(2)) ! Scalar component arg
  40   if (rslt .ne. 32) stop 5
  41
  42   rslt = storage_size(s_alloc(1)%c)    ! Scalar component of array arg
  43   if (rslt .ne. 32) stop 6
  44
  45   ptr_s => tgt
  46   rslt = storage_size (ptr_s)          ! INTEGER(8) target
  47   if (rslt .ne. 64) stop 7
  48
  49   allocate (chr(2), source = ["abcde", "fghij"])
  50   ptr_s => chr(2)
  51   rslt = storage_size (ptr_s)          ! CHARACTER(5) scalar
  52   if (rslt .ne. 40) stop 8
  53
  54   ptr_a => chr
  55   rslt = storage_size (ptr_a)          ! CHARACTER(5) array
  56   if (rslt .ne. 40) stop 9
  57
  58   deallocate (t_alloc, s_alloc, chr)   ! For valgrind check
  59
  60 contains
  61
  62 ! Original testcase from José Rui Faustino de Sousa
  63   subroutine pr100027
  64     implicit none
  65
  66     integer, parameter :: n = 11
  67
  68     type :: foo_t
  69     end type foo_t
  70
  71     type, extends(foo_t) :: bar_t
  72     end type bar_t
  73
  74     class(*),     pointer :: apu(:)
  75     class(foo_t), pointer :: apf(:)
  76     class(bar_t), pointer :: apb(:)
  77     type(bar_t),   target :: atb(n)
  78
  79     integer :: m
  80
  81     apu => atb
  82     m = storage_size(apu)
  83     if (m .ne. 0) stop 10
  84     apf => atb
  85     m = storage_size(apf)
  86     if (m .ne. 0) stop 11
  87     apb => atb
  88     m = storage_size(apb)
  89     if (m .ne. 0) stop 12
  90   end
  91 end program p