gcc/testsuite/gfortran.dg/class_dummy_6.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR99819 - explicit shape class arrays in different
   4 ! procedures caused an ICE.
   5 !
   6 ! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
   7 !
   8 program p
   9    type t
  10       integer :: i
  11    end type
  12    class(t), allocatable :: dum1(:), dum2(:), dum3(:,:)
  13
  14    allocate (t :: dum1(3), dum2(10), dum3(2,5))
  15    dum2%i = [1,2,3,4,5,6,7,8,9,10]
  16    dum3%i = reshape ([1,2,3,4,5,6,7,8,9,10],[2,5])
  17
  18 ! Somewhat elaborated versions of the PR procedures.
  19    if (f (dum1, dum2, dum3) .ne. 10) stop 1
  20    if (g (dum1) .ne. 3) stop 2
  21
  22 ! Test the original versions of the procedures.
  23    if (f_original (dum1, dum2) .ne. 3) stop 3
  24    if (g_original (dum2) .ne. 10) stop 4
  25
  26 contains
  27    integer function f(x, y, z)
  28       class(t) :: x(:)
  29       class(t) :: y(size( x))
  30       class(t) :: z(2,*)
  31       if (size (y) .ne. 3) stop 5
  32       if (size (z) .ne. 0) stop 6
  33       select type (y)
  34         type is (t)
  35           f = 1
  36           if (any (y%i .ne. [1,2,3])) stop 7
  37         class default
  38           f = 0
  39       end select
  40       select type (z)
  41         type is (t)
  42           f = f*10
  43           if (any (z(1,1:4)%i .ne. [1,3,5,7])) stop 8
  44         class default
  45           f = 0
  46       end select
  47    end
  48    integer function g(z)
  49       class(t) :: z(:)
  50       type(t) :: u(size(z))
  51       g = size (u)
  52    end
  53
  54    integer function f_original(x, y)
  55       class(t) :: x(:)
  56       class(*) :: y(size (x))
  57       f_original = size (y)
  58    end
  59
  60    integer function g_original(z)
  61       class(*) :: z(:)
  62       type(t) :: u(size(z))
  63       g_original = size (u)
  64    end
  65 end