gcc/testsuite/gfortran.dg/pdt_3.f03

   1 ! { dg-do run }
   2 !
   3 ! Check PDT type extension and simple OOP.
   4 !
   5 module vars
   6   integer :: d_dim = 4
   7   integer :: mat_dim = 256
   8   integer, parameter :: ftype = kind(0.0d0)
   9 end module
  10
  11   use vars
  12   implicit none
  13   integer :: i
  14   type :: mytype (a,b)
  15     integer, kind :: a = kind(0.0e0)
  16     integer, LEN :: b = 4
  17     integer :: i
  18     real(kind = a) :: d(b, b)
  19   end type
  20
  21   type, extends(mytype) :: thytype(h)
  22     integer, kind :: h
  23     integer(kind = h) :: j
  24   end type
  25
  26   type x (q, r, s)
  27     integer, kind :: q
  28     integer, kind :: r
  29     integer, LEN :: s
  30     integer(kind = q) :: idx_mat(2,2)  ! check these do not get treated as pdt_arrays.
  31     type (mytype (b=s)) :: mat1
  32     type (mytype (b=s*2)) :: mat2
  33   end type x
  34
  35   real, allocatable :: matrix (:,:)
  36   type(thytype(ftype, 4, 4)) :: w
  37   type(x(8,4,256)) :: q
  38   class(mytype(ftype, :)), allocatable :: cz
  39
  40   w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
  41
  42 ! Make sure that the type extension is ordering the parameters correctly.
  43   if (w%a .ne. ftype) call abort
  44   if (w%b .ne. 4) call abort
  45   if (w%h .ne. 4) call abort
  46   if (size (w%d) .ne. 16) call abort
  47   if (int (w%d(2,4)) .ne. 14) call abort
  48   if (kind (w%j) .ne. w%h) call abort
  49
  50 ! As a side issue, ensure PDT components are OK
  51   if (q%mat1%b .ne. q%s) call abort
  52   if (q%mat2%b .ne. q%s*2) call abort
  53   if (size (q%mat1%d) .ne. mat_dim**2) call abort
  54   if (size (q%mat2%d) .ne. 4*mat_dim**2) call abort
  55
  56 ! Now check some basic OOP with PDTs
  57   matrix = w%d
  58
  59 ! TODO - for some reason, using w%d directly in the source causes a seg fault.
  60   allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
  61   select type (cz)
  62     type is (mytype(ftype, *))
  63       if (int (sum (cz%d)) .ne. 136) call abort
  64     type is (thytype(ftype, *, 8))
  65       call abort
  66   end select
  67   deallocate (cz)
  68
  69   allocate (thytype(ftype, d_dim*2, 8) :: cz)
  70   cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
  71   select type (cz)
  72     type is (mytype(ftype, *))
  73       call abort
  74     type is (thytype(ftype, *, 8))
  75       if (int (sum (cz%d)) .ne. 20800) call abort
  76   end select
  77
  78   deallocate (cz)
  79 end