gcc/testsuite/gfortran.dg/unlimited_polymorphic_18.f90

   1 ! { dg-do run }
   2 ! Testing fix for
   3 ! PR fortran/60414
   4 !
   5 module m
   6     implicit none
   7     Type T
   8         real, public :: expectedScalar;
   9     contains
  10         procedure :: FCheck
  11         procedure :: FCheckArr
  12         generic :: Check => FCheck, FCheckArr
  13     end Type
  14
  15 contains
  16
  17     subroutine FCheck(this,X)
  18         class(T) this
  19         class(*) X
  20         real :: r
  21         select type (X)
  22             type is (real)
  23                 if ( abs (X - this%expectedScalar) > 0.0001 ) then
  24                     call abort()
  25                 end if
  26             class default
  27                 call abort ()
  28          end select
  29     end subroutine FCheck
  30
  31     subroutine FCheckArr(this,X)
  32         class(T) this
  33         class(*) X(:)
  34         integer i
  35         do i = 1,6
  36             this%expectedScalar = i - 1.0
  37             call this%FCheck(X(i))
  38         end do
  39     end subroutine FCheckArr
  40
  41     subroutine CheckTextVector(vec, n, scal)
  42         integer, intent(in) :: n
  43         class(*), intent(in) :: vec(n)
  44         class(*), intent(in) :: scal
  45         integer j
  46         Type(T) :: Tester
  47
  48         ! Check full vector
  49         call Tester%Check(vec)
  50         ! Check a scalar of the same class like the vector
  51         Tester%expectedScalar = 5.0
  52         call Tester%Check(scal)
  53         ! Check an element of the vector, which is a scalar
  54         j=3
  55         Tester%expectedScalar = 2.0
  56         call Tester%Check(vec(j))
  57
  58     end subroutine CheckTextVector
  59
  60 end module
  61
  62 program test
  63    use :: m
  64    implicit none
  65
  66    real :: vec(1:6) = (/ 0, 1, 2, 3, 4, 5 /)
  67    call checktextvector(vec, 6, 5.0)
  68 end program test
  69