gcc/testsuite/gfortran.dg/assumed_rank_22.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources assumed_rank_22_aux.c }
   3 ! { dg-additional-options "-fdump-tree-original" }
   4 !
   5 ! FIXME: wrong extend in array descriptor, see C file.
   6 ! { dg-output "c_assumed - 40 - OK" { xfail *-*-* } }
   7 ! { dg-output "c_assumed - 100 - OK" { xfail *-*-* } }
   8 !
   9 ! PR fortran/94070
  10 !
  11 ! Contributed by Tobias Burnus
  12 ! and José Rui Faustino de Sousa
  13 !
  14 program main
  15   implicit none
  16   integer :: A(5,4,2)
  17   integer, allocatable :: B(:,:,:)
  18   integer :: C(5,4,-2:-1)
  19
  20   interface
  21     subroutine c_assumed (x, num) bind(C)
  22       integer :: x(..)
  23       integer, value :: num
  24     end subroutine
  25     subroutine c_allocated (x) bind(C)
  26       integer, allocatable :: x(..)
  27     end subroutine
  28   end interface
  29
  30   allocate (B(-1:3,4,-1:-1))
  31
  32   call caller (a)          ! num=0: assumed-size
  33   call test (b, num=20)           ! full array
  34   call test (b(:,:,0:-1), num=40) ! zero-sized array
  35   call test (c, num=60)
  36   call test (c(:,:,:-1), num=80) ! full-size slice
  37   call test (c(:,:,1:-1), num=100) !zero-size array
  38
  39   call test_alloc(b)
  40
  41   call c_assumed (b, num=20)
  42   call c_assumed (b(:,:,0:-1), num=40)
  43   call c_assumed (c, num=60)
  44   call c_assumed (c(:,:,:-1), num=80)
  45   call c_assumed (c(:,:,1:-1), num=100)
  46
  47   call c_allocated (b)
  48 contains
  49   subroutine caller(y)
  50     integer :: y(-1:3,4,*)
  51     call test(y, num=0)
  52     call c_assumed (y, num=0)
  53   end
  54   subroutine test (x, num)
  55     integer :: x(..), num
  56
  57     ! SIZE (x)
  58     if (num == 0) then
  59       if (size (x) /= -20) stop 1
  60     elseif (num == 20) then
  61       if (size (x) /= 20) stop 21
  62     elseif (num == 40) then
  63       if (size (x) /= 0) stop 41
  64     elseif (num == 60) then
  65       if (size (x) /= 40) stop 61
  66     elseif (num == 80) then
  67       if (size (x) /= 40) stop 81
  68     elseif (num == 100) then
  69       if (size (x) /= 0) stop 101
  70     else
  71       stop 99  ! Invalid num
  72     endif
  73
  74     ! SIZE (x, dim=...)
  75     if (size (x, dim=1) /= 5) stop num + 2
  76     if (size (x, dim=2) /= 4) stop num + 3
  77
  78     if (num == 0) then
  79       if (size (x, dim=3) /= -1) stop 4
  80     elseif (num == 20) then
  81       if (size (x, dim=3) /= 1) stop 24
  82     elseif (num == 40) then
  83       if (size (x, dim=3) /= 0) stop 44
  84     elseif (num == 60) then
  85       if (size (x, dim=3) /= 2) stop 64
  86     elseif (num == 80) then
  87       if (size (x, dim=3) /= 2) stop 84
  88     elseif (num == 100) then
  89       if (size (x, dim=3) /= 0) stop 104
  90     endif
  91
  92     ! SHAPE (x)
  93     if (num == 0) then
  94       if (any (shape (x) /= [5, 4, -1])) stop 5
  95     elseif (num == 20) then
  96       if (any (shape (x) /= [5, 4, 1])) stop 25
  97     elseif (num == 40) then
  98       if (any (shape (x) /= [5, 4, 0])) stop 45
  99     elseif (num == 60) then
 100       if (any (shape (x) /= [5, 4, 2])) stop 65
 101     elseif (num == 80) then
 102       if (any (shape (x) /= [5, 4, 2])) stop 85
 103     elseif (num == 100) then
 104       if (any (shape (x) /= [5, 4, 0])) stop 105
 105     endif
 106
 107     ! LBOUND (X)
 108     if (any (lbound (x) /= [1, 1, 1])) stop num + 6
 109
 110     ! LBOUND (X, dim=...)
 111     if (lbound (x, dim=1) /= 1) stop num + 7
 112     if (lbound (x, dim=2) /= 1) stop num + 8
 113     if (lbound (x, dim=3) /= 1) stop num + 9
 114
 115     ! UBOUND (X)
 116     if (num == 0) then
 117       if (any (ubound (x) /= [5, 4, -1])) stop 11
 118     elseif (num == 20) then
 119       if (any (ubound (x) /= [5, 4, 1])) stop 31
 120     elseif (num == 40) then
 121       if (any (ubound (x) /= [5, 4, 0])) stop 51
 122     elseif (num == 60) then
 123       if (any (ubound (x) /= [5, 4, 2])) stop 71
 124     elseif (num == 80) then
 125       if (any (ubound (x) /= [5, 4, 2])) stop 91
 126     elseif (num == 100) then
 127       if (any (ubound (x) /= [5, 4, 0])) stop 111
 128     endif
 129
 130     ! UBOUND (X, dim=...)
 131     if (ubound (x, dim=1) /= 5) stop num + 12
 132     if (ubound (x, dim=2) /= 4) stop num + 13
 133     if (num == 0) then
 134       if (ubound (x, dim=3) /= -1) stop 14
 135     elseif (num == 20) then
 136       if (ubound (x, dim=3) /= 1) stop 34
 137     elseif (num == 40) then
 138       if (ubound (x, dim=3) /= 0) stop 54
 139     elseif (num == 60) then
 140       if (ubound (x, dim=3) /= 2) stop 74
 141     elseif (num == 80) then
 142       if (ubound (x, dim=3) /= 2) stop 94
 143     elseif (num == 100) then
 144       if (ubound (x, dim=3) /= 0) stop 114
 145     endif
 146   end
 147
 148   subroutine test_alloc (x)
 149     integer, allocatable :: x(..)
 150
 151     if (size (x) /= 20) stop 61
 152     if (size (x, dim=1) /= 5) stop 62
 153     if (size (x, dim=2) /= 4) stop 63
 154     if (size (x, dim=3) /= 1) stop 64
 155
 156     if (any (shape (x) /= [5, 4, 1])) stop 65
 157
 158     if (any (lbound (x) /= [-1, 1, -1])) stop 66
 159     if (lbound (x, dim=1) /= -1) stop 77
 160     if (lbound (x, dim=2) /= 1) stop 78
 161     if (lbound (x, dim=3) /= -1) stop 79
 162
 163     if (any (ubound (x) /= [3, 4, -1])) stop 80
 164     if (ubound (x, dim=1) /= 3) stop 92
 165     if (ubound (x, dim=2) /= 4) stop 93
 166     if (ubound (x, dim=3) /= -1) stop 94
 167   end
 168 end
 169 ! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } }