From bfd61955ce652ec1c4bb1228fcf43e46424ebf41 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sun, 25 Nov 2007 23:02:53 +0100 Subject: [PATCH] re PR fortran/34079 (Bind(C): Character argument/return value problems) 2007-11-25 Tobias Burnus PR fortran/34079 * trans-types.c (gfc_return_by_reference, gfc_get_function_type): Do not return result of character-returning bind(C) functions as argument. * trans-expr.c (gfc_conv_function_call): Ditto. 2007-11-25 Tobias Burnus PR fortran/34079 * gfortran.dg/bind_c_usage_10_c.c: Fix comment. * gfortran.dg/bind_c_usage_16.f03: New. * gfortran.dg/bind_c_usage_16_c.c: New. From-SVN: r130414 --- gcc/fortran/ChangeLog | 8 +++ gcc/fortran/trans-expr.c | 9 ++++ gcc/fortran/trans-types.c | 18 +++---- gcc/testsuite/ChangeLog | 7 +++ gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c | 2 +- gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 | 52 +++++++++++++++++++ gcc/testsuite/gfortran.dg/bind_c_usage_16_c.c | 22 ++++++++ 7 files changed, 108 insertions(+), 10 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 create mode 100644 gcc/testsuite/gfortran.dg/bind_c_usage_16_c.c diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 94ebe8e54be..2b4799af88e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2007-11-25 Tobias Burnus + + PR fortran/34079 + * trans-types.c (gfc_return_by_reference, + gfc_get_function_type): Do not return result of + character-returning bind(C) functions as argument. + * trans-expr.c (gfc_conv_function_call): Ditto. + 2007-11-25 Jerry DeLisle PR fortran/34175 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 231fef5bf7b..813e43da2db 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2586,6 +2586,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, && !sym->attr.always_explicit) se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr); + /* Bind(C) character variables may have only length 1. */ + if (sym->ts.type == BT_CHARACTER && sym->attr.is_bind_c) + { + gcc_assert (sym->ts.cl->length + && sym->ts.cl->length->expr_type == EXPR_CONSTANT + && mpz_cmp_si (sym->ts.cl->length->value.integer, 1)); + se->string_length = build_int_cst (gfc_charlen_type_node, 1); + } + /* A pure function may still have side-effects - it may modify its parameters. */ TREE_SIDE_EFFECTS (se->expr) = 1; diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 5202539fc50..ff5643b0fc3 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1853,7 +1853,7 @@ gfc_return_by_reference (gfc_symbol * sym) if (sym->attr.dimension) return 1; - if (sym->ts.type == BT_CHARACTER) + if (sym->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) return 1; /* Possibly return complex numbers by reference for g77 compatibility. @@ -1942,17 +1942,17 @@ gfc_get_function_type (gfc_symbol * sym) typelist = gfc_chainon_list (typelist, gfc_array_index_type); } + if (sym->result) + arg = sym->result; + else + arg = sym; + + if (arg->ts.type == BT_CHARACTER) + gfc_conv_const_charlen (arg->ts.cl); + /* Some functions we use an extra parameter for the return value. */ if (gfc_return_by_reference (sym)) { - if (sym->result) - arg = sym->result; - else - arg = sym; - - if (arg->ts.type == BT_CHARACTER) - gfc_conv_const_charlen (arg->ts.cl); - type = gfc_sym_type (arg); if (arg->ts.type == BT_COMPLEX || arg->attr.dimension diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6c4f2ac860a..df55de85047 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-11-25 Tobias Burnus + + PR fortran/34079 + * gfortran.dg/bind_c_usage_10_c.c: Fix comment. + * gfortran.dg/bind_c_usage_16.f03: New. + * gfortran.dg/bind_c_usage_16_c.c: New. + 2007-11-25 Eric Botcazou * gnat.dg/specs/size_clause1.ads: New test. diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c b/gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c index 91871c770fa..ec64c41b00c 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c @@ -1,6 +1,6 @@ /* Check BIND(C) for ENTRY PR fortran/34079 - To be linked with bind_c_usage_10.c + To be linked with bind_c_usage_10.f03 */ void mySub1(int *); diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 new file mode 100644 index 00000000000..b05faa752fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_16_c.c } +! +! PR fortran/34079 +! +! Ensure character-returning, bind(C) function work. +! +module mod + use iso_c_binding + implicit none +contains + function bar(x) bind(c, name="returnA") + character(len=1,kind=c_char) :: bar, x + bar = x + bar = 'A' + end function bar + function foo() bind(c, name="returnB") + character(len=1,kind=c_char) :: foo + foo = 'B' + end function foo +end module mod + +subroutine test() bind(c) + use mod + implicit none + character(len=1,kind=c_char) :: a + character(len=5,kind=c_char) :: b + character(len=1,kind=c_char) :: c(3) + character(len=5,kind=c_char) :: d(3) + a = 'z' + b = 'fffff' + c = 'h' + d = 'uuuuu' + + a = bar('x') + if (a /= 'A') call abort() + b = bar('y') + if (b /= 'A') call abort() + c = bar('x') + if (any(c /= 'A')) call abort() + d = bar('y') + if (any(d /= 'A')) call abort() + + a = foo() + if (a /= 'B') call abort() + b = foo() + if (b /= 'B') call abort() + c = foo() + if (any(c /= 'B')) call abort() + d = foo() + if (any(d /= 'B')) call abort() +end subroutine diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_16_c.c b/gcc/testsuite/gfortran.dg/bind_c_usage_16_c.c new file mode 100644 index 00000000000..30ce25f8bd7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_16_c.c @@ -0,0 +1,22 @@ +/* Check character-returning bind(C) functions + PR fortran/34079 + To be linked with bind_c_usage_16.f03 +*/ + +#include + +char returnA(char *); +char returnB(void); +void test(void); + +int main() +{ + char c; + c = 'z'; + c = returnA(&c); + if (c != 'A') abort(); + c = returnB(); + if (c != 'B') abort(); + test(); + return 0; +}