From 152315665ec17e11bad055588958922ae831def8 Mon Sep 17 00:00:00 2001 From: "Christopher D. Rickett" Date: Thu, 20 Sep 2007 11:50:39 +0000 Subject: [PATCH] re PR fortran/33497 (Bind(C): C_LOC rejects interoperable arguments) 2007-09-20 Christopher D. Rickett PR fortran/33497 * resolve.c (gfc_iso_c_func_interface): Use information from subcomponent if applicable. 2007-09-20 Christopher D. Rickett PR fortran/33497 * gfortran.dg/c_loc_tests_11.f03: New test case. From-SVN: r128620 --- gcc/fortran/ChangeLog | 6 +++ gcc/fortran/resolve.c | 79 +++++++++++++++++++++------- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 | 49 +++++++++++++++++ 4 files changed, 119 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 2bba492..29d8dd2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-09-20 Christopher D. Rickett + + PR fortran/33497 + * resolve.c (gfc_iso_c_func_interface): Use information from + subcomponent if applicable. + 2007-09-20 Tobias Burnus PR fortran/33325 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 5d1c116..1b3aab6 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1754,6 +1754,9 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, int optional_arg = 0; try retval = SUCCESS; gfc_symbol *args_sym; + gfc_typespec *arg_ts; + gfc_ref *parent_ref; + gfc_ref *curr_ref; if (args->expr->expr_type == EXPR_CONSTANT || args->expr->expr_type == EXPR_OP @@ -1765,7 +1768,38 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } args_sym = args->expr->symtree->n.sym; - + + /* The typespec for the actual arg should be that stored in the expr + and not necessarily that of the expr symbol (args_sym), because + the actual expression could be a part-ref of the expr symbol. */ + arg_ts = &(args->expr->ts); + + /* Get the parent reference (if any) for the expression. This happens for + cases such as a%b%c. */ + parent_ref = args->expr->ref; + curr_ref = NULL; + if (parent_ref != NULL) + { + curr_ref = parent_ref->next; + while (curr_ref != NULL && curr_ref->next != NULL) + { + parent_ref = curr_ref; + curr_ref = curr_ref->next; + } + } + + /* If curr_ref is non-NULL, we had a part-ref expression. If the curr_ref + is for a REF_COMPONENT, then we need to use it as the parent_ref for + the name, etc. Otherwise, the current parent_ref should be correct. */ + if (curr_ref != NULL && curr_ref->type == REF_COMPONENT) + parent_ref = curr_ref; + + if (parent_ref == args->expr->ref) + parent_ref = NULL; + else if (parent_ref != NULL && parent_ref->type != REF_COMPONENT) + gfc_internal_error ("Unexpected expression reference type in " + "gfc_iso_c_func_interface"); + if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) { /* If the user gave two args then they are providing something for @@ -1807,21 +1841,24 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, else if (sym->intmod_sym_id == ISOCBINDING_LOC) { /* Make sure we have either the target or pointer attribute. */ - if (!(args->expr->symtree->n.sym->attr.target) - && !(args->expr->symtree->n.sym->attr.pointer)) + if (!(args_sym->attr.target) + && !(args_sym->attr.pointer) + && (parent_ref == NULL || + !parent_ref->u.c.component->pointer)) { gfc_error_now ("Parameter '%s' to '%s' at %L must be either " "a TARGET or an associated pointer", - args->expr->symtree->n.sym->name, + args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } /* See if we have interoperable type and type param. */ - if (verify_c_interop (&(args->expr->symtree->n.sym->ts), - args->expr->symtree->n.sym->name, + if (verify_c_interop (arg_ts, + (parent_ref ? parent_ref->u.c.component->name + : args_sym->name), &(args->expr->where)) == SUCCESS - || gfc_check_any_c_kind (&(args_sym->ts)) == SUCCESS) + || gfc_check_any_c_kind (arg_ts) == SUCCESS) { if (args_sym->attr.target == 1) { @@ -1875,13 +1912,13 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, /* Make sure it's not a character string. Arrays of any type should be ok if the variable is of a C interoperable type. */ - if (args_sym->ts.type == BT_CHARACTER) - if (args_sym->ts.cl != NULL - && (args_sym->ts.cl->length == NULL - || args_sym->ts.cl->length->expr_type + if (arg_ts->type == BT_CHARACTER) + if (arg_ts->cl != NULL + && (arg_ts->cl->length == NULL + || arg_ts->cl->length->expr_type != EXPR_CONSTANT || mpz_cmp_si - (args_sym->ts.cl->length->value.integer, 1) + (arg_ts->cl->length->value.integer, 1) != 0) && is_scalar_expr_ptr (args->expr) != SUCCESS) { @@ -1893,8 +1930,10 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } } } - else if (args_sym->attr.pointer == 1 - && is_scalar_expr_ptr (args->expr) != SUCCESS) + else if ((args_sym->attr.pointer == 1 || + (parent_ref != NULL + && parent_ref->u.c.component->pointer)) + && is_scalar_expr_ptr (args->expr) != SUCCESS) { /* Case 1c, section 15.1.2.5, J3/04-007: an associated scalar pointer. */ @@ -1911,7 +1950,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, with no length type parameters. It still must have either the pointer or target attribute, and it can be allocatable (but must be allocated when c_loc is called). */ - if (args_sym->attr.dimension != 0 + if (args->expr->rank != 0 && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("Parameter '%s' to '%s' at %L must be a " @@ -1919,7 +1958,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, &(args->expr->where)); retval = FAILURE; } - else if (args_sym->ts.type == BT_CHARACTER + else if (arg_ts->type == BT_CHARACTER && is_scalar_expr_ptr (args->expr) != SUCCESS) { gfc_error_now ("CHARACTER argument '%s' to '%s' at " @@ -1932,21 +1971,21 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args, } else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC) { - if (args->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE) + if (args_sym->attr.flavor != FL_PROCEDURE) { /* TODO: Update this error message to allow for procedure pointers once they are implemented. */ gfc_error_now ("Parameter '%s' to '%s' at %L must be a " "procedure", - args->expr->symtree->n.sym->name, sym->name, + args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } - else if (args->expr->symtree->n.sym->attr.is_bind_c != 1) + else if (args_sym->attr.is_bind_c != 1) { gfc_error_now ("Parameter '%s' to '%s' at %L must be " "BIND(C)", - args->expr->symtree->n.sym->name, sym->name, + args_sym->name, sym->name, &(args->expr->where)); retval = FAILURE; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 804f300..52e2cdf 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-09-20 Christopher D. Rickett + + PR fortran/33497 + * gfortran.dg/c_loc_tests_11.f03: New test case. + 2007-09-20 Paolo Carlini PR c++/33459 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 new file mode 100644 index 0000000..197666d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 @@ -0,0 +1,49 @@ +! { dg-do compile } +! Test argument checking for C_LOC with subcomponent parameters. +module c_vhandle_mod + use iso_c_binding + + type double_vector_item + real(kind(1.d0)), allocatable :: v(:) + end type double_vector_item + type(double_vector_item), allocatable, target :: dbv_pool(:) + real(kind(1.d0)), allocatable, target :: vv(:) + + type foo + integer :: i + end type foo + type foo_item + type(foo), pointer :: v => null() + end type foo_item + type(foo_item), allocatable :: foo_pool(:) + + type foo_item2 + type(foo), pointer :: v(:) => null() + end type foo_item2 + type(foo_item2), allocatable :: foo_pool2(:) + + +contains + + type(c_ptr) function get_double_vector_address(handle) + integer(c_int), intent(in) :: handle + + if (.true.) then ! The ultimate component is an allocatable target + get_double_vector_address = c_loc(dbv_pool(handle)%v) + else + get_double_vector_address = c_loc(vv) + endif + + end function get_double_vector_address + + + type(c_ptr) function get_foo_address(handle) + integer(c_int), intent(in) :: handle + get_foo_address = c_loc(foo_pool(handle)%v) + + get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "must be a scalar" } + end function get_foo_address + + +end module c_vhandle_mod + -- 2.7.4