procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Emit correct types for CHARACTER(C_CHAR), VALUE arguments

Browse source 
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.
This commit is contained in:
Francois-Xavier Coudert 2021-12-26 20:18:01 +01:00 • committed by Francois-Xavier Coudert
parent db25655fa5
commit 906b4e15ce
8 changed files with 255 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/trans-decl.c
View file

@ -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)

86
gcc/fortran/trans-expr.c
View file

@ -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);
}

2
gcc/fortran/trans-types.c
View file

@ -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

1
gcc/fortran/trans.h
View file

@ -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 *);

51
gcc/testsuite/gfortran.dg/c_char_tests_3.f90 Normal file
View file

@ -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

16
gcc/testsuite/gfortran.dg/c_char_tests_3_c.c Normal file
View file

@ -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');
}

90
gcc/testsuite/gfortran.dg/c_char_tests_4.f90 Normal file
View file

@ -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

49
gcc/testsuite/gfortran.dg/c_char_tests_5.f90 Normal file
View file

@ -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