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)
#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. */
}
-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);
}
}
}
&& 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);
}
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
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 *);
--- /dev/null
+! { 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
+
--- /dev/null
+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');
+}
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
+
projects / platform / upstream / gcc.git / commitdiff