gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03

   1 ! { dg-do run }
   2 ! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c }
   3 ! Verify that the optional SHAPE parameter to c_f_pointer can be of any
   4 ! valid integer kind.  We don't test all kinds here since it would be
   5 ! difficult to know what kinds are valid for the architecture we're running on.
   6 ! However, testing ones that should be different should be sufficient.
   7 module c_f_pointer_shape_tests_2
   8   use, intrinsic :: iso_c_binding
   9   implicit none
  10 contains
  11   subroutine test_long_long_1d(cPtr, num_elems) bind(c)
  12     use, intrinsic :: iso_c_binding
  13     type(c_ptr), value :: cPtr
  14     integer(c_int), value :: num_elems
  15     integer, dimension(:), pointer :: myArrayPtr
  16     integer(c_long_long), dimension(1) :: shape
  17     integer :: i
  18
  19     shape(1) = num_elems
  20     call c_f_pointer(cPtr, myArrayPtr, shape)
  21     do i = 1, num_elems
  22        if(myArrayPtr(i) /= (i-1)) call abort ()
  23     end do
  24   end subroutine test_long_long_1d
  25
  26   subroutine test_long_long_2d(cPtr, num_rows, num_cols) bind(c)
  27     use, intrinsic :: iso_c_binding
  28     type(c_ptr), value :: cPtr
  29     integer(c_int), value :: num_rows
  30     integer(c_int), value :: num_cols
  31     integer, dimension(:,:), pointer :: myArrayPtr
  32     integer(c_long_long), dimension(2) :: shape
  33     integer :: i,j
  34
  35     shape(1) = num_rows
  36     shape(2) = num_cols
  37     call c_f_pointer(cPtr, myArrayPtr, shape)
  38     do j = 1, num_cols
  39        do i = 1, num_rows
  40           if(myArrayPtr(i,j) /= ((j-1)*num_rows)+(i-1)) call abort ()
  41        end do
  42     end do
  43   end subroutine test_long_long_2d
  44
  45   subroutine test_long_1d(cPtr, num_elems) bind(c)
  46     use, intrinsic :: iso_c_binding
  47     type(c_ptr), value :: cPtr
  48     integer(c_int), value :: num_elems
  49     integer, dimension(:), pointer :: myArrayPtr
  50     integer(c_long), dimension(1) :: shape
  51     integer :: i
  52
  53     shape(1) = num_elems
  54     call c_f_pointer(cPtr, myArrayPtr, shape)
  55     do i = 1, num_elems
  56        if(myArrayPtr(i) /= (i-1)) call abort ()
  57     end do
  58   end subroutine test_long_1d
  59
  60   subroutine test_int_1d(cPtr, num_elems) bind(c)
  61     use, intrinsic :: iso_c_binding
  62     type(c_ptr), value :: cPtr
  63     integer(c_int), value :: num_elems
  64     integer, dimension(:), pointer :: myArrayPtr
  65     integer(c_int), dimension(1) :: shape
  66     integer :: i
  67
  68     shape(1) = num_elems
  69     call c_f_pointer(cPtr, myArrayPtr, shape)
  70     do i = 1, num_elems
  71        if(myArrayPtr(i) /= (i-1)) call abort ()
  72     end do
  73   end subroutine test_int_1d
  74
  75   subroutine test_short_1d(cPtr, num_elems) bind(c)
  76     use, intrinsic :: iso_c_binding
  77     type(c_ptr), value :: cPtr
  78     integer(c_int), value :: num_elems
  79     integer, dimension(:), pointer :: myArrayPtr
  80     integer(c_short), dimension(1) :: shape
  81     integer :: i
  82
  83     shape(1) = num_elems
  84     call c_f_pointer(cPtr, myArrayPtr, shape)
  85     do i = 1, num_elems
  86        if(myArrayPtr(i) /= (i-1)) call abort ()
  87     end do
  88   end subroutine test_short_1d
  89
  90   subroutine test_mixed(cPtr, num_elems) bind(c)
  91     use, intrinsic :: iso_c_binding
  92     type(c_ptr), value :: cPtr
  93     integer(c_int), value :: num_elems
  94     integer, dimension(:), pointer :: myArrayPtr
  95     integer(c_int), dimension(1) :: shape1
  96     integer(c_long_long), dimension(1) :: shape2
  97     integer :: i
  98
  99     shape1(1) = num_elems
 100     call c_f_pointer(cPtr, myArrayPtr, shape1)
 101     do i = 1, num_elems
 102        if(myArrayPtr(i) /= (i-1)) call abort ()
 103     end do
 104
 105     nullify(myArrayPtr)
 106     shape2(1) = num_elems
 107     call c_f_pointer(cPtr, myArrayPtr, shape2)
 108     do i = 1, num_elems
 109        if(myArrayPtr(i) /= (i-1)) call abort ()
 110     end do
 111   end subroutine test_mixed
 112 end module c_f_pointer_shape_tests_2
 113 ! { dg-final { cleanup-modules "c_f_pointer_shape_tests_2" } }
 114