[PATCH,fortran]: updated patch for PR 32627
Christopher D. Rickett
crickett@lanl.gov
Wed Jul 18 18:08:00 GMT 2007
hi all,
the attached patch is an updated version of the patch for PR 32627 that
also allows the SHAPE array to be any valid integer kind.
bootstrapped and regtested on x86 and x86_64 linux with no new failures.
Chris
:ADDPATCH fortran:
2007-07-18 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-18 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-18 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.
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/pr32627_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/pr32627_driver.c (revision 0)
+++ gcc/testsuite/gfortran.dg/pr32627_driver.c (revision 0)
@@ -0,0 +1,4 @@
+char *get_c_string()
+{
+ return "c_string";
+}
Index: gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03 (revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/pr32627.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32627.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/pr32627.f03 (revision 0)
@@ -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
+
+
Index: gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c (revision 0)
@@ -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;
+}
Index: gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c (revision 0)
@@ -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;
+}
Index: gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03 (revision 0)
@@ -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" } }
+
Index: gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 (revision 0)
@@ -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" } }
+
Index: gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c
===================================================================
--- gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c (revision 0)
+++ gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c (revision 0)
@@ -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;
+}
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 126704)
+++ gcc/fortran/symbol.c (working copy)
@@ -3421,6 +3421,9 @@ gen_shape_param (gfc_formal_arglist **he
/* 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 (to allow for any valid integer kind). */
param_sym->ts.kind = gfc_default_integer_kind;
param_sym->as = gfc_get_array_spec ();
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 126704)
+++ gcc/fortran/resolve.c (working copy)
@@ -2248,6 +2248,11 @@ set_name_and_label (gfc_code *c, gfc_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. */
@@ -2322,6 +2331,13 @@ gfc_iso_c_sub_interface (gfc_code *c, gf
/* 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;
}
Index: libgfortran/intrinsics/iso_c_generated_procs.c
===================================================================
--- libgfortran/intrinsics/iso_c_generated_procs.c (revision 126704)
+++ libgfortran/intrinsics/iso_c_generated_procs.c (working copy)
@@ -75,11 +75,57 @@ void ISO_C_BINDING_PREFIX (c_f_pointer_r
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_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
@@ -262,3 +308,164 @@ ISO_C_BINDING_PREFIX (c_f_pointer_r16) (
(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
Index: libgfortran/intrinsics/iso_c_binding.c
===================================================================
--- libgfortran/intrinsics/iso_c_binding.c (revision 126704)
+++ libgfortran/intrinsics/iso_c_binding.c (working copy)
@@ -109,7 +109,28 @@ ISO_C_BINDING_PREFIX (c_f_pointer_u0) (v
{
/* 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.
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 126704)
+++ libgfortran/gfortran.map (working copy)
@@ -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_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;
Index: libgfortran/mk-kinds-h.sh
===================================================================
--- libgfortran/mk-kinds-h.sh (revision 126704)
+++ libgfortran/mk-kinds-h.sh (working copy)
@@ -8,6 +8,7 @@ possible_real_kinds="4 8 10 16"
largest=""
+smallest=""
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
+ 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};"
@@ -32,6 +37,7 @@ done
echo "#define GFC_INTEGER_LARGEST GFC_INTEGER_${largest}"
echo "#define GFC_UINTEGER_LARGEST GFC_UINTEGER_${largest}"
+echo "#define GFC_DEFAULT_CHAR ${smallest}"
echo ""
More information about the Fortran
mailing list