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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126817 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 87e5c6a..2e627da 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
 2007-07-21  Christopher D. Rickett  <crickett@lanl.gov>
 
 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.
        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 (file)
--- 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;
         }
           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.  */
       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);
         
          /* 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;
        }
          /* 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 (file)
--- 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;
 
   /* 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 ();
 
   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 (file)
--- 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.
 
        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 (file)
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 (file)
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 (file)
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 (file)
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 (file)
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 (file)
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 (file)
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 (file)
index 0000000..24b7872
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32627_driver.c
@@ -0,0 +1,4 @@
+char *get_c_string()
+{
+  return "c_string";
+}

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 560e8bc..56c5fcd 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,18 @@
+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-19  Christopher D. Rickett  <crickett@lanl.gov>
 
        PR fortran/32600
 2007-07-19  Christopher D. Rickett  <crickett@lanl.gov>
 
        PR fortran/32600

diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index f8d184a..f118bf3 100644 (file)
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1016,6 +1016,15 @@ GFORTRAN_1.0 {
     __iso_c_binding_c_f_pointer_r8;
     __iso_c_binding_c_f_pointer_r10;
     __iso_c_binding_c_f_pointer_r16;
     __iso_c_binding_c_f_pointer_r8;
     __iso_c_binding_c_f_pointer_r10;
     __iso_c_binding_c_f_pointer_r16;

+    __iso_c_binding_c_f_pointer_c4;
+    __iso_c_binding_c_f_pointer_c8;
+    __iso_c_binding_c_f_pointer_c10;
+    __iso_c_binding_c_f_pointer_c16;
+    __iso_c_binding_c_f_pointer_s0;
+    __iso_c_binding_c_f_pointer_l1;
+    __iso_c_binding_c_f_pointer_l2;
+    __iso_c_binding_c_f_pointer_l4;
+    __iso_c_binding_c_f_pointer_l8;

     __iso_c_binding_c_f_pointer_u0;
     __iso_c_binding_c_f_procpointer;
     __iso_c_binding_c_funloc;
     __iso_c_binding_c_f_pointer_u0;
     __iso_c_binding_c_f_procpointer;
     __iso_c_binding_c_funloc;

diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c
index d73a9ce..101cc4e 100644 (file)
--- a/libgfortran/intrinsics/iso_c_binding.c
+++ b/libgfortran/intrinsics/iso_c_binding.c
@@ -109,7 +109,28 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
         {
           /* Lower bound is 1, as specified by the draft.  */
           f_ptr_out->dim[i].lbound = 1;
         {
           /* Lower bound is 1, as specified by the draft.  */
           f_ptr_out->dim[i].lbound = 1;

-          f_ptr_out->dim[i].ubound = ((int *) (shape->data))[i];
+          /* Have to allow for the SHAPE array to be any valid kind for
+             an INTEGER type.  */
+#ifdef HAVE_GFC_INTEGER_1
+         if (GFC_DESCRIPTOR_SIZE (shape) == 1)
+           f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i];
+#endif
+#ifdef HAVE_GFC_INTEGER_2
+         if (GFC_DESCRIPTOR_SIZE (shape) == 2)
+           f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i];
+#endif
+#ifdef HAVE_GFC_INTEGER_4
+         if (GFC_DESCRIPTOR_SIZE (shape) == 4)
+           f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i];
+#endif
+#ifdef HAVE_GFC_INTEGER_8
+         if (GFC_DESCRIPTOR_SIZE (shape) == 8)
+           f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i];
+#endif
+#ifdef HAVE_GFC_INTEGER_16
+         if (GFC_DESCRIPTOR_SIZE (shape) == 16)
+           f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i];
+#endif         

         }
 
       /* Set the offset and strides.
         }
 
       /* Set the offset and strides.

diff --git a/libgfortran/intrinsics/iso_c_generated_procs.c b/libgfortran/intrinsics/iso_c_generated_procs.c
index f60b264..aee0e57 100644 (file)
--- a/libgfortran/intrinsics/iso_c_generated_procs.c
+++ b/libgfortran/intrinsics/iso_c_generated_procs.c
@@ -75,11 +75,57 @@ void ISO_C_BINDING_PREFIX (c_f_pointer_r8) (void *, gfc_array_void *,
 void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *, gfc_array_void *,
                                             const array_t *);
 #endif
 void ISO_C_BINDING_PREFIX (c_f_pointer_r10) (void *, gfc_array_void *,
                                             const array_t *);
 #endif

+

 #ifdef HAVE_GFC_REAL_16
 void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *, gfc_array_void *,
                                             const array_t *);
 #endif
 
 #ifdef HAVE_GFC_REAL_16
 void ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *, gfc_array_void *,
                                             const array_t *);
 #endif
 

+#ifdef HAVE_GFC_COMPLEX_4
+void ISO_C_BINDING_PREFIX (c_f_pointer_c4) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_COMPLEX_8
+void ISO_C_BINDING_PREFIX (c_f_pointer_c8) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_COMPLEX_10
+void ISO_C_BINDING_PREFIX (c_f_pointer_c10) (void *, gfc_array_void *,
+                                            const array_t *);
+#endif
+
+#ifdef HAVE_GFC_COMPLEX_16
+void ISO_C_BINDING_PREFIX (c_f_pointer_c16) (void *, gfc_array_void *,
+                                            const array_t *);
+#endif
+
+#ifdef GFC_DEFAULT_CHAR
+void ISO_C_BINDING_PREFIX (c_f_pointer_s0) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_LOGICAL_1
+void ISO_C_BINDING_PREFIX (c_f_pointer_l1) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_LOGICAL_2
+void ISO_C_BINDING_PREFIX (c_f_pointer_l2) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_LOGICAL_4
+void ISO_C_BINDING_PREFIX (c_f_pointer_l4) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+
+#ifdef HAVE_GFC_LOGICAL_8
+void ISO_C_BINDING_PREFIX (c_f_pointer_l8) (void *, gfc_array_void *,
+                                           const array_t *);
+#endif
+

 
 #ifdef HAVE_GFC_INTEGER_1
 /* Set the given Fortran pointer, 'f_ptr_out', to point to the given C
 
 #ifdef HAVE_GFC_INTEGER_1
 /* Set the given Fortran pointer, 'f_ptr_out', to point to the given C


@@ -262,3 +308,164 @@ ISO_C_BINDING_PREFIX (c_f_pointer_r16) (void *c_ptr_in,
                                      (int) sizeof (GFC_REAL_16));
 }
 #endif
                                      (int) sizeof (GFC_REAL_16));
 }
 #endif

+
+
+#ifdef HAVE_GFC_COMPLEX_4
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type complex and
+   kind=4.  The function c_f_pointer is used to set up the pointer
+   descriptor.  */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_c4) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have an complex(kind=4).  */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_COMPLEX,
+                                     (int) sizeof (GFC_COMPLEX_4));
+}
+#endif
+
+
+#ifdef HAVE_GFC_COMPLEX_8
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type complex and
+   kind=8.  The function c_f_pointer is used to set up the pointer
+   descriptor.  */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_c8) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have an complex(kind=8).  */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_COMPLEX,
+                                     (int) sizeof (GFC_COMPLEX_8));
+}
+#endif
+
+
+#ifdef HAVE_GFC_COMPLEX_10
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type complex and
+   kind=10.  The function c_f_pointer is used to set up the pointer
+   descriptor.  */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_c10) (void *c_ptr_in,
+                                       gfc_array_void *f_ptr_out,
+                                       const array_t *shape)
+{
+  /* Here we have an complex(kind=10).  */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_COMPLEX,
+                                     (int) sizeof (GFC_COMPLEX_10));
+}
+#endif
+
+
+#ifdef HAVE_GFC_COMPLEX_16
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type complex and
+   kind=16.  The function c_f_pointer is used to set up the pointer
+   descriptor.  */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_c16) (void *c_ptr_in,
+                                       gfc_array_void *f_ptr_out,
+                                       const array_t *shape)
+{
+  /* Here we have an complex(kind=16).  */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_COMPLEX,
+                                     (int) sizeof (GFC_COMPLEX_16));
+}
+#endif
+
+
+#ifdef GFC_DEFAULT_CHAR
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type character.  */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_s0) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have a character string of len=1.  */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_CHARACTER,
+                                     (int) sizeof (char));
+}
+#endif
+
+
+#ifdef HAVE_GFC_LOGICAL_1
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type logical, kind=1. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_l1) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have a logical of kind=1. */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_LOGICAL,
+                                     (int) sizeof (GFC_LOGICAL_1));
+}
+#endif
+
+
+#ifdef HAVE_GFC_LOGICAL_2
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type logical, kind=2. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_l2) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have a logical of kind=2. */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_LOGICAL,
+                                     (int) sizeof (GFC_LOGICAL_2));
+}
+#endif
+
+
+#ifdef HAVE_GFC_LOGICAL_4
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type logical, kind=4. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_l4) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have a logical of kind=4. */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_LOGICAL,
+                                     (int) sizeof (GFC_LOGICAL_4));
+}
+#endif
+
+
+#ifdef HAVE_GFC_LOGICAL_8
+/* Set the given Fortran pointer, f_ptr_out, to point to the given C
+   address, c_ptr_in.  The Fortran pointer is of type logical, kind=8. */
+
+void
+ISO_C_BINDING_PREFIX (c_f_pointer_l8) (void *c_ptr_in,
+                                      gfc_array_void *f_ptr_out,
+                                      const array_t *shape)
+{
+  /* Here we have a logical of kind=8. */
+  ISO_C_BINDING_PREFIX (c_f_pointer) (c_ptr_in, f_ptr_out, shape,
+                                     (int) GFC_DTYPE_LOGICAL,
+                                     (int) sizeof (GFC_LOGICAL_8));
+}
+#endif

