re PR fortran/32627 ([ISO Bind C] Accept c_f_pointer for TYPE)

2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>

        PR fortran/32627
        * resolve.c (set_name_and_label): Set kind number for character
        version of c_f_pointer.
        (gfc_iso_c_sub_interface): Set the kind of the SHAPE formal arg to
        that of the actual SHAPE arg.
        * symbol.c (gen_shape_param): Initialize kind for SHAPE arg.

2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>

        PR fortran/32627
        * libgfortran/intrinsics/iso_c_generated_procs.c: Add c_f_pointer
        for character/string arguments.
        * libgfortran/intrinsic/iso_c_binding.c (c_f_pointer_u0): Allow
        the optional SHAPE arg to be any valid integer kind.
        * libgfortran/gfortran.map: Add c_f_pointer_s0.
        * libgfortran/mk-kinds-h.sh: Save smallest integer kind as default
        character kind.
        * libgfortran/intrinsics/iso_c_generated_procs.c: Add versions of
        c_f_pointer for complex and logical types.
        * libgfortran/gfortran.map: Add c_f_pointer versions for logical
        and complex types.

2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>

        PR fortran/32627
        * gfortran.dg/pr32627_driver.c: Driver for pr32627.
        * gfortran.dg/pr32627.f03: New test case.
        * gfortran.dg/c_f_pointer_logical.f03: New test case.
        * gfortran.dg/c_f_pointer_logical_driver.c: Driver for
        c_f_pointer_logical.
        * gfortran.dg/c_f_pointer_complex_driver.c: Driver for
        c_f_pointer_complex.
        * gfortran.dg/c_f_pointer_complex.f03: New test case.
        * gfortran.dg/c_f_pointer_shape_tests_2_driver.c: Driver for
        c_f_pointer_shape_tests_2.
        * gfortran.dg/c_f_pointer_shape_tests_2.f03: New test case.

From-SVN: r126817

12 files changed, 371 insertions, 1 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 87e5c6a..2e627da 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
 2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
 
+	PR fortran/32627
+	* resolve.c (set_name_and_label): Set kind number for character
+	version of c_f_pointer.
+	(gfc_iso_c_sub_interface): Set the kind of the SHAPE formal arg to
+	that of the actual SHAPE arg.
+	* symbol.c (gen_shape_param): Initialize kind for SHAPE arg.
+
+2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
+
 	PR fortran/32801
 	* symbol.c (generate_isocbinding_symbol): Remove unnecessary
 	conditional.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f50da8c..45a49e2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2282,6 +2282,11 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym,
           type = gfc_type_letter (arg->ts.type);
           kind = arg->ts.kind;
         }
+
+      if (arg->ts.type == BT_CHARACTER)
+	/* Kind info for character strings not needed.	*/
+	kind = 0;
+
       sprintf (name, "%s_%c%d", sym->name, type, kind);
       /* Set up the binding label as the given symbol's label plus
          the type and kind.  */
@@ -2356,6 +2361,13 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
 	  /* the 1 means to add the optional arg to formal list */
 	  new_sym = get_iso_c_sym (sym, name, binding_label, 1);
 	 
