PR fortran/32599
* decl.c (verify_c_interop_param): Require character string dummy
args to BIND(C) procedures to have length 1.
* resolve.c (resolve_fl_procedure): Modify parameter checking for
BIND(C) procedures.
PR fortran/32601
* resolve.c (gfc_iso_c_func_interface): Verify that a valid
expression is given as an argument to C_LOC and C_ASSOCIATED.
* trans-io.c (transfer_expr): Add argument for code block. Add
standards check to determine if an error message should be
reported for printing C_PTR or C_FUNPTR.
(transfer_array_component): Update arguments to transfer_expr.
(gfc_trans_transfer): Ditto.
* symbol.c (gen_cptr_param): Fix whitespace.
2007-07-12 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/32599
* gfortran.dg/32599.f03: New test case.
PR fortran/32601
* gfortran.dg/32601.f03: New test case.
* gfortran.dg/32601_1.f03: Ditto.
* gfortran.dg/c_ptr_tests_9.f03: Updated dg-options.
* gfortran.dg/c_ptr_tests_10.f03: Ditto.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@126598
138bc75d-0d04-0410-961f-
82ee72b054a4
+2007-07-12 Christopher D. Rickett <crickett@lanl.gov>
+
+ PR fortran/32599
+ * decl.c (verify_c_interop_param): Require character string dummy
+ args to BIND(C) procedures to have length 1.
+ * resolve.c (resolve_fl_procedure): Modify parameter checking for
+ BIND(C) procedures.
+
+ PR fortran/32601
+ * resolve.c (gfc_iso_c_func_interface): Verify that a valid
+ expression is given as an argument to C_LOC and C_ASSOCIATED.
+ * trans-io.c (transfer_expr): Add argument for code block. Add
+ standards check to determine if an error message should be
+ reported for printing C_PTR or C_FUNPTR.
+ (transfer_array_component): Update arguments to transfer_expr.
+ (gfc_trans_transfer): Ditto.
+
+ * symbol.c (gen_cptr_param): Fix whitespace.
+
2007-07-12 Jakub Jelinek <jakub@redhat.com>
PR fortran/32550
sym->name, &(sym->declared_at),
sym->ns->proc_name->name);
}
-
+
+ /* Character strings are only C interoperable if they have a
+ length of 1. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
+ || mpz_cmp_si (cl->length->value.integer, 1) != 0)
+ {
+ gfc_error ("Character argument '%s' at %L "
+ "must be length 1 because "
+ "procedure '%s' is BIND(C)",
+ sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+ retval = FAILURE;
+ }
+ }
+
/* We have to make sure that any param to a bind(c) routine does
not have the allocatable, pointer, or optional attributes,
according to J3/04-007, section 5.1. */
try retval = SUCCESS;
gfc_symbol *args_sym;
+ if (args->expr->expr_type == EXPR_CONSTANT
+ || args->expr->expr_type == EXPR_OP
+ || args->expr->expr_type == EXPR_NULL)
+ {
+ gfc_error ("Argument to '%s' at %L is not a variable",
+ sym->name, &(args->expr->where));
+ return FAILURE;
+ }
+
args_sym = args->expr->symtree->n.sym;
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
{
gfc_formal_arglist *curr_arg;
+ int has_non_interop_arg = 0;
if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
sym->common_block) == FAILURE)
while (curr_arg != NULL)
{
/* Skip implicitly typed dummy args here. */
- if (curr_arg->sym->attr.implicit_type == 0
- && verify_c_interop_param (curr_arg->sym) == FAILURE)
- {
- /* If something is found to fail, mark the symbol for the
- procedure as not being BIND(C) to try and prevent multiple
- errors being reported. */
- sym->attr.is_c_interop = 0;
- sym->ts.is_c_interop = 0;
- sym->attr.is_bind_c = 0;
- }
+ if (curr_arg->sym->attr.implicit_type == 0)
+ if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+ /* If something is found to fail, record the fact so we
+ can mark the symbol for the procedure as not being
+ BIND(C) to try and prevent multiple errors being
+ reported. */
+ has_non_interop_arg = 1;
+
curr_arg = curr_arg->next;
}
+
+ /* See if any of the arguments were not interoperable and if so, clear
+ the procedure symbol to prevent duplicate error messages. */
+ if (has_non_interop_arg != 0)
+ {
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ sym->attr.is_bind_c = 0;
+ }
}
return SUCCESS;
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
-
else
c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
else
- c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
if (c_ptr_sym == NULL)
{
/* This can happen if the user did not define c_ptr but they are
generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
(char *)c_ptr_type);
else
- generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
+ generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
(char *)c_ptr_type);
gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
}
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
tmp = build_fold_addr_expr (se.expr);
- transfer_expr (&se, &cm->ts, tmp);
+ transfer_expr (&se, &cm->ts, tmp, NULL);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
/* Generate the call for a scalar transfer node. */
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{
tree tmp, function, arg2, field, expr;
gfc_component *c;
/* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
the user says something like: print *, 'c_null_ptr: ', c_null_ptr
We need to translate the expression to a constant if it's either
- C_NULL_PTR or C_NULL_FUNPTR. */
- if (ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+ C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
+ type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
+ BT_DERIVED (could have been changed by gfc_conv_expr). */
+ if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+ || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
{
+ /* C_PTR and C_FUNPTR have private components which means they can not
+ be printed. However, if -std=gnu and not -pedantic, allow
+ the component to be printed to help debugging. */
+ if (gfc_notification_std (GFC_STD_GNU) != SILENT)
+ {
+ gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
+ ts->derived->name, code != NULL ? &(code->loc) :
+ &gfc_current_locus);
+ return;
+ }
+
ts->type = ts->derived->ts.type;
ts->kind = ts->derived->ts.kind;
ts->f90_type = ts->derived->ts.f90_type;
{
if (!c->pointer)
tmp = build_fold_addr_expr (tmp);
- transfer_expr (se, &c->ts, tmp);
+ transfer_expr (se, &c->ts, tmp, code);
}
}
return;
{
/* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr);
+ transfer_expr (&se, &expr->ts, se.expr, code);
}
else
{
se.ss = ss;
gfc_conv_expr_reference (&se, expr);
- transfer_expr (&se, &expr->ts, se.expr);
+ transfer_expr (&se, &expr->ts, se.expr, code);
}
finish_block_label:
+2007-07-12 Christopher D. Rickett <crickett@lanl.gov>
+
+ PR fortran/32599
+ * gfortran.dg/32599.f03: New test case.
+
+ PR fortran/32601
+ * gfortran.dg/32601.f03: New test case.
+ * gfortran.dg/32601_1.f03: Ditto.
+ * gfortran.dg/c_ptr_tests_9.f03: Updated dg-options.
+ * gfortran.dg/c_ptr_tests_10.f03: Ditto.
+
2007-07-12 Steve Ellcey <sje@cup.hp.com>
* gcc.c-torture/execute/align-3.c: Remove function addr check.
! { dg-run }
+! { dg-options "-std=gnu" }
! This test case exists because gfortran had an error in converting the
! expressions for the derived types from iso_c_binding in some cases.
module c_ptr_tests_10
! { dg-do run }
+! { dg-options "-std=gnu" }
! This test is pretty simple but is here just to make sure that the changes
! done to c_ptr and c_funptr (translating them to void *) works in the case
! where a component of a type is of type c_ptr or c_funptr.
--- /dev/null
+! { dg-do compile }
+! PR fortran/32599
+! Verifies that character string arguments to a bind(c) procedure have length
+! 1, or no len is specified.
+module pr32599
+ interface
+ subroutine destroy(path) BIND(C) ! { dg-error "must be length 1" }
+ use iso_c_binding
+ implicit none
+ character(len=*,kind=c_char), intent(IN) :: path
+ end subroutine destroy
+
+ subroutine create(path) BIND(C) ! { dg-error "must be length 1" }
+ use iso_c_binding
+ implicit none
+ character(len=5,kind=c_char), intent(IN) :: path
+ end subroutine create
+
+ ! This should be valid.
+ subroutine create1(path) BIND(C)
+ use iso_c_binding
+ implicit none
+ character(len=1,kind=c_char), intent(IN) :: path
+ end subroutine create1
+
+ ! This should be valid.
+ subroutine create2(path) BIND(C)
+ use iso_c_binding
+ implicit none
+ character(kind=c_char), intent(IN) :: path
+ end subroutine create2
+
+ ! This should be valid.
+ subroutine create3(path) BIND(C)
+ use iso_c_binding
+ implicit none
+ character(kind=c_char), dimension(*), intent(IN) :: path
+ end subroutine create3
+ end interface
+end module pr32599
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+! PR fortran/32601
+module pr32601
+use, intrinsic :: iso_c_binding, only: c_int
+contains
+ function get_ptr()
+ integer(c_int), pointer :: get_ptr
+ integer(c_int), target :: x
+ get_ptr = x
+ end function get_ptr
+end module pr32601
+
+USE ISO_C_BINDING, only: c_null_ptr, c_ptr, c_loc
+use pr32601
+implicit none
+
+type(c_ptr) :: t
+t = c_null_ptr
+
+! Next two lines should be errors if -pedantic or -std=f2003
+print *, c_null_ptr, t ! { dg-error "has PRIVATE components" }
+print *, t ! { dg-error "has PRIVATE components" }
+
+print *, c_loc(get_ptr()) ! { dg-error "has PRIVATE components" }
+
+end
+! { dg-final { cleanup-modules "pr32601" } }
--- /dev/null
+! { dg-do compile }
+! PR fortran/32601
+use, intrinsic :: iso_c_binding, only: c_loc, c_ptr
+implicit none
+
+! This was causing an ICE, but is an error because the argument to C_LOC
+! needs to be a variable.
+print *, c_loc(4) ! { dg-error "not a variable" }
+
+end
projects / platform / upstream / linaro-gcc.git / commitdiff