diff --git a/libgfortran/mk-kinds-h.sh b/libgfortran/mk-kinds-h.sh
index 98328b6..ccd0738 100755 (executable)
--- a/libgfortran/mk-kinds-h.sh
+++ b/libgfortran/mk-kinds-h.sh
@@ -8,6 +8,7 @@ possible_real_kinds="4 8 10 16"
 
 
 largest=""
 
 
 largest=""

+smallest=""

 for k in $possible_integer_kinds; do
   echo "  integer (kind=$k) :: i" > tmp$$.f90
   echo "  end" >> tmp$$.f90
 for k in $possible_integer_kinds; do
   echo "  integer (kind=$k) :: i" > tmp$$.f90
   echo "  end" >> tmp$$.f90


@@ -21,6 +22,10 @@ for k in $possible_integer_kinds; do
       prefix=""
     fi
 
       prefix=""
     fi
 

+    if [ "$smallest" = "" ]; then
+       smallest="$k"
+    fi
+

     echo "typedef ${prefix}int${s}_t GFC_INTEGER_${k};"
     echo "typedef ${prefix}uint${s}_t GFC_UINTEGER_${k};"
     echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};"
     echo "typedef ${prefix}int${s}_t GFC_INTEGER_${k};"
     echo "typedef ${prefix}uint${s}_t GFC_UINTEGER_${k};"
     echo "typedef GFC_INTEGER_${k} GFC_LOGICAL_${k};"


@@ -32,6 +37,7 @@ done
 
 echo "#define GFC_INTEGER_LARGEST GFC_INTEGER_${largest}"
 echo "#define GFC_UINTEGER_LARGEST GFC_UINTEGER_${largest}"
 
 echo "#define GFC_INTEGER_LARGEST GFC_INTEGER_${largest}"
 echo "#define GFC_UINTEGER_LARGEST GFC_UINTEGER_${largest}"

+echo "#define GFC_DEFAULT_CHAR ${smallest}"

 echo ""
 
 
 echo ""