procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/33020 (Bind(C): c_f_pointer: type/rank mismatch error with integer(8) SHAPE)

Browse source 
2007-08-22  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/33020
	* resolve.c (gfc_iso_c_sub_interface): Remove setting of type and
	kind for optional SHAPE parameter of C_F_POINTER.

2007-08-22  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/33020
	* gfortran.dg/c_f_pointer_shape_tests_2.f03: Update test to
	include multiple kinds for SHAPE parameter within a single
	namespace.
	* gfortran.dg/c_f_pointer_shape_tests_2_driver.c: Ditto.
	* gfortran.dg/c_f_pointer_shape_tests_3.f03: New test case.

From-SVN: r127719
This commit is contained in:
Christopher D. Rickett 2007-08-22 21:28:08 +00:00 • committed by Tobias Burnus
parent 129d15a3e0
commit aa2f6edbf7
6 changed files with 66 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View file

@ -1,3 +1,9 @@
2007-08-22 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/33020
* resolve.c (gfc_iso_c_sub_interface): Remove setting of type and
kind for optional SHAPE parameter of C_F_POINTER.
2007-08-22 Janus Weil <jaydub66@gmail.com>
* decl.c (match_attr_spec): Pass on errors from gfc_match_bind_c.

12
gcc/fortran/resolve.c
View file

@ -2351,11 +2351,6 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
formal args) before resolving. */
gfc_procedure_use (sym, &c->ext.actual, &(c->loc));
/* Give the optional SHAPE formal arg a type now that we've done our
initial checking against the actual. */
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
sym->formal->next->next->sym->ts.type = BT_INTEGER;
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
@ -2396,13 +2391,6 @@ 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;
}

9
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,12 @@
2007-08-22 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/33020
* gfortran.dg/c_f_pointer_shape_tests_2.f03: Update test to
include multiple kinds for SHAPE parameter within a single
namespace.
* gfortran.dg/c_f_pointer_shape_tests_2_driver.c: Ditto.
* gfortran.dg/c_f_pointer_shape_tests_3.f03: New test case.
2007-08-22 Janus Weil <jaydub66@gmail.com>
* interface_abstract_1.f90: Extended test case.

23
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2.f03
View file

@ -86,6 +86,29 @@ contains
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_short_1d
subroutine test_mixed(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) :: shape1
integer(c_long_long), dimension(1) :: shape2
integer :: i
shape1(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape1)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
nullify(myArrayPtr)
shape2(1) = num_elems
call c_f_pointer(cPtr, myArrayPtr, shape2)
do i = 1, num_elems
if(myArrayPtr(i) /= (i-1)) call abort ()
end do
end subroutine test_mixed
end module c_f_pointer_shape_tests_2
! { dg-final { cleanup-modules "c_f_pointer_shape_tests_2" } }

7
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_2_driver.c
View file

@ -7,6 +7,7 @@ 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);
void test_mixed(int *array, int num_elems);
int main(int argc, char **argv)
{
@ -36,6 +37,10 @@ int main(int argc, char **argv)
/* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */
test_short_1d(my_array, NUM_ELEMS);
/* Test c_f_pointer where SHAPE is of type integer, kind=c_int and
kind=c_long_long. */
test_mixed(my_array, NUM_ELEMS);
return 0;
}

22
gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_3.f03 Normal file
View file

@ -0,0 +1,22 @@
! { dg-do compile }
! Verify that the type and rank of the SHAPE argument are enforced.
module c_f_pointer_shape_tests_3
use, intrinsic :: iso_c_binding
contains
subroutine sub0(my_c_array) bind(c)
type(c_ptr), value :: my_c_array
integer(c_int), dimension(:), pointer :: my_array_ptr
call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be a rank 1 INTEGER array" }
end subroutine sub0
subroutine sub1(my_c_array) bind(c)
type(c_ptr), value :: my_c_array
integer(c_int), dimension(:), pointer :: my_array_ptr
integer(c_int), dimension(1,1) :: shape
shape(1,1) = 10
call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be a rank 1 INTEGER array" }
end subroutine sub1
end module c_f_pointer_shape_tests_3