gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the behavior of lbound, ubound of shape with assumed rank arguments
   4 ! in an array context (without DIM argument).
   5 !
   6
   7 program test
   8
   9   integer              :: a(2:4,-2:5)
  10   integer, allocatable :: b(:,:)
  11   integer, pointer     :: c(:,:)
  12   character(52)        :: buffer
  13
  14   call foo(a)
  15
  16   allocate(b(2:4,-2:5))
  17   call foo(b)
  18   call bar(b)
  19
  20   allocate(c(2:4,-2:5))
  21   call foo(c)
  22   call baz(c)
  23
  24 contains
  25   subroutine foo(arg)
  26     integer :: arg(..)
  27
  28     !print *, lbound(arg)
  29     !print *, id(lbound(arg))
  30     if (any(lbound(arg) /= [1, 1])) STOP 1
  31     if (any(id(lbound(arg)) /= [1, 1])) STOP 2
  32     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  33     write(buffer,*) lbound(arg)
  34     if (buffer /= '           1           1') STOP 3
  35     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  36     write(buffer,*) id(lbound(arg))
  37     if (buffer /= '           1           1') STOP 4
  38
  39     !print *, ubound(arg)
  40     !print *, id(ubound(arg))
  41     if (any(ubound(arg) /= [3, 8])) STOP 5
  42     if (any(id(ubound(arg)) /= [3, 8])) STOP 6
  43     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  44     write(buffer,*) ubound(arg)
  45     if (buffer /= '           3           8') STOP 7
  46     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  47     write(buffer,*) id(ubound(arg))
  48     if (buffer /= '           3           8') STOP 8
  49
  50     !print *, shape(arg)
  51     !print *, id(shape(arg))
  52     if (any(shape(arg) /= [3, 8])) STOP 9
  53     if (any(id(shape(arg)) /= [3, 8])) STOP 10
  54     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  55     write(buffer,*) shape(arg)
  56     if (buffer /= '           3           8') STOP 11
  57     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  58     write(buffer,*) id(shape(arg))
  59     if (buffer /= '           3           8') STOP 12
  60
  61   end subroutine foo
  62   subroutine bar(arg)
  63     integer, allocatable :: arg(:,:)
  64
  65     !print *, lbound(arg)
  66     !print *, id(lbound(arg))
  67     if (any(lbound(arg) /= [2, -2])) STOP 13
  68     if (any(id(lbound(arg)) /= [2, -2])) STOP 14
  69     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  70     write(buffer,*) lbound(arg)
  71     if (buffer /= '           2          -2') STOP 15
  72     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  73     write(buffer,*) id(lbound(arg))
  74     if (buffer /= '           2          -2') STOP 16
  75
  76     !print *, ubound(arg)
  77     !print *, id(ubound(arg))
  78     if (any(ubound(arg) /= [4, 5])) STOP 17
  79     if (any(id(ubound(arg)) /= [4, 5])) STOP 18
  80     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  81     write(buffer,*) ubound(arg)
  82     if (buffer /= '           4           5') STOP 19
  83     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  84     write(buffer,*) id(ubound(arg))
  85     if (buffer /= '           4           5') STOP 20
  86
  87     !print *, shape(arg)
  88     !print *, id(shape(arg))
  89     if (any(shape(arg) /= [3, 8])) STOP 21
  90     if (any(id(shape(arg)) /= [3, 8])) STOP 22
  91     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  92     write(buffer,*) shape(arg)
  93     if (buffer /= '           3           8') STOP 23
  94     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
  95     write(buffer,*) id(shape(arg))
  96     if (buffer /= '           3           8') STOP 24
  97
  98   end subroutine bar
  99   subroutine baz(arg)
 100     integer, pointer :: arg(..)
 101
 102     !print *, lbound(arg)
 103     !print *, id(lbound(arg))
 104     if (any(lbound(arg) /= [2, -2])) STOP 25
 105     if (any(id(lbound(arg)) /= [2, -2])) STOP 26
 106     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 107     write(buffer,*) lbound(arg)
 108     if (buffer /= '           2          -2') STOP 27
 109     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 110     write(buffer,*) id(lbound(arg))
 111     if (buffer /= '           2          -2') STOP 28
 112
 113     !print *, ubound(arg)
 114     !print *, id(ubound(arg))
 115     if (any(ubound(arg) /= [4, 5])) STOP 29
 116     if (any(id(ubound(arg)) /= [4, 5])) STOP 30
 117     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 118     write(buffer,*) ubound(arg)
 119     if (buffer /= '           4           5') STOP 31
 120     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 121     write(buffer,*) id(ubound(arg))
 122     if (buffer /= '           4           5') STOP 32
 123
 124     !print *, shape(arg)
 125     !print *, id(shape(arg))
 126     if (any(shape(arg) /= [3, 8])) STOP 33
 127     if (any(id(shape(arg)) /= [3, 8])) STOP 34
 128     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 129     write(buffer,*) shape(arg)
 130     if (buffer /= '           3           8') STOP 35
 131     buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
 132     write(buffer,*) id(shape(arg))
 133     if (buffer /= '           3           8') STOP 36
 134
 135   end subroutine baz
 136   elemental function id(arg)
 137     integer, intent(in) :: arg
 138     integer             :: id
 139
 140     id = arg
 141   end function id
 142 end program test
 143