[PATCH,fortran] fix PR 32599 and PR 32601
Christopher D. Rickett
crickett@lanl.gov
Fri Jul 6 23:10:00 GMT 2007
hi all,
the attached patch fixes PR 32601 and 32599. for 32601, the user is
allowed to print out a c_ptr or c_funptr by default. however, if
-pedantic or -std=f2003 is given, an error message is reported. for
32599, the compiler now enforces that character string dummy args have a
length of 1 (or ommitted) if the procedure is bind(c).
bootstrapped and regtested on x86 linux with no new failures, but i am
still seeing the following regression:
FAIL: gfortran.fortran-torture/compile/pr32417.f90, "-O" (internal
compiler error)
ChangeLog entry:
2007-07-06 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.
* gfortran.dg/32599.f03: New test case.
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.
* 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.
* symbol.c (gen_cptr_param): Fix whitespace.
i apologize if i got the ChangeLog entry form wrong; the patch is mostly
for the two PRs but there is also a little whitespace fixup for symbol.c.
thanks.
Chris
-------------- next part --------------
Index: gcc/testsuite/gfortran.dg/pr32601_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32601_1.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/pr32601_1.f03 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 (revision 126419)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 (working copy)
@@ -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.
Index: gcc/testsuite/gfortran.dg/pr32599.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32599.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/pr32599.f03 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/pr32601.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pr32601.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/pr32601.f03 (revision 0)
@@ -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" } }
Index: gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
===================================================================
--- gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 (revision 126419)
+++ gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 (working copy)
@@ -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
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 126419)
+++ gcc/fortran/symbol.c (working copy)
@@ -3290,7 +3290,6 @@ gen_cptr_param (gfc_formal_arglist **hea
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 **hea
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,9 +3329,9 @@ gen_cptr_param (gfc_formal_arglist **hea
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));
}
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 126419)
+++ gcc/fortran/decl.c (working copy)
@@ -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. */
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 126419)
+++ gcc/fortran/resolve.c (working copy)
@@ -1701,6 +1701,15 @@ gfc_iso_c_func_interface (gfc_symbol *sy
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)
@@ -6730,6 +6739,7 @@ resolve_fl_procedure (gfc_symbol *sym, i
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)
@@ -6751,18 +6761,25 @@ resolve_fl_procedure (gfc_symbol *sym, i
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;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 126419)
+++ gcc/fortran/trans-io.c (working copy)
@@ -1711,7 +1711,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
@@ -1779,7 +1779,7 @@ transfer_array_component (tree expr, gfc
/* 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. */
@@ -1804,7 +1804,7 @@ transfer_array_component (tree expr, gfc
/* 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;
@@ -1813,9 +1813,23 @@ transfer_expr (gfc_se * se, gfc_typespec
/* 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;
@@ -1882,7 +1896,7 @@ transfer_expr (gfc_se * se, gfc_typespec
{
if (!c->pointer)
tmp = build_fold_addr_expr (tmp);
- transfer_expr (se, &c->ts, tmp);
+ transfer_expr (se, &c->ts, tmp, code);
}
}
return;
@@ -1948,7 +1962,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
{
@@ -1987,7 +2001,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:
More information about the Gcc-patches
mailing list