public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-6137] Fortran: Emit correct types for CHARACTER(C_CHAR), VALUE arguments
@ 2021-12-28 22:28 Franथईois-Xavier Coudert
0 siblings, 0 replies; only message in thread
From: Franथईois-Xavier Coudert @ 2021-12-28 22:28 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:906b4e15ce84790c7657405238d61358e0893676
commit r12-6137-g906b4e15ce84790c7657405238d61358e0893676
Author: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Date: Sun Dec 26 20:18:01 2021 +0100
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.
Diff:
---
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(-)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cb7f684d52c..d288af5aa10 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 e413b2d7a1f..80c669f50fb 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 eec4aa6f5fc..6262d52657f 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 15012a336ff..f78d5025047 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 00000000000..9fc07144ed0
--- /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 00000000000..1c86a549165
--- /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 00000000000..512948a2a3f
--- /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 00000000000..c7a1c6e8c2b
--- /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
+
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-12-28 22:28 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-12-28 22:28 [gcc r12-6137] Fortran: Emit correct types for CHARACTER(C_CHAR), VALUE arguments Franथईois-Xavier Coudert
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).