[patch, libfortran] Fix PR 40187

[Thomas Koenig]

Hello world,

this fixes PR 40187, where we didn't use strides in the "shape" argument
to c_f_pointer.

Regression-tested on trunk, on i686-pc-linux-gnu.  OK for trunk and
fortran-dev?

	Thomas

2009-05-23  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/40187
	* intrinsics/iso_c_binding.c (c_f_pointer_u0):  Take care
	of stride in "shape" argument.

-------------- next part --------------
A non-text attachment was scrubbed...
Name: iso-c.diff
Type: text/x-patch
Size: 3109 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/gcc-patches/attachments/20090523/25797e14/attachment.bin>
-------------- next part --------------
! { dg-do run }
! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c }
! Verify that the optional SHAPE parameter to c_f_pointer can be of any
! valid integer kind.  We don't test all kinds here since it would be 
! difficult to know what kinds are valid for the architecture we're running on.
! However, testing ones that should be different should be sufficient.
module c_f_pointer_shape_tests_4
  use, intrinsic :: iso_c_binding
  implicit none
contains
  subroutine test_long_long_1d(cPtr, num_elems) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_elems
    integer, dimension(:), pointer :: myArrayPtr
    integer(c_long_long), dimension(1) :: shape
    integer :: i
    
    shape(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do
  end subroutine test_long_long_1d

  subroutine test_long_long_2d(cPtr, num_rows, num_cols) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_rows
    integer(c_int), value :: num_cols
    integer, dimension(:,:), pointer :: myArrayPtr
    integer(c_long_long), dimension(3) :: shape
    integer :: i,j
    
    shape(1) = num_rows
    shape(2) = -3;
    shape(3) = num_cols
    call c_f_pointer(cPtr, myArrayPtr, shape(1:3:2)) 
    do j = 1, num_cols
       do i = 1, num_rows
          if(myArrayPtr(i,j) /= ((j-1)*num_rows)+(i-1)) call abort ()
       end do
    end do
  end subroutine test_long_long_2d

  subroutine test_long_1d(cPtr, num_elems) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_elems
    integer, dimension(:), pointer :: myArrayPtr
    integer(c_long), dimension(1) :: shape
    integer :: i
    
    shape(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do
  end subroutine test_long_1d

  subroutine test_int_1d(cPtr, num_elems) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_elems
    integer, dimension(:), pointer :: myArrayPtr
    integer(c_int), dimension(1) :: shape
    integer :: i
    
    shape(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do
  end subroutine test_int_1d

  subroutine test_short_1d(cPtr, num_elems) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_elems
    integer, dimension(:), pointer :: myArrayPtr
    integer(c_short), dimension(1) :: shape
    integer :: i
    
    shape(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do
  end subroutine test_short_1d

  subroutine test_mixed(cPtr, num_elems) bind(c)
    use, intrinsic :: iso_c_binding
    type(c_ptr), value :: cPtr
    integer(c_int), value :: num_elems
    integer, dimension(:), pointer :: myArrayPtr
    integer(c_int), dimension(1) :: shape1
    integer(c_long_long), dimension(1) :: shape2
    integer :: i

    shape1(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape1) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do

    nullify(myArrayPtr)
    shape2(1) = num_elems
    call c_f_pointer(cPtr, myArrayPtr, shape2) 
    do i = 1, num_elems
       if(myArrayPtr(i) /= (i-1)) call abort ()
    end do
  end subroutine test_mixed
end module c_f_pointer_shape_tests_4
! { dg-final { cleanup-modules "c_f_pointer_shape_tests_2" } } 

-------------- next part --------------
A non-text attachment was scrubbed...
Name: c_f_pointer_shape_tests_4_driver.c
Type: text/x-csrc
Size: 1408 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/gcc-patches/attachments/20090523/25797e14/attachment-0001.bin>