gcc/testsuite/gfortran.dg/class_array_20.f03

   1 ! { dg-do run }
   2 !
   3 ! Test contributed by Thomas L. Clune via pr60322
   4 !                  and Antony Lewis via pr64692
   5
   6 program class_array_20
   7   implicit none
   8
   9   type Foo
  10   end type
  11
  12   type(foo), dimension(2:3) :: arg
  13   integer :: oneDarr(2)
  14   integer :: twoDarr(2,3)
  15   integer :: x, y
  16   double precision :: P(2, 2)
  17
  18   ! Checking for PR/60322
  19   call copyFromClassArray([Foo(), Foo()])
  20   call copyFromClassArray(arg)
  21   call copyFromClassArray(arg(:))
  22
  23   x= 3
  24   y= 4
  25   oneDarr = [x, y]
  26   call W([x, y])
  27   call W(oneDarr)
  28   call W([3, 4])
  29
  30   twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3])
  31   call WtwoD(twoDarr)
  32   call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3]))
  33
  34   ! Checking for PR/64692
  35   P(1:2, 1) = [1.d0, 2.d0]
  36   P(1:2, 2) = [3.d0, 4.d0]
  37   call AddArray(P(1:2, 2))
  38
  39 contains
  40
  41   subroutine copyFromClassArray(classarray)
  42     class (Foo), intent(in) :: classarray(:)
  43
  44     if (lbound(classarray, 1) .ne. 1) STOP 1
  45     if (ubound(classarray, 1) .ne. 2) STOP 2
  46     if (size(classarray) .ne. 2) STOP 3
  47   end subroutine
  48
  49   subroutine AddArray(P)
  50     class(*), target, intent(in) :: P(:)
  51     class(*), pointer :: Pt(:)
  52
  53     allocate(Pt(1:size(P)), source= P)
  54
  55     select type (P)
  56       type is (double precision)
  57         if (abs(P(1)-3.d0) .gt. 1.d-8) STOP 4
  58         if (abs(P(2)-4.d0) .gt. 1.d-8) STOP 5
  59       class default
  60         STOP 6
  61     end select
  62
  63     select type (Pt)
  64       type is (double precision)
  65         if (abs(Pt(1)-3.d0) .gt. 1.d-8) STOP 7
  66         if (abs(Pt(2)-4.d0) .gt. 1.d-8) STOP 8
  67       class default
  68         STOP 9
  69     end select
  70   end subroutine
  71
  72   subroutine W(ar)
  73     class(*), intent(in) :: ar(:)
  74
  75     if (lbound(ar, 1) /= 1) STOP 10
  76     select type (ar)
  77       type is (integer)
  78         ! The indeces 1:2 are essential here, or else one would not
  79         ! note, that the array internally starts at 0, although the
  80         ! check for the lbound above went fine.
  81         if (any (ar(1:2) .ne. [3, 4])) STOP 11
  82       class default
  83         STOP 12
  84     end select
  85   end subroutine
  86
  87   subroutine WtwoD(ar)
  88     class(*), intent(in) :: ar(:,:)
  89
  90     if (any (lbound(ar) /= [1, 1])) STOP 13
  91     select type (ar)
  92       type is (integer)
  93         if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) &
  94         STOP 14
  95       class default
  96         STOP 15
  97     end select
  98   end subroutine
  99 end program class_array_20
 100