From 65a5a63e39b8eeb539b37435568fe615e1cd189f Mon Sep 17 00:00:00 2001 From: kargl Date: Sat, 21 Jul 2007 23:45:44 +0000 Subject: [PATCH] 2007-07-21 Christopher D. Rickett 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 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 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 --- gcc/fortran/ChangeLog | 9 + gcc/fortran/resolve.c | 12 ++ gcc/fortran/symbol.c | 3 + gcc/testsuite/ChangeLog | 18 +- gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03 | 61 ++++++ .../gfortran.dg/c_f_pointer_complex_driver.c | 41 ++++ gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03 | 34 ++++ .../gfortran.dg/c_f_pointer_logical_driver.c | 26 +++ .../gfortran.dg/c_f_pointer_shape_tests_2.f03 | 91 +++++++++ .../gfortran.dg/c_f_pointer_shape_tests_2_driver.c | 41 ++++ gcc/testsuite/gfortran.dg/pr32627.f03 | 32 ++++ gcc/testsuite/gfortran.dg/pr32627_driver.c | 4 + libgfortran/ChangeLog | 15 ++ libgfortran/gfortran.map | 9 + libgfortran/intrinsics/iso_c_binding.c | 23 ++- libgfortran/intrinsics/iso_c_generated_procs.c | 207 +++++++++++++++++++++ libgfortran/mk-kinds-h.sh | 6 + 17 files changed, 630 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_complex.f03 create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_complex_driver.c create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_logical.f03 create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_logical_driver.c create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03 create mode 100644 gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c create mode 100644 gcc/testsuite/gfortran.dg/pr32627.f03 create mode 100644 gcc/testsuite/gfortran.dg/pr32627_driver.c 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 + 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 + 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 +2007-07-21 Christopher D. Rickett + + 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 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 + +#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"; +} diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 560e8bc..56c5fcd 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,18 @@ +2007-07-21 Christopher D. Rickett + + 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 PR fortran/32600 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index f8d184a..f118bf3 100644 --- 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_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; diff --git a/libgfortran/intrinsics/iso_c_binding.c b/libgfortran/intrinsics/iso_c_binding.c index d73a9ce..101cc4e 100644 --- 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; - 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. diff --git a/libgfortran/intrinsics/iso_c_generated_procs.c b/libgfortran/intrinsics/iso_c_generated_procs.c index f60b264..aee0e57 100644 --- 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 + #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) (void *c_ptr_in, (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 --- a/libgfortran/mk-kinds-h.sh +++ b/libgfortran/mk-kinds-h.sh @@ -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 "" -- 2.7.4