+	  /* Set the kind for the SHAPE array to that of the actual
+	     (if given).  */
+	  if (c->ext.actual != NULL && c->ext.actual->next != NULL
+	      && c->ext.actual->next->expr->rank != 0)
+	    new_sym->formal->next->next->sym->ts.kind =
+	      c->ext.actual->next->next->expr->ts.kind;
+	 
 	  /* for error reporting, say it's declared where the original was */
 	  new_sym->declared_at = sym->declared_at;
 	}
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index f8ca9b3..474de8e 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3421,6 +3421,9 @@ gen_shape_param (gfc_formal_arglist **head,
 
   /* Integer array, rank 1, describing the shape of the object.  */
   param_sym->ts.type = BT_INTEGER;
+  /* Initialize the kind to default integer.  However, it will be overriden
+     during resolution to match the kind of the SHAPE parameter given as
+     the actual argument (to allow for any valid integer kind).  */
   param_sym->ts.kind = gfc_default_integer_kind;   
   param_sym->as = gfc_get_array_spec ();
 
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index b94b0e5..17280f4 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,4 +1,20 @@
-2007-07-19  Christopher D. Rickett  <crickett@lanl.gov>
+2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32627
+	* gfortran.dg/pr32627_driver.c: Driver for pr32627.
+	* gfortran.dg/pr32627.f03: New test case.
+
+	* gfortran.dg/c_f_pointer_logical.f03: New test case.
+	* gfortran.dg/c_f_pointer_logical_driver.c: Driver for
+	c_f_pointer_logical.
+	* gfortran.dg/c_f_pointer_complex_driver.c: Driver for
+	c_f_pointer_complex.
+	* gfortran.dg/c_f_pointer_complex.f03: New test case.
+	* gfortran.dg/c_f_pointer_shape_tests_2_driver.c: Driver for
+	c_f_pointer_shape_tests_2.
+	* gfortran.dg/c_f_pointer_shape_tests_2.f03: New test case.
+
+2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
 
 	PR fortran/32804
 	* gfortran.dg/c_loc_tests_9.f03: New test case.
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03
new file mode 100644
index 0000000..fd97031
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03
@@ -0,0 +1,61 @@
+! { dg-do run }
+! { dg-additional-sources c_f_pointer_complex_driver.c }
+! { dg-options "-std=gnu -w" }
+! Test c_f_pointer for the different types of interoperable complex values.
+module c_f_pointer_complex
+  use, intrinsic :: iso_c_binding, only: c_float_complex, c_double_complex, &
+       c_long_double_complex, c_f_pointer, c_ptr, c_long_double, c_int
+  implicit none
+
+contains
+  subroutine test_complex_scalars(my_c_float_complex, my_c_double_complex, &
+       my_c_long_double_complex) bind(c)
+    type(c_ptr), value :: my_c_float_complex
+    type(c_ptr), value :: my_c_double_complex
+    type(c_ptr), value :: my_c_long_double_complex
+    complex(c_float_complex), pointer :: my_f03_float_complex
+    complex(c_double_complex), pointer :: my_f03_double_complex
+    complex(c_long_double_complex), pointer :: my_f03_long_double_complex
+    
+    call c_f_pointer(my_c_float_complex, my_f03_float_complex)
+    call c_f_pointer(my_c_double_complex, my_f03_double_complex)
+    call c_f_pointer(my_c_long_double_complex, my_f03_long_double_complex)
+
+    if(my_f03_float_complex /= (1.0, 0.0)) call abort ()
+    if(my_f03_double_complex /= (2.0d0, 0.0d0)) call abort ()
+    if(my_f03_long_double_complex /= (3.0_c_long_double, &
+         0.0_c_long_double)) call abort ()
+  end subroutine test_complex_scalars
+
+  subroutine test_complex_arrays(float_complex_array, double_complex_array, &
+       long_double_complex_array, num_elems) bind(c)
+    type(c_ptr), value :: float_complex_array
+    type(c_ptr), value :: double_complex_array
+    type(c_ptr), value :: long_double_complex_array    
+    complex(c_float_complex), pointer, dimension(:) :: f03_float_complex_array
+    complex(c_double_complex), pointer, dimension(:) :: &
+         f03_double_complex_array
+    complex(c_long_double_complex), pointer, dimension(:) :: &
+         f03_long_double_complex_array
+    integer(c_int), value :: num_elems
+    integer :: i
+
+    call c_f_pointer(float_complex_array, f03_float_complex_array, &
+         (/ num_elems /))
+    call c_f_pointer(double_complex_array, f03_double_complex_array, &
+         (/ num_elems /))
+    call c_f_pointer(long_double_complex_array, &
+         f03_long_double_complex_array, (/ num_elems /))
+
+    do i = 1, num_elems
+       if(f03_float_complex_array(i) &
+            /= (i*(1.0, 0.0))) call abort ()
+       if(f03_double_complex_array(i) &
+            /= (i*(1.0d0, 0.0d0))) call abort ()
+       if(f03_long_double_complex_array(i) &
+            /= (i*(1.0_c_long_double, 0.0_c_long_double))) call abort ()
+    end do
+  end subroutine test_complex_arrays
+end module c_f_pointer_complex
+! { dg-final { cleanup-modules "c_f_pointer_complex" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c
new file mode 100644
index 0000000..6286c34
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c
@@ -0,0 +1,41 @@
+/* { dg-options "-std=c99 -w" } */
+/* From c_by_val.c in gfortran.dg.  */
+#define _Complex_I (1.0iF)
+
+#define NUM_ELEMS 10
+
+void test_complex_scalars (float _Complex *float_complex_ptr,
+                           double _Complex *double_complex_ptr,
+                           long double _Complex *long_double_complex_ptr);
+void test_complex_arrays (float _Complex *float_complex_array,
+                          double _Complex *double_complex_array,
+                          long double _Complex *long_double_complex_array,
+                          int num_elems);
+
+int main (int argc, char **argv)
+{
+  float _Complex c1;
+  double _Complex c2;
+  long double _Complex c3;
+  float _Complex c1_array[NUM_ELEMS];
+  double _Complex c2_array[NUM_ELEMS];
+  long double _Complex c3_array[NUM_ELEMS];
+  int i;
+
+  c1 = 1.0 + 0.0 * _Complex_I;
+  c2 = 2.0 + 0.0 * _Complex_I;
+  c3 = 3.0 + 0.0 * _Complex_I;
+
+  test_complex_scalars (&c1, &c2, &c3);
+
+  for (i = 0; i < NUM_ELEMS; i++)
+    {
+      c1_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I;
+      c2_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I;
+      c3_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I;
+    }
+
+  test_complex_arrays (c1_array, c2_array, c3_array, NUM_ELEMS);
+
+  return 0;
+}
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03
new file mode 100644
index 0000000..977c4cb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-additional-sources c_f_pointer_logical_driver.c }
+! Verify that c_f_pointer exists for C logicals (_Bool).
+module c_f_pointer_logical
+  use, intrinsic :: iso_c_binding, only: c_bool, c_f_pointer, c_ptr, c_int
+contains
+  subroutine test_scalar(c_logical_ptr) bind(c)
+    type(c_ptr), value :: c_logical_ptr
+    logical(c_bool), pointer :: f03_logical_ptr
+    call c_f_pointer(c_logical_ptr, f03_logical_ptr)
+    
+    if(f03_logical_ptr .neqv. .true.) call abort ()
+  end subroutine test_scalar
+
+  subroutine test_array(c_logical_array, num_elems) bind(c)
+    type(c_ptr), value :: c_logical_array
+    integer(c_int), value :: num_elems
+    logical(c_bool), pointer, dimension(:) :: f03_logical_array
+    integer :: i
+
+    call c_f_pointer(c_logical_array, f03_logical_array, (/ num_elems /))
+
+    ! Odd numbered locations are true (even numbered offsets in C)
+    do i = 1, num_elems, 2
+       if(f03_logical_array(i) .neqv. .true.) call abort ()
+    end do
+    
+    ! Even numbered locations are false.
+    do i = 2, num_elems, 2
+       if(f03_logical_array(i) .neqv. .false.) call abort ()
+    end do
+  end subroutine test_array
+end module c_f_pointer_logical
+! { dg-final { cleanup-modules "c_f_pointer_logical" } }
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c
new file mode 100644
index 0000000..e3044c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c
@@ -0,0 +1,26 @@
+/* { dg-options "-std=c99 -w" } */
+
+#include <stdbool.h>
+
+#define NUM_ELEMS 10
+
+void test_scalar(_Bool *my_c_bool_ptr);
+void test_array(_Bool *my_bool_array, int num_elems);
+
+int main(int argc, char **argv)
+{
+  _Bool my_bool = true;
+  _Bool my_bool_array[NUM_ELEMS];
+  int i;
+
+  test_scalar(&my_bool);
+
+  for(i = 0; i < NUM_ELEMS; i+=2)
+    my_bool_array[i] = true;
+  for(i = 1; i < NUM_ELEMS; i+=2)
+    my_bool_array[i] = false;
+
+  test_array(my_bool_array, NUM_ELEMS);
+  
+  return 0;
+}
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
new file mode 100644
index 0000000..5d6acc2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
@@ -0,0 +1,91 @@
+! { 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_2
+  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(2) :: shape
+    integer :: i,j
+    
+    shape(1) = num_rows
+    shape(2) = num_cols
+    call c_f_pointer(cPtr, myArrayPtr, shape) 
+    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
+end module c_f_pointer_shape_tests_2
+! { dg-final { cleanup-modules "c_f_pointer_shape_tests_2" } } 
+
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
new file mode 100644
index 0000000..686ae8f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
@@ -0,0 +1,41 @@
+#define NUM_ELEMS 10
+#define NUM_ROWS 2
+#define NUM_COLS 3
+
+void test_long_long_1d(int *array, int num_elems);
+void test_long_long_2d(int *array, int num_rows, int num_cols);
+void test_long_1d(int *array, int num_elems);
+void test_int_1d(int *array, int num_elems);
+void test_short_1d(int *array, int num_elems);
+
+int main(int argc, char **argv)
+{
+  int my_array[NUM_ELEMS];
+  int my_2d_array[NUM_ROWS][NUM_COLS];
+  int i, j;
+
+  for(i = 0; i < NUM_ELEMS; i++)
+    my_array[i] = i;
+
+  for(i = 0; i < NUM_ROWS; i++)
+    for(j = 0; j < NUM_COLS; j++)
+      my_2d_array[i][j] = (i*NUM_COLS) + j;
+
+  /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long.  */
+  test_long_long_1d(my_array, NUM_ELEMS);
+
+  /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long.  
+     The indices are transposed for Fortran.  */
+  test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS);
+
+  /* Test c_f_pointer where SHAPE is of type integer, kind=c_long.  */
+  test_long_1d(my_array, NUM_ELEMS);
+
+  /* Test c_f_pointer where SHAPE is of type integer, kind=c_int.  */
+  test_int_1d(my_array, NUM_ELEMS);
+
+  /* Test c_f_pointer where SHAPE is of type integer, kind=c_short.  */
+  test_short_1d(my_array, NUM_ELEMS);
+  
+  return 0;
+}
diff --git a/gcc/testsuite/gfortran.dg/pr32627.f03 b/gcc/testsuite/gfortran.dg/pr32627.f03
new file mode 100644
index 0000000..f8695e0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32627.f03
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-additional-sources pr32627_driver.c }
+! Verify that c_f_pointer exists for string arguments.
+program main
+  use iso_c_binding
+  implicit none
+  interface
+     function get_c_string() bind(c)
+       use, intrinsic :: iso_c_binding, only: c_ptr
+       type(c_ptr) :: get_c_string
+     end function get_c_string
+  end interface
+
+  type, bind( c ) :: A
+    integer( c_int ) :: xc, yc
+    type( c_ptr )    :: str
+  end type
+  type( c_ptr )               :: x
+  type( A ), pointer          :: fptr
+  type( A ), target           :: my_a_type
+  character( len=9 ), pointer :: strptr
+
+  fptr => my_a_type
+
+  fptr%str = get_c_string()
+
+  call c_f_pointer( fptr%str, strptr )
+
+  print *, 'strptr is: ', strptr
+end program main
+
+  
diff --git a/gcc/testsuite/gfortran.dg/pr32627_driver.c b/gcc/testsuite/gfortran.dg/pr32627_driver.c
new file mode 100644
index 0000000..24b7872
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32627_driver.c
@@ -0,0 +1,4 @@
+char *get_c_string()
+{
+  return "c_string";
+}