gcc/testsuite/gfortran.dg/ISO_Fortran_binding_17.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources ISO_Fortran_binding_17.c }
   3 ! { dg-options "-fcheck=all" }
   4 ! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
   5 !
   6 ! PR fortran/92470
   7 !
   8 ! https://github.com/j3-fortran/fortran_proposals/issues/57#issuecomment-552680503
   9 !
  10 ! Unit Test #: Test-1.F2018-2.7.5
  11 ! Author     : FortranFan
  12 ! Reference  : The New Features of Fortran 2018, John Reid, August 2, 2018
  13 !              ISO/IEC JTC1/SC22/WG5 N2161
  14 ! Description:
  15 ! Test item 2.7.5 Fortran subscripting
  16 ! void *CFI_address(const CFI_cdesc_t *dv, const CFI_index_t subscripts[]);
  17 ! that returns the C address of a scalar or of an element of an array using
  18 ! Fortran sub-scripting.
  19 !
  20    use, intrinsic :: iso_c_binding, only: c_int, c_size_t, c_loc
  21    implicit none
  22
  23    integer, parameter :: LB_A = -2
  24    integer, parameter :: UB_A = 1
  25    character(len=*), parameter :: fmtg = "(*(g0,1x))"
  26    character(len=*), parameter :: fmth = "(g0,1x,z0)"
  27
  28    blk1: block
  29       interface
  30          subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
  31             import :: c_size_t
  32             type(*), intent(in) :: a(:)
  33             integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
  34          end subroutine
  35       end interface
  36
  37       integer(c_int), target :: a( LB_A:UB_A )
  38       integer(c_size_t) :: loc_a
  39
  40       print fmtg, "Block 1"
  41
  42       loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a)
  43       print fmth, "Address of a: ", loc_a
  44
  45       call Csub(a, loc_a, -1_c_size_t) ! LB starts at 0
  46       call Csub(a, loc_a, 5_c_size_t)  ! 4 elements + 1
  47       print *
  48    end block blk1
  49
  50    blk2: block
  51       interface
  52          subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
  53             import :: c_int, c_size_t
  54             integer(kind=c_int), allocatable, intent(in) :: a(:)
  55             integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
  56          end subroutine
  57       end interface
  58
  59       integer(c_int), allocatable, target :: a(:)
  60       integer(c_size_t) :: loc_a
  61
  62       print fmtg, "Block 2"
  63
  64       allocate( a( LB_A:UB_A ) )
  65       loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a )
  66       print fmth, "Address of a: ", loc_a
  67
  68       call Csub(a, loc_a, LB_A-1_c_size_t)
  69       call Csub(a, loc_a, UB_A+1_c_size_t)
  70       print *
  71    end block blk2
  72 end
  73
  74 ! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -1, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+)" }
  75 ! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 5, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+).*" }
  76 ! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -3, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" }
  77 ! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 2, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" }