gcc/testsuite/gfortran.dg/PR93308.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR94331
   4 !
   5 ! Contributed by Robin Hogan <r.j.hogan@reading.ac.uk>
   6 !
   7
   8 program test
   9
  10   use, intrinsic :: iso_c_binding, only: &
  11     c_int, c_float
  12
  13   implicit none
  14
  15   integer                       :: i
  16   integer,            parameter :: n = 11
  17   real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)]
  18
  19   real(kind=c_float), allocatable :: A(:)
  20   real(kind=c_float)              :: E(n)
  21   integer(kind=c_int)             :: l1, l2, l3
  22
  23   allocate(A, source=u)
  24   l1 = lbound(A, 1)
  25   call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A...
  26   l3 = lbound(A, 1)
  27   if (l1 /= 1)                        stop 1
  28   if (l1 /= l2)                       stop 2
  29   if (l1 /= l3)                       stop 3
  30   if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4
  31   deallocate(A)
  32   !
  33   E = u
  34   l1 = lbound(E, 1)
  35   call routine_bindc(E, l2) ! ...but does not change lbound of E
  36   l3 = lbound(E, 1)
  37   if (l1 /= 1)                        stop 5
  38   if (l1 /= l2)                       stop 6
  39   if (l1 /= l3)                       stop 7
  40   if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8
  41
  42 contains
  43
  44   subroutine routine_bindc(v, l) bind(c)
  45     real(kind=c_float),  intent(inout) :: v(:)
  46     integer(kind=c_int), intent(out)   :: l
  47
  48     l = lbound(v, 1)
  49     if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9
  50   end subroutine routine_bindc
  51
  52 end program test