OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/32599 ([ISO C Binding] Accepts character with len /= 1) 

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  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.

From-SVN: r126598
This commit is contained in:
Christopher D. Rickett 2007-07-12 19:52:03 +00:00 committed by Tobias Burnus
parent 26a9718401
commit aa5e22f000
11 changed files with 179 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/fortran/ChangeLog
View File

@ -1,3 +1,22 @@
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

19
gcc/fortran/decl.c
View File

@ -838,7 +838,24 @@ verify_c_interop_param (gfc_symbol *sym)
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. */

37
gcc/fortran/resolve.c
View File

@ -1717,6 +1717,15 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
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)
@ -6798,6 +6807,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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)
@ -6819,18 +6829,25 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
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;

5
gcc/fortran/symbol.c
View File

@ -3290,7 +3290,6 @@ gen_cptr_param (gfc_formal_arglist **head,
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";
@ -3321,7 +3320,7 @@ gen_cptr_param (gfc_formal_arglist **head,
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
@ -3330,7 +3329,7 @@ gen_cptr_param (gfc_formal_arglist **head,
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));

30
gcc/fortran/trans-io.c
View File

@ -1712,7 +1712,7 @@ gfc_trans_dt_end (gfc_code * code)
}
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
@ -1780,7 +1780,7 @@ transfer_array_component (tree expr, gfc_component * cm)
/* 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. */
@ -1805,7 +1805,7 @@ transfer_array_component (tree expr, gfc_component * cm)
/* 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;
@ -1814,9 +1814,23 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
/* 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;
@ -1883,7 +1897,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
{
if (!c->pointer)
tmp = build_fold_addr_expr (tmp);
transfer_expr (se, &c->ts, tmp);
transfer_expr (se, &c->ts, tmp, code);
}
}
return;
@ -1949,7 +1963,7 @@ gfc_trans_transfer (gfc_code * code)
{
/* 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
{
@ -1988,7 +2002,7 @@ gfc_trans_transfer (gfc_code * code)
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:

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
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.

1
gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
View File

@ -1,4 +1,5 @@
! { 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

1
gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
View File

@ -1,4 +1,5 @@
! { 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.

40
gcc/testsuite/gfortran.dg/pr32599.f03 Normal file
View File

@ -0,0 +1,40 @@
! { 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

28
gcc/testsuite/gfortran.dg/pr32601.f03 Normal file
View File

@ -0,0 +1,28 @@
! { 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" } }

10
gcc/testsuite/gfortran.dg/pr32601_1.f03 Normal file
View File

@ -0,0 +1,10 @@
! { 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