(j3.2006) One more thing for the C TR

[Van Snyder]

It would be useful if the C TR required a header file containing the
values of the named constants in Table 15.2 in the 2008 standard, with
the names specified there, maybe in upper case.

I needed to test whether c_int == kind(0) (alternatively c_long) and
either use c_f_pointer, or use c_f_pointer and allocate and assign and
ultimately deallocate to grab an argument.  I had to trust that the C
side (actually C++ side) was compiled correctly (with the correct
command-line options to create typedefs consistent with the Fortran
side, using #ifdef etc.).  If I had been able to pass the kind as an
argument it would have been helpful.

An example abstracted from the bigger problem is attached.  Be careful
to compile either both with -DLONG or both without -DLONG.

Van

-------------- next part --------------
A non-text attachment was scrubbed...
Name: cpptest.cpp
Type: text/x-c++src
Size: 554 bytes
Desc: not available
URL: <http://j3-fortran.org/pipermail/j3/attachments/20110922/dff646ec/attachment.bin>
-------------- next part --------------
module fortmodule

  implicit none
  private

contains

  subroutine fortfun ( s ) bind(C,name='MyFortfun')

    use, intrinsic :: iso_c_binding, only: c_f_pointer, c_long, c_ptr
    type(c_ptr), intent(in), value :: s
    interface
      function strlen ( P ) bind(C)
        import ! Interface body don't have host access otherwise
        integer(c_long) strlen
        type(c_ptr), intent(in), value :: P
      end function strlen
    end interface
    integer :: i, n
    character, pointer :: c(:)
    n = strlen(s)
    call c_f_pointer ( s, c, [n] )
    write ( *, '(a)', advance='no' ) 'Now in fortfun, received "'
    do i = 1, n
      write ( *, '(a)', advance='no' ) c(i)
    end do
    write ( *, '(a)' ) '"'

  end subroutine fortfun

  subroutine AnotherFun ( c ) bind(C,name='More_Fun')

    use, intrinsic :: iso_c_binding, only: c_null_char
    character, intent(in) :: c(*)
    integer :: i
    i = 0
    write ( *, '(a)', advance='no' ) 'Now in AnotherFun, received "'
    do
      i = i + 1
      if ( c(i) == c_null_char ) exit
      write ( *, '(a)', advance='no' ) c(i)
    end do
    write ( *, '(a)' ) '"'

  end subroutine AnotherFun

  subroutine ArrayFun ( c, rank, dims ) bind(C)

#if (defined LONG)
    use, intrinsic :: iso_c_binding, only: c_f_pointer, c_int, me=>c_long, c_ptr
#else
    use, intrinsic :: iso_c_binding, only: c_f_pointer, c_int, me=>c_int, c_ptr
#endif
    type(c_ptr), intent(in), value :: C
    integer(c_int), intent(in), value :: Rank
    integer(me), intent(in) :: Dims(*)
    integer(me), pointer :: Rank1(:), Rank2(:,:) ! C_INT or C_LONG integer
    integer, pointer :: R1(:), R2(:,:) ! Default integer
    if ( me == kind(0) ) then
      print '(a)', 'In ArrayFun, same kinds'
      select case ( rank )
      case ( 1_c_int )
        call c_f_pointer ( c, rank1, dims(1:rank) )
        print '(6i3)', rank1
      case ( 2_c_int )
        call c_f_pointer ( c, rank2, dims(1:rank) )
        print '(3i3)', rank2
      end select
    else
      print '(a)', 'In ArrayFun, different kinds'
      select case ( rank )
      case ( 1_c_int )
        call c_f_pointer ( c, rank1, dims(1:rank) )
        allocate ( r1(dims(1)) )
        r1 = rank1
        print '(6i3)', r1
        deallocate ( r1 )
      case ( 2_c_int )
        call c_f_pointer ( c, rank2, dims(1:rank) )
        allocate ( r2(dims(1),dims(2)) )
        r2 = rank2
        print '(3i3)', r2
        deallocate ( r2 )
      end select
    end if

  end subroutine ArrayFun

end module fortmodule