+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.
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))
{
/* 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;
}
+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.
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" } }
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)
{
/* 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;
}
--- /dev/null
+! { 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