Initial version.

Author: rasmussn

tests/annex_c/c_10_2_1.f90

@@ -0,0 +1,33 @@
+module ftn_c_1
+  use, intrinsic :: iso_c_binding
+end module ftn_c_1
+
+module ftn_c_2
+  interface
+     ! isn't this an error, since c_int won't be defined in time because it's
+     ! not defined until the use ftn_c_1 below??
+     integer(c_int) function c_library_function &
+          (sendbuf, sendcount, recvcounts) &
+          bind(c, name='C_Library_function')
+       use ftn_c_1
+       implicit none
+       type(c_ptr), value :: sendbuf
+       integer(c_int), value :: sendcount
+       type(c_ptr), value :: recvcounts
+     end function c_library_function
+  end interface
+end module ftn_c_2
+
+use, intrinsic :: iso_c_binding, only: c_int, c_float, c_loc
+use ftn_c_2
+
+real(c_float), target :: send(100)
+integer(c_int) :: sendcount
+integer(c_int), allocatable, target :: recvcounts(100)
+
+allocate( recvcounts(100) )
+
+call c_library_function(c_loc(send), sendcoutn, &
+     c_loc(recvcounts))
+
+end

tests/annex_c/c_10_2_2.f90

@@ -0,0 +1,25 @@
+subroutine simulation(alpha, beta, gamma, delta, arrays) bind(c)
+  use, intrinsic :: iso_c_binding
+  implicit none
+  integer(c_long), value :: alpha
+  real (c_double), intent(inout) :: beta
+  integer(c_long), intent(out) :: gamma
+  real(c_double),dimension(*),intent(in) :: delta
+  type, bind(c) :: pass
+     integer(c_int) :: lenc, lenf
+     type(c_ptr) :: c, f
+  end type pass
+  type(pass), intent(inout) :: arrays
+  real (c_float), allocatable, target, save :: eta(:)
+  real(c_float), pointer :: c_array(:)
+
+  ! Associate c_array with an array allocated in C
+  call c_f_pointer (arrays%c, c_array, (/arrays%lenc/) )
+
+  ! Allocate an array and make it available in C
+  arrays%lenf = 100
+  allocate (eta(arrays%lenf))
+  arrays%f = c_loc(eta)
+
+end subroutine simulation
+

tests/annex_c/c_10_2_3.f90

@@ -0,0 +1,16 @@
+use, intrinsic :: iso_c_binding
+
+interface
+   subroutine process_buffer(buffer, n_bytes) bind(c,name="ProcessBuffer")
+     import :: c_ptr, c_int
+     type(c_ptr), value :: buffer ! The "C address" of the array buffer
+     integer(c_int), value :: n_bytes ! Number of bytes in buffer
+   end subroutine process_buffer
+end interface
+
+real(r_quad), dimension(:), allocatable, target :: quad_array
+
+call process_buffer(c_loc(quad_array), int(16*size(quad_array),c_int))
+! One quead real takes 16 bytes on this processor
+
+end 

tests/annex_c/c_10_2_4.f90

@@ -0,0 +1,60 @@
+module assumed_module ! i added this
+  use, intrinsic :: iso_c_binding
+  ! Assume this code is inside a module
+
+  type random_stream
+     ! A (uniform) random number generator (URNG)
+   contains
+     procedure(random_uniform), deferred, pass(stream) :: next
+     ! Generates the next number from the stream
+  end type random_stream
+
+  abstract interface
+     ! Abstract interface of Fortran URNG
+     subroutine random_uniform(stream, number)
+       import :: random_stream, c_double
+       class(random_stream), intent(inout) :: stream
+       real(c_duoble), intent(out) :: number
+     end subroutine random_uniform
+  end interface
+
+  type :: urng_state ! No BIND(C), as this type is not interoperable
+     class(random_stream), allocatable :: stream
+  end type urng_state
+
+contains ! i added this
+  subroutine initialize_urng(state_handle, method) &
+       bind(c, name="InitializeURNG")
+    type(c_ptr), intent(out) :: state_handle
+    ! An opaque handle for the URNG
+    character(c_char), dimension(*), intent(in) :: method
+    ! The algorithm to be used
+    type(urng_state), pointer :: state
+    ! An actual URNG object
+    allocate(state)
+    ! There needs to be a corresponding finalizatin
+    ! procedure to avoid memory leaks, not shown in this example
+    ! Allocate state%stream with a dynamic type depending on method
+
+    state_handle=c_loc(state)
+    ! Obtain an opaque handle to return to C
+  end subroutine initialize_urng
+
+  ! Generate a random number:
+  subroutine generate_uniform(state_handle, number) &
+       bind(c, name="GenerateUniform")
+    type(c_ptr), intent(in), value :: state_handle
+    ! An opaque handle: Obained via a call to initialize_urng
+    real(c_double), intent(out) :: number
+    
+    type(urng_state), pointer :: state
+    ! A pointer to the actual urng
+
+    call c_f_pointer(c_ptr=state_handle, fptr=state)
+    ! Convert the opaque handle into a usable pointer
+    call state%stream%next(number)
+    ! Use the type-bound procedure next to generate number
+  end subroutine generate_uniform
+end module assumed_module
+
+  

tests/annex_c/c_11_1_1.f90

@@ -0,0 +1,13 @@
+program a
+  integer i, j
+
+contains
+  subroutine b
+    integer i  ! Declaration of i hides 
+               ! program a's declaration of i
+
+    i = j      ! Use of variable j from program a
+               ! through host association
+  end subroutine b
+end program a
+

tests/annex_c/c_11_1_2.f90

@@ -0,0 +1,16 @@
+program a
+  type t
+     integer :: field ! add a field to it (not in draft)
+  end type t
+
+contains
+  subroutine b
+    implicit type(t) (c) ! Refers to type T declared below
+                         ! in subroutine B, not type T
+                         ! declared above in program a
+    type t
+       integer :: this_field ! add a field (not in draft) 
+    end type t
+  end subroutine b
+end program a
+

tests/annex_c/c_11_1_3.f90

@@ -0,0 +1,10 @@
+program q
+  real(kind=1) :: c
+  
+contains
+  subroutine r
+    real(kind = kind(c)) :: D   ! Invalid declaration
+                                ! See below
+    real(kind=2) :: c
+  end subroutine r
+end program q

tests/annex_c/c_11_2_1.f90

@@ -0,0 +1,12 @@
+interface good1
+   function f1a(x)
+     real :: f1a, x
+   end function f1a
+   function f1b(x)
+     integer :: f1b, x
+   end function f1b
+end interface good1
+
+end
+
+

tests/annex_c/c_11_2_2.f90

@@ -0,0 +1,11 @@
+interface good2
+   function f2a(x)
+     real :: f2a, x
+   end function f2a
+   function f2b(x,y)
+     complex :: f2b
+     real :: x,y
+   end function f2b
+end interface good2
+
+end

tests/annex_c/c_11_2_3.f90

@@ -0,0 +1,13 @@
+interface good3
+   subroutine s3a(w,x,y,z)
+     real :: w,y
+     integer :: x,z
+   end subroutine s3a
+   subroutine s3b(x,w,z,y)
+     real :: w,z
+     integer :: x,y
+   end subroutine s3b
+end interface good3
+
+end
+