gcc/testsuite/gfortran.dg/PR94327.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources PR94327.c }
   3 !
   4 ! Test the fix for PR94327
   5 !
   6
   7 program attr_p
   8
   9   use, intrinsic :: iso_c_binding, only: &
  10     c_int, c_bool, c_char
  11
  12   implicit none
  13
  14   integer            :: i
  15   integer, parameter :: n = 11
  16   integer, parameter :: u(*) = [(i, i=1,n)]
  17
  18   interface
  19     function attr_p_as(a, s) result(c) &
  20       bind(c, name="get_attr")
  21       use, intrinsic :: iso_c_binding, only: &
  22         c_int, c_bool, c_char
  23       implicit none
  24       integer(kind=c_int), pointer, intent(in) :: a(:)
  25       logical(kind=c_bool),  value, intent(in) :: s
  26       character(kind=c_char)                   :: c
  27     end function attr_p_as
  28     function attr_a_as(a, s) result(c) &
  29       bind(c, name="get_attr")
  30       use, intrinsic :: iso_c_binding, only: &
  31         c_int, c_bool, c_char
  32       implicit none
  33       integer(kind=c_int), allocatable, intent(in) :: a(:)
  34       logical(kind=c_bool),      value, intent(in) :: s
  35       character(kind=c_char)                       :: c
  36     end function attr_a_as
  37     function attr_o_as(a, s) result(c) &
  38       bind(c, name="get_attr")
  39       use, intrinsic :: iso_c_binding, only: &
  40         c_int, c_bool, c_char
  41       implicit none
  42       integer(kind=c_int),         intent(in) :: a(:)
  43       logical(kind=c_bool), value, intent(in) :: s
  44       character(kind=c_char)                  :: c
  45     end function attr_o_as
  46     function attr_p_ar(a, s) result(c) &
  47       bind(c, name="get_attr")
  48       use, intrinsic :: iso_c_binding, only: &
  49         c_int, c_bool, c_char
  50       implicit none
  51       integer(kind=c_int), pointer, intent(in) :: a(..)
  52       logical(kind=c_bool),  value, intent(in) :: s
  53       character(kind=c_char)                   :: c
  54     end function attr_p_ar
  55     function attr_a_ar(a, s) result(c) &
  56       bind(c, name="get_attr")
  57       use, intrinsic :: iso_c_binding, only: &
  58         c_int, c_bool, c_char
  59       implicit none
  60       integer(kind=c_int), allocatable, intent(in) :: a(..)
  61       logical(kind=c_bool),      value, intent(in) :: s
  62       character(kind=c_char)                       :: c
  63     end function attr_a_ar
  64     function attr_o_ar(a, s) result(c) &
  65       bind(c, name="get_attr")
  66       use, intrinsic :: iso_c_binding, only: &
  67         c_int, c_bool, c_char
  68       implicit none
  69       integer(kind=c_int),         intent(in) :: a(..)
  70       logical(kind=c_bool), value, intent(in) :: s
  71       character(kind=c_char)                  :: c
  72     end function attr_o_ar
  73   end interface
  74
  75   integer(kind=c_int),              target :: a(n)
  76   integer(kind=c_int), allocatable, target :: b(:)
  77   integer(kind=c_int),             pointer :: p(:)
  78   character(kind=c_char)                   :: c
  79
  80   a = u
  81   c = attr_p_as(a, .true._c_bool)
  82   if(c/='p')                stop 1
  83   if(any(a/=u))             stop 2
  84   !
  85   a = u
  86   c = attr_p_ar(a, .true._c_bool)
  87   if(c/='p')                stop 3
  88   if(any(a/=u))             stop 4
  89   !
  90   a = u
  91   c = attr_o_as(a, .true._c_bool)
  92   if(c/='o')                stop 5
  93   if(any(a/=u))             stop 6
  94   !
  95   a = u
  96   c = attr_o_ar(a, .true._c_bool)
  97   if(c/='o')                stop 7
  98   if(any(a/=u))             stop 8
  99   !
 100   allocate(b, source=u)
 101   c = attr_p_as(b, .true._c_bool)
 102   if(c/='p')                stop 9
 103   if(.not.allocated(b))     stop 10
 104   if(any(b/=u))             stop 11
 105   !
 106   deallocate(b)
 107   allocate(b, source=u)
 108   c = attr_p_ar(b, .true._c_bool)
 109   if(c/='p')                stop 12
 110   if(.not.allocated(b))     stop 13
 111   if(any(b/=u))             stop 14
 112   !
 113   deallocate(b)
 114   allocate(b, source=u)
 115   c = attr_a_as(b, .true._c_bool)
 116   if(c/='a')                stop 15
 117   if(.not.allocated(b))     stop 16
 118   if(any(b/=u))             stop 17
 119   !
 120   deallocate(b)
 121   allocate(b, source=u)
 122   c = attr_a_ar(b, .true._c_bool)
 123   if(c/='a')                stop 18
 124   if(.not.allocated(b))     stop 19
 125   if(any(b/=u))             stop 20
 126   !
 127   deallocate(b)
 128   allocate(b, source=u)
 129   c = attr_o_as(b, .true._c_bool)
 130   if(c/='o')                stop 21
 131   if(.not.allocated(b))     stop 22
 132   if(any(b/=u))             stop 23
 133   !
 134   deallocate(b)
 135   allocate(b, source=u)
 136   c = attr_o_ar(b, .true._c_bool)
 137   if(c/='o')                stop 24
 138   if(.not.allocated(b))     stop 25
 139   if(any(b/=u))             stop 26
 140   !
 141   deallocate(b)
 142   c = attr_a_as(b, .false._c_bool)
 143   if(c/='a')                stop 27
 144   if(allocated(b))          stop 28
 145   !
 146   c = attr_a_ar(b, .false._c_bool)
 147   if(c/='a')                stop 29
 148   if(allocated(b))          stop 30
 149   !
 150   nullify(p)
 151   p => a
 152   c = attr_p_as(p, .true._c_bool)
 153   if(c/='p')                stop 31
 154   if(.not.associated(p))    stop 32
 155   if(.not.associated(p, a)) stop 33
 156   if(any(p/=u))             stop 34
 157   !
 158   nullify(p)
 159   p => a
 160   c = attr_p_ar(p, .true._c_bool)
 161   if(c/='p')                stop 35
 162   if(.not.associated(p))    stop 36
 163   if(.not.associated(p, a)) stop 37
 164   if(any(p/=u))             stop 38
 165   !
 166   nullify(p)
 167   p => a
 168   c = attr_o_as(p, .true._c_bool)
 169   if(c/='o')                stop 39
 170   if(.not.associated(p))    stop 40
 171   if(.not.associated(p, a)) stop 41
 172   if(any(p/=u))             stop 42
 173   !
 174   nullify(p)
 175   p => a
 176   c = attr_o_ar(p, .true._c_bool)
 177   if(c/='o')                stop 43
 178   if(.not.associated(p))    stop 44
 179   if(.not.associated(p, a)) stop 45
 180   if(any(p/=u))             stop 46
 181   !
 182   nullify(p)
 183   c = attr_p_as(p, .false._c_bool)
 184   if(c/='p')                stop 47
 185   if(associated(p))         stop 48
 186   if(associated(p, a))      stop 49
 187   !
 188   nullify(p)
 189   c = attr_p_ar(p, .false._c_bool)
 190   if(c/='p')                stop 50
 191   if(associated(p))         stop 51
 192   if(associated(p, a))      stop 52
 193   stop
 194
 195 end program attr_p