From 906b4e15ce84790c7657405238d61358e0893676 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Sun, 26 Dec 2021 20:18:01 +0100 Subject: [PATCH] Fortran: Emit correct types for CHARACTER(C_CHAR), VALUE arguments Make the front-end emit the right type for CHARACTER(C_CHAR), VALUE arguments to BIND(C) procedures. They are scalar integers of C type char, and should be emitted as such. They are not strings or arrays, and are not promoted to C int, either. gcc/fortran/ChangeLog: PR fortran/103828 * trans-decl.c (generate_local_decl): Do not call gfc_conv_scalar_char_value(), but check the type tree. * trans-expr.c (gfc_conv_scalar_char_value): Rename to conv_scalar_char_value, do not alter type tree. (gfc_conv_procedure_call): Adjust call to renamed conv_scalar_char_value() function. * trans-types.c (gfc_sym_type): Take care of CHARACTER(C_CHAR), VALUE arguments. * trans.h (gfc_conv_scalar_char_value): Remove prototype. gcc/testsuite/ChangeLog: PR fortran/103828 * gfortran.dg/c_char_tests_3.f90: New file. * gfortran.dg/c_char_tests_3_c.c: New file. * gfortran.dg/c_char_tests_4.f90: New file. * gfortran.dg/c_char_tests_5.f90: New file. --- gcc/fortran/trans-decl.c | 17 ++++-- gcc/fortran/trans-expr.c | 86 ++++++++++++-------------- gcc/fortran/trans-types.c | 2 +- gcc/fortran/trans.h | 1 - gcc/testsuite/gfortran.dg/c_char_tests_3.f90 | 51 ++++++++++++++++ gcc/testsuite/gfortran.dg/c_char_tests_3_c.c | 16 +++++ gcc/testsuite/gfortran.dg/c_char_tests_4.f90 | 90 ++++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/c_char_tests_5.f90 | 49 +++++++++++++++ 8 files changed, 255 insertions(+), 57 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_3_c.c create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c_char_tests_5.f90 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index cb7f684..d288af5 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -6001,15 +6001,20 @@ generate_local_decl (gfc_symbol * sym) if (sym->attr.dummy == 1) { - /* Modify the tree type for scalar character dummy arguments of bind(c) - procedures if they are passed by value. The tree type for them will - be promoted to INTEGER_TYPE for the middle end, which appears to be - what C would do with characters passed by-value. The value attribute - implies the dummy is a scalar. */ + /* The tree type for scalar character dummy arguments of BIND(C) + procedures, if they are passed by value, should be unsigned char. + The value attribute implies the dummy is a scalar. */ if (sym->attr.value == 1 && sym->backend_decl != NULL && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c) - gfc_conv_scalar_char_value (sym, NULL, NULL); + { + /* We used to modify the tree here. Now it is done earlier in + the front-end, so we only check it here to avoid regressions. */ + gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE); + gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1); + gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE); + gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0); + } /* Unused procedure passed as dummy argument. */ if (sym->attr.flavor == FL_PROCEDURE) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e413b2d..80c669f 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -41,6 +41,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-stmt.h" #include "dependency.h" #include "gimplify.h" +#include "tm.h" /* For CHAR_TYPE_SIZE. */ /* Calculate the number of characters in a string. */ @@ -3972,63 +3973,50 @@ gfc_string_to_single_character (tree len, tree str, int kind) } -void -gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) +static void +conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr) { + gcc_assert (expr); + /* We used to modify the tree here. Now it is done earlier in + the front-end, so we only check it here to avoid regressions. */ if (sym->backend_decl) { - /* This becomes the nominal_type in - function.c:assign_parm_find_data_types. */ - TREE_TYPE (sym->backend_decl) = unsigned_char_type_node; - /* This becomes the passed_type in - function.c:assign_parm_find_data_types. C promotes char to - integer for argument passing. */ - DECL_ARG_TYPE (sym->backend_decl) = unsigned_type_node; - - DECL_BY_REFERENCE (sym->backend_decl) = 0; + gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE); + gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1); + gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE); + gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0); } - if (expr != NULL) + /* If we have a constant character expression, make it into an + integer of type C char. */ + if ((*expr)->expr_type == EXPR_CONSTANT) { - /* If we have a constant character expression, make it into an - integer. */ - if ((*expr)->expr_type == EXPR_CONSTANT) - { - gfc_typespec ts; - gfc_clear_ts (&ts); + gfc_typespec ts; + gfc_clear_ts (&ts); - *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, - (int)(*expr)->value.character.string[0]); - if ((*expr)->ts.kind != gfc_c_int_kind) - { - /* The expr needs to be compatible with a C int. If the - conversion fails, then the 2 causes an ICE. */ - ts.type = BT_INTEGER; - ts.kind = gfc_c_int_kind; - gfc_convert_type (*expr, &ts, 2); - } + *expr = gfc_get_int_expr (gfc_default_character_kind, NULL, + (*expr)->value.character.string[0]); + } + else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE) + { + if ((*expr)->ref == NULL) + { + se->expr = gfc_string_to_single_character + (build_int_cst (integer_type_node, 1), + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + gfc_get_symbol_decl + ((*expr)->symtree->n.sym)), + (*expr)->ts.kind); } - else if (se != NULL && (*expr)->expr_type == EXPR_VARIABLE) - { - if ((*expr)->ref == NULL) - { - se->expr = gfc_string_to_single_character - (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), - gfc_get_symbol_decl - ((*expr)->symtree->n.sym)), - (*expr)->ts.kind); - } - else - { - gfc_conv_variable (se, *expr); - se->expr = gfc_string_to_single_character - (build_int_cst (integer_type_node, 1), - gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), - se->expr), - (*expr)->ts.kind); - } + else + { + gfc_conv_variable (se, *expr); + se->expr = gfc_string_to_single_character + (build_int_cst (integer_type_node, 1), + gfc_build_addr_expr (gfc_get_pchar_type ((*expr)->ts.kind), + se->expr), + (*expr)->ts.kind); } } } @@ -6341,7 +6329,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && fsym->ns->proc_name->attr.is_bind_c) { parmse.expr = NULL; - gfc_conv_scalar_char_value (fsym, &parmse, &e); + conv_scalar_char_value (fsym, &parmse, &e); if (parmse.expr == NULL) gfc_conv_expr (&parmse, e); } diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index eec4aa6..6262d52 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2262,7 +2262,7 @@ gfc_sym_type (gfc_symbol * sym, bool is_bind_c) if (sym->ts.type == BT_CHARACTER && ((sym->attr.function && sym->attr.is_bind_c) - || (sym->attr.result + || ((sym->attr.result || sym->attr.value) && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) || (sym->ts.deferred && (!sym->ts.u.cl diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 15012a3..f78d502 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -508,7 +508,6 @@ void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree); tree gfc_get_character_len_in_bytes (tree); tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute); tree gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *, gfc_expr *); -void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr); tree gfc_string_to_single_character (tree len, tree str, int kind); tree gfc_get_tree_for_caf_expr (gfc_expr *); void gfc_get_caf_token_offset (gfc_se*, tree *, tree *, tree, tree, gfc_expr *); diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_3.f90 new file mode 100644 index 0000000..9fc0714 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_char_tests_3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-sources c_char_tests_3_c.c } +! +! PR fortran/103828 +! Check that we can pass many function args as C char, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding + implicit none + integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= iachar('a')) stop 1 + if (b /= iachar('b')) stop 2 + if (c /= iachar('c')) stop 3 + if (d /= iachar('d')) stop 4 + if (e /= iachar('e')) stop 5 + if (f /= iachar('f')) stop 6 + if (g /= iachar('g')) stop 7 + if (h /= iachar('h')) stop 8 + if (i /= iachar('i')) stop 9 + if (j /= iachar('j')) stop 10 + if (k /= iachar('k')) stop 11 + if (l /= iachar('l')) stop 12 + if (m /= iachar('m')) stop 13 + if (n /= iachar('n')) stop 14 + if (o /= iachar('o')) stop 15 +end subroutine + +subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding + implicit none + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= 'a') stop 101 + if (b /= 'b') stop 102 + if (c /= 'c') stop 103 + if (d /= 'd') stop 104 + if (e /= 'e') stop 105 + if (f /= 'f') stop 106 + if (g /= 'g') stop 107 + if (h /= 'h') stop 108 + if (i /= 'i') stop 109 + if (j /= 'j') stop 110 + if (k /= 'k') stop 111 + if (l /= 'l') stop 112 + if (m /= 'm') stop 113 + if (n /= 'n') stop 114 + if (o /= 'o') stop 115 +end subroutine + diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c b/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c new file mode 100644 index 0000000..1c86a54 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_char_tests_3_c.c @@ -0,0 +1,16 @@ +void test_char (char, char, char, char, char, + char, char, char, char, char, + char, char, char, char, char); + +void test_int (char, char, char, char, char, + char, char, char, char, char, + char, char, char, char, char); + +int main (void) { + test_char ('a', 'b', 'c', 'd', 'e', + 'f', 'g', 'h', 'i', 'j', + 'k', 'l', 'm', 'n', 'o'); + test_int ('a', 'b', 'c', 'd', 'e', + 'f', 'g', 'h', 'i', 'j', + 'k', 'l', 'm', 'n', 'o'); +} diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 new file mode 100644 index 0000000..512948a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_char_tests_4.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! PR fortran/103828 +! Check that we can pass many function args as C char, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +program test + use, intrinsic :: iso_c_binding, only : c_signed_char, c_char + implicit none + + interface + ! In order to perform this test, we cheat and pretend to give each function + ! the other one's prototype. It should still work, because all arguments + ! are interoperable with C char. + + subroutine test1 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_int') + import c_char + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + end subroutine test1 + + subroutine test2 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_char') + import c_signed_char + integer(kind=c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + end subroutine test2 + + end interface + + call test1('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o') + call test2(ichar('a', kind=c_signed_char), & + ichar('b', kind=c_signed_char), & + ichar('c', kind=c_signed_char), & + ichar('d', kind=c_signed_char), & + ichar('e', kind=c_signed_char), & + ichar('f', kind=c_signed_char), & + ichar('g', kind=c_signed_char), & + ichar('h', kind=c_signed_char), & + ichar('i', kind=c_signed_char), & + ichar('j', kind=c_signed_char), & + ichar('k', kind=c_signed_char), & + ichar('l', kind=c_signed_char), & + ichar('m', kind=c_signed_char), & + ichar('n', kind=c_signed_char), & + ichar('o', kind=c_signed_char)) + +end program test + +subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding, only : c_signed_char + implicit none + integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= iachar('a')) stop 1 + if (b /= iachar('b')) stop 2 + if (c /= iachar('c')) stop 3 + if (d /= iachar('d')) stop 4 + if (e /= iachar('e')) stop 5 + if (f /= iachar('f')) stop 6 + if (g /= iachar('g')) stop 7 + if (h /= iachar('h')) stop 8 + if (i /= iachar('i')) stop 9 + if (j /= iachar('j')) stop 10 + if (k /= iachar('k')) stop 11 + if (l /= iachar('l')) stop 12 + if (m /= iachar('m')) stop 13 + if (n /= iachar('n')) stop 14 + if (o /= iachar('o')) stop 15 +end subroutine + +subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding, only : c_char + implicit none + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= 'a') stop 101 + if (b /= 'b') stop 102 + if (c /= 'c') stop 103 + if (d /= 'd') stop 104 + if (e /= 'e') stop 105 + if (f /= 'f') stop 106 + if (g /= 'g') stop 107 + if (h /= 'h') stop 108 + if (i /= 'i') stop 109 + if (j /= 'j') stop 110 + if (k /= 'k') stop 111 + if (l /= 'l') stop 112 + if (m /= 'm') stop 113 + if (n /= 'n') stop 114 + if (o /= 'o') stop 115 +end subroutine + diff --git a/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 new file mode 100644 index 0000000..c7a1c6e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_char_tests_5.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! +! PR fortran/103828 +! Check that we can C char with non-ASCII values, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +program test + use, intrinsic :: iso_c_binding, only : c_signed_char, c_char + implicit none + + interface + ! In order to perform this test, we cheat and pretend to give each function + ! the other one's prototype. It should still work, because all arguments + ! are interoperable with C char. + + subroutine test1 (a) bind(c, name='test_int') + import c_char + character(kind=c_char, len=1), value :: a + end subroutine test1 + + subroutine test2 (a) bind(c, name='test_char') + import c_signed_char + integer(kind=c_signed_char), value :: a + end subroutine test2 + + end interface + + call test1('\xA3') + call test2(-93_c_signed_char) + +end program test + +subroutine test_int (a) bind(c) + use, intrinsic :: iso_c_binding, only : c_signed_char + implicit none + integer(c_signed_char), value :: a + + if (a /= iachar('\xA3', kind=c_signed_char)) stop 1 +end subroutine + +subroutine test_char (a) bind(c) + use, intrinsic :: iso_c_binding, only : c_char + implicit none + character(kind=c_char, len=1), value :: a + + if (a /= '\xA3') stop 101 +end subroutine + -- 2.7.4