gcc/testsuite/gfortran.dg/pdt_5.f03

   1 ! { dg-do run }
   2 !
   3 ! Third, complete example from the PGInsider article:
   4 ! "Object-Oriented Programming in Fortran 2003 Part 3: Parameterized Derived Types"
   5 ! by Mark Leair
   6 !
   7 !     Copyright (c) 2013, NVIDIA CORPORATION.  All rights reserved.
   8 !
   9 ! NVIDIA CORPORATION and its licensors retain all intellectual property
  10 ! and proprietary rights in and to this software, related documentation
  11 ! and any modifications thereto.  Any use, reproduction, disclosure or
  12 ! distribution of this software and related documentation without an express
  13 ! license agreement from NVIDIA CORPORATION is strictly prohibited.
  14 !
  15
  16 !          THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
  17 !   WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
  18 !   NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
  19 !   FITNESS FOR A PARTICULAR PURPOSE.
  20 !
  21 ! Note that modification had to be made all of which are commented.
  22 !
  23 module matrix
  24
  25 type :: base_matrix(k,c,r)
  26   private
  27     integer, kind :: k = 4
  28     integer, len :: c = 1
  29     integer, len :: r = 1
  30 end type base_matrix
  31
  32 type, extends(base_matrix) ::  adj_matrix
  33   private
  34     class(*), pointer :: m(:,:) => null()
  35 end type adj_matrix
  36
  37 interface getKind
  38   module procedure getKind4
  39   module procedure getKind8
  40 end interface getKind
  41
  42 interface getColumns
  43   module procedure getNumCols4
  44   module procedure getNumCols8
  45 end interface getColumns
  46
  47 interface getRows
  48   module procedure getNumRows4
  49   module procedure getNumRows8
  50 end interface getRows
  51
  52 interface adj_matrix
  53    module procedure construct_4   ! kind=4 constructor
  54    module procedure construct_8   ! kind=8 constructor
  55 end interface adj_matrix
  56
  57 interface assignment(=)
  58    module procedure m2m4          ! assign kind=4 matrix
  59    module procedure a2m4          ! assign kind=4 array
  60    module procedure m2m8          ! assign kind=8 matrix
  61    module procedure a2m8          ! assign kind=8 array
  62    module procedure m2a4          ! assign kind=4 matrix to array
  63    module procedure m2a8          ! assign kind=8 matrix to array
  64 end interface assignment(=)
  65
  66
  67 contains
  68
  69   function getKind4(this) result(rslt)
  70    class(adj_matrix(4,*,*)) :: this
  71    integer :: rslt
  72    rslt = this%k
  73   end function getKind4
  74
  75  function getKind8(this) result(rslt)
  76    class(adj_matrix(8,*,*)) :: this
  77    integer :: rslt
  78    rslt = this%k
  79  end function getKind8
  80
  81   function getNumCols4(this) result(rslt)
  82    class(adj_matrix(4,*,*)) :: this
  83    integer :: rslt
  84    rslt = this%c
  85   end function getNumCols4
  86
  87   function getNumCols8(this) result(rslt)
  88    class(adj_matrix(8,*,*)) :: this
  89    integer :: rslt
  90    rslt = this%c
  91   end function getNumCols8
  92
  93   function getNumRows4(this) result(rslt)
  94    class(adj_matrix(4,*,*)) :: this
  95    integer :: rslt
  96    rslt = this%r
  97   end function getNumRows4
  98
  99   function getNumRows8(this) result(rslt)
 100    class(adj_matrix(8,*,*)) :: this
 101    integer :: rslt
 102    rslt = this%r
 103   end function getNumRows8
 104
 105
 106  function construct_4(k,c,r) result(mat)
 107      integer(4) :: k
 108      integer :: c
 109      integer :: r
 110      class(adj_matrix(4,:,:)),allocatable :: mat
 111
 112      allocate(adj_matrix(4,c,r)::mat)
 113
 114   end function construct_4
 115
 116   function construct_8(k,c,r) result(mat)
 117      integer(8) :: k
 118      integer :: c
 119      integer :: r
 120      class(adj_matrix(8,:,:)),allocatable :: mat
 121
 122      allocate(adj_matrix(8,c,r)::mat)
 123
 124   end function construct_8
 125
 126   subroutine a2m4(d,s)
 127    class(adj_matrix(4,:,:)),allocatable :: d
 128    class(*),dimension(:,:) :: s
 129
 130    if (allocated(d)) deallocate(d)
 131 !    allocate(adj_matrix(4,size(s,1),size(s,2))::d)     ! generates assembler error
 132    allocate(d, mold = adj_matrix(4,size(s,1),size(s,2)))
 133    allocate(d%m(size(s,1),size(s,2)),source=s)
 134  end subroutine a2m4
 135
 136  subroutine a2m8(d,s)
 137    class(adj_matrix(8,:,:)),allocatable :: d
 138    class(*),dimension(:,:) :: s
 139
 140    if (allocated(d)) deallocate(d)
 141 !    allocate(adj_matrix(8,size(s,1),size(s,2))::d)     ! generates assembler error
 142    allocate(d, mold = adj_matrix(8_8,size(s,1),size(s,2))) ! Needs 8_8 to match arg1 of 'construct_8'
 143    allocate(d%m(size(s,1),size(s,2)),source=s)
 144  end subroutine a2m8
 145
 146 subroutine m2a8(a,this)
 147 class(adj_matrix(8,*,*)), intent(in) :: this         ! Intents required for
 148 real(8),allocatable, intent(out) :: a(:,:)           ! defined assignment
 149   select type (array => this%m)                      ! Added SELECT TYPE because...
 150     type is (real(8))
 151   if (allocated(a)) deallocate(a)
 152   allocate(a,source=array)
 153   end select
 154 !   allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
 155  end subroutine m2a8
 156
 157  subroutine m2a4(a,this)
 158  class(adj_matrix(4,*,*)), intent(in) :: this        ! Intents required for
 159  real(4),allocatable, intent(out) :: a(:,:)          ! defined assignment
 160   select type (array => this%m)                      ! Added SELECT TYPE because...
 161     type is (real(4))
 162    if (allocated(a)) deallocate(a)
 163    allocate(a,source=array)
 164   end select
 165 !   allocate(a(size(this%m,1),size(this%m,2)),source=this%m) ! ...CLASS(*) source does not work in gfortran
 166  end subroutine m2a4
 167
 168   subroutine m2m4(d,s)
 169    CLASS(adj_matrix(4,:,:)),allocatable, intent(OUT) :: d   ! Intents required for
 170    CLASS(adj_matrix(4,*,*)), intent(in) :: s                ! defined assignment
 171
 172    if (allocated(d)) deallocate(d)
 173    allocate(d,source=s)
 174  end subroutine m2m4
 175
 176  subroutine m2m8(d,s)
 177    CLASS(adj_matrix(8,:,:)),allocatable, intent(OUT) :: d   ! Intents required for
 178    CLASS(adj_matrix(8,*,*)), intent(in) :: s                ! defined assignment
 179
 180    if (allocated(d)) deallocate(d)
 181    allocate(d,source=s)
 182  end subroutine m2m8
 183
 184
 185 end module matrix
 186
 187
 188 program adj3
 189
 190   use matrix
 191   implicit none
 192   integer(8) :: i
 193
 194   class(adj_matrix(8,:,:)),allocatable :: adj             ! Was TYPE: Fails in
 195   real(8) :: a(2,3)                                       ! defined assignment
 196   real(8),allocatable :: b(:,:)
 197
 198   class(adj_matrix(4,:,:)),allocatable :: adj_4           ! Ditto and ....
 199   real(4) :: a_4(3,2)                                     ! ... these declarations were
 200   real(4),allocatable :: b_4(:,:)                         ! added to check KIND=4
 201
 202 ! Check constructor of PDT and instrinsic assignment
 203   adj = adj_matrix(INT(8,8),2,4)
 204   if (adj%k .ne. 8) STOP 1
 205   if (adj%c .ne. 2) STOP 2
 206   if (adj%r .ne. 4) STOP 3
 207   a = reshape ([(i, i = 1, 6)], [2,3])
 208   adj = a
 209   b = adj
 210   if (any (b .ne. a)) STOP 4
 211
 212 ! Check allocation with MOLD of PDT. Note that only KIND parameters set.
 213   allocate (adj_4, mold = adj_matrix(4,3,2))           ! Added check of KIND = 4
 214   if (adj_4%k .ne. 4) STOP 5
 215   a_4 = reshape (a, [3,2])
 216   adj_4 = a_4
 217   b_4 = adj_4
 218   if (any (b_4 .ne. a_4)) STOP 6
 219
 220 end program adj3
 221
 222
 223