aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog19
-rw-r--r--gcc/fortran/decl.c19
-rw-r--r--gcc/fortran/resolve.c37
-rw-r--r--gcc/fortran/symbol.c5
-rw-r--r--gcc/fortran/trans-io.c30
-rw-r--r--gcc/testsuite/ChangeLog11
-rw-r--r--gcc/testsuite/gfortran.dg/c_ptr_tests_10.f031
-rw-r--r--gcc/testsuite/gfortran.dg/c_ptr_tests_9.f031
-rw-r--r--gcc/testsuite/gfortran.dg/pr32599.f0340
-rw-r--r--gcc/testsuite/gfortran.dg/pr32601.f0328
-rw-r--r--gcc/testsuite/gfortran.dg/pr32601_1.f0310
11 files changed, 179 insertions, 22 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ef75186..151b7d9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 67e8ef7..00241b8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -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. */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 911d5ec..f12cbd4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -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;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 5e76fe2..e83c190 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -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));
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 4d7695e..4b70871 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -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:
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5ec8f20..fc12113 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
index d04786c..8ad3f43 100644
--- a/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
+++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_10.f03
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03 b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
index db59859..f723492 100644
--- a/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
+++ b/gcc/testsuite/gfortran.dg/c_ptr_tests_9.f03
@@ -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.
diff --git a/gcc/testsuite/gfortran.dg/pr32599.f03 b/gcc/testsuite/gfortran.dg/pr32599.f03
new file mode 100644
index 0000000..fa8aa68
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32599.f03
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/pr32601.f03 b/gcc/testsuite/gfortran.dg/pr32601.f03
new file mode 100644
index 0000000..90fa6b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32601.f03
@@ -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" } }
diff --git a/gcc/testsuite/gfortran.dg/pr32601_1.f03 b/gcc/testsuite/gfortran.dg/pr32601_1.f03
new file mode 100644
index 0000000..3e9aa73
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr32601_1.f03
@@ -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
generated by cgit v1.1 at 2025-05-01 20:39:04 +0000