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

Fortran: Implement f_c_string function.

Browse source 
Fortran 2023 has added the new intrinsic function F_C_STRING to
convert fortran strings of default character kind to a null
terminated C string.

Contributions from Steve Kargl, Harald Anlauf, FX Coudert, Mikael Morin,
and Jerry DeLisle.

	PR fortran/117643

gcc/fortran/ChangeLog:

	* check.cc (gfc_check_f_c_string): Check arguments of f_c_string().
	* gfortran.h (enum gfc_isym_id): New symbol GFC_ISYM_F_C_STRING.
	* intrinsic.cc (add_functions): Add the ISO C Binding routine f_c_string().
	Wrap nearby long line to less than 80 characters.
	* intrinsic.h (gfc_check_f_c_string): Prototype for gfc_check_f_c_string().
	* iso-c-binding.def (NAMED_FUNCTION): Declare for ISO C Binding
	routine f_c_string().
	* primary.cc (gfc_match_rvalue): Fix comment that has been untrue since 2011.
	Add ISOCBINDING_F_C_STRING to conditional.
	* trans-intrinsic.cc (conv_trim): Specialized version of trim() for
	f_c_string().
	(gfc_conv_intrinsic_function): Use GFC_ISYM_F_C_STRING to trigger in-lining.

gcc/testsuite/ChangeLog:

	* gfortran.dg/f_c_string1.f90: New test.
	* gfortran.dg/f_c_string2.f90: New test.
This commit is contained in:
Steven G. Kargl 2024-12-29 14:19:18 -08:00 • committed by Jerry DeLisle
parent 64d31343d4
commit efc0981077
9 changed files with 329 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
gcc/fortran/check.cc
View file

@ -1829,6 +1829,42 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
}
/* Check the arguments for f_c_string. */
bool
gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis)
{
if (gfc_invalid_null_arg (string))
return false;
if (!scalar_check (string, 0))
return false;
if (string->ts.type != BT_CHARACTER
|| (string->ts.type == BT_CHARACTER
&& (string->ts.kind != gfc_default_character_kind)))
{
gfc_error ("%qs argument of %qs intrinsic at %L shall have "
"a type of CHARACTER(KIND=C_CHAR)",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&string->where);
return false;
}
if (asis)
{
if (!type_check (asis, 1, BT_LOGICAL))
return false;
if (!scalar_check (asis, 1))
return false;
}
return true;
}
bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{

1
gcc/fortran/gfortran.h
View file

@ -508,6 +508,7 @@ enum gfc_isym_id
GFC_ISYM_EXP,
GFC_ISYM_EXPONENT,
GFC_ISYM_EXTENDS_TYPE_OF,
GFC_ISYM_F_C_STRING,
GFC_ISYM_FAILED_IMAGES,
GFC_ISYM_FDATE,
GFC_ISYM_FE_RUNTIME_ERROR,

11
gcc/fortran/intrinsic.cc
View file

@ -3145,6 +3145,14 @@ add_functions (void)
x, BT_UNKNOWN, 0, REQUIRED);
make_from_module();
add_sym_2 ("f_c_string", GFC_ISYM_F_C_STRING, CLASS_TRANSFORMATIONAL,
ACTUAL_NO,
BT_CHARACTER, dc, GFC_STD_F2023,
gfc_check_f_c_string, NULL, NULL,
stg, BT_CHARACTER, dc, REQUIRED,
"asis", BT_CHARACTER, dc, OPTIONAL);
make_from_module();
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
@ -3301,7 +3309,8 @@ add_functions (void)
make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
BT_CHARACTER, dc, GFC_STD_F95,
gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
stg, BT_CHARACTER, dc, REQUIRED);

1
gcc/fortran/intrinsic.h
View file

@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime (gfc_expr *);
bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_f_c_string (gfc_expr *, gfc_expr *);
bool gfc_check_failed_or_stopped_images (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);

3
gcc/fortran/iso-c-binding.def
View file

@ -256,6 +256,9 @@ NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc",
NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
NAMED_FUNCTION (ISOCBINDING_F_C_STRING, "f_c_string", \
GFC_ISYM_F_C_STRING, GFC_STD_F2023)
#undef NAMED_INTCST
#undef NAMED_UINTCST
#undef NAMED_REALCST

5
gcc/fortran/primary.cc
View file

@ -4039,12 +4039,11 @@ gfc_match_rvalue (gfc_expr **result)
}
/* Check here for the existence of at least one argument for the
iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. The
argument(s) given will be checked in gfc_iso_c_func_interface,
during resolution of the function call. */
iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED. */
if (sym->attr.is_iso_c == 1
&& (sym->from_intmod == INTMOD_ISO_C_BINDING
&& (sym->intmod_sym_id == ISOCBINDING_LOC
|| sym->intmod_sym_id == ISOCBINDING_F_C_STRING
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC
|| sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
{

182
gcc/fortran/trans-intrinsic.cc
View file

@ -10024,11 +10024,39 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
}
/* The following routine generates code for the intrinsic
functions from the ISO_C_BINDING module:
* C_LOC
* C_FUNLOC
* C_ASSOCIATED */
/* Specialized trim for f_c_string. */
static void
conv_trim (gfc_se *tse, gfc_se *str)
{
tree cond, plen, pvar, tlen, ttmp, tvar;
tlen = gfc_create_var (gfc_charlen_type_node, "tlen");
plen = gfc_build_addr_expr (NULL_TREE, tlen);
tvar = gfc_create_var (pchar_type_node, "tstr");
pvar = gfc_build_addr_expr (ppvoid_type_node, tvar);
ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4,
plen, pvar, str->string_length, str->expr);
gfc_add_expr_to_block (&tse->pre, ttmp);
/* Free the temporary afterwards, if necessary. */
cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
tlen, build_int_cst (TREE_TYPE (tlen), 0));
ttmp = gfc_call_free (tvar);
ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&tse->post, ttmp);
tse->expr = tvar;
tse->string_length = tlen;
}
/* The following routine generates code for the intrinsic functions from
the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
F_C_STRING. */
static void
conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
@ -10103,6 +10131,149 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
not_null_expr, eq_expr);
}
}
else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
{
/* There are three cases:
f_c_string(string) -> trim(string) // c_null_char
f_c_string(string, .false.) -> trim(string) // c_null_char
f_c_string(string, .true.) -> string // c_null_char */
gfc_se lse, rse, tse;
tree len, tmp, var;
gfc_expr *string = arg->expr;
gfc_expr *asis = arg->next->expr;
gfc_expr *cnc;
/* Convert string. */
gfc_init_se (&lse, se);
gfc_conv_expr (&lse, string);
gfc_conv_string_parameter (&lse);
/* Create a string for C_NULL_CHAR and convert it. */
cnc = gfc_get_character_expr (gfc_default_character_kind,
&string->where, "\0", 1);
gfc_init_se (&rse, se);
gfc_conv_expr (&rse, cnc);
gfc_conv_string_parameter (&rse);
gfc_free_expr (cnc);
#ifdef cnode
#undef cnode
#endif
#define cnode gfc_charlen_type_node
if (asis)
{
stmtblock_t block;
gfc_se asis_se, vse;
tree elen, evar, tlen, tvar;
tree else_branch, then_branch;
elen = evar = tlen = tvar = NULL_TREE;
/* f_c_string(string, .true.) -> string // c_null_char */
gfc_init_block (&block);
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
fold_convert (cnode, lse.string_length),
fold_convert (cnode, rse.string_length));
gfc_init_se (&vse, se);
tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
gfc_add_block_to_block (&block, &vse.pre);
tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
6, tlen, tvar,
lse.string_length, lse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&block, tmp);
then_branch = gfc_finish_block (&block);
/* f_c_string(string, .false.) = trim(string) // c_null_char */
gfc_init_block (&block);
gfc_init_se (&tse, se);
conv_trim (&tse, &lse);
gfc_add_block_to_block (&block, &tse.pre);
gfc_add_block_to_block (&block, &rse.pre);
elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
fold_convert (cnode, tse.string_length),
fold_convert (cnode, rse.string_length));
gfc_init_se (&vse, se);
evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
gfc_add_block_to_block (&block, &vse.pre);
tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
6, elen, evar,
tse.string_length, tse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&block, tmp);
else_branch = gfc_finish_block (&block);
gfc_init_se (&asis_se, se);
gfc_conv_expr (&asis_se, asis);
if (asis->expr_type == EXPR_VARIABLE
&& asis->symtree->n.sym->attr.dummy
&& asis->symtree->n.sym->attr.optional)
{
tree present = gfc_conv_expr_present (asis->symtree->n.sym);
asis_se.expr = build3_loc (input_location, COND_EXPR,
logical_type_node, present,
asis_se.expr,
build_int_cst (logical_type_node, 0));
}
gfc_add_block_to_block (&se->pre, &asis_se.pre);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
asis_se.expr, then_branch, else_branch);
gfc_add_expr_to_block (&se->pre, tmp);
var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
asis_se.expr, tvar, evar);
gfc_add_expr_to_block (&se->pre, var);
len = fold_build3_loc (input_location, COND_EXPR, cnode,
asis_se.expr, tlen, elen);
gfc_add_expr_to_block (&se->pre, len);
}
else
{
/* f_c_string(string) = trim(string) // c_null_char */
gfc_add_block_to_block (&se->pre, &lse.pre);
gfc_add_block_to_block (&se->pre, &rse.pre);
gfc_init_se (&tse, se);
conv_trim (&tse, &lse);
gfc_add_block_to_block (&se->pre, &tse.pre);
gfc_add_block_to_block (&se->post, &tse.post);
len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
fold_convert (cnode, tse.string_length),
fold_convert (cnode, rse.string_length));
var = gfc_conv_string_tmp (se, pchar_type_node, len);
tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
6, len, var,
tse.string_length, tse.expr,
rse.string_length, rse.expr);
gfc_add_expr_to_block (&se->pre, tmp);
}
se->expr = var;
se->string_length = len;
#undef cnode
}
else
gcc_unreachable ();
}
@ -11243,6 +11414,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
case GFC_ISYM_C_ASSOCIATED:
case GFC_ISYM_C_FUNLOC:
case GFC_ISYM_C_LOC:
case GFC_ISYM_F_C_STRING:
conv_isocbinding_function (se, expr);
break;

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

@ -0,0 +1,49 @@
!
! { dg-do run }
!
! PR117643 F_C_STRING from F23 is missing.
! Test case and initial patch provided by Steve Kargl.
program foo
use iso_c_binding, only : c_null_char, c_char, f_c_string, c_size_t
implicit none
logical asis
character(len=6, kind=c_char) :: s1
character(len=:, kind=c_char), allocatable :: s2
interface
!
! strlen() counts up to '\0', and excludes it from the count
!
function strlen(s) bind(c,name="strlen")
import c_char, c_size_t
integer(c_size_t) strlen
character(len=1,kind=c_char), intent(in) :: s(*)
end function strlen
end interface
s1 = 'abc '
s2 = f_c_string(s1)
if (len_trim(s1) /= int(strlen(s2), 4)) stop 1
s1 = ' ghij '
s2 = f_c_string(s1)
if (len_trim(s1) /= int(strlen(s2), 4)) stop 2
s2 = f_c_string(s1, .true.)
if (len(s1) /= int(strlen(s2), 4)) stop 3
s2 = f_c_string(s1, .false.)
if (len_trim(s1) /= int(strlen(s2), 4)) stop 4
asis = .true.
s2 = f_c_string(s1, asis)
if (len(s1) /= int(strlen(s2), 4)) stop 5
asis = .false.
s2 = f_c_string(s1, asis)
if (len_trim(s1) /= int(strlen(s2), 4)) stop 6
end program foo

50
gcc/testsuite/gfortran.dg/f_c_string2.f90 Normal file
View file

@ -0,0 +1,50 @@
! { dg-do run }
! See pr117643, this tests passing of the optional argument when it is
! not present.
program foo
use iso_c_binding, only : c_null_char, c_char, f_c_string, c_size_t
implicit none
logical asis
character(len=6, kind=c_char) :: s1
character(len=:, kind=c_char), allocatable :: s2
interface
!
! strlen() counts up to '\0', and excludes it from the count
!
function strlen(s) bind(c,name="strlen")
import c_char, c_size_t
integer(c_size_t) strlen
character(len=1,kind=c_char), intent(in) :: s(*)
end function strlen
end interface
s1 = 'abc '
asis = .true.
call check (asis) ! OK
asis = .false.
call check (asis) ! OK
call check () ! segfault fixed
contains
subroutine check (asis)
logical, optional, intent(in) :: asis
s2 = f_c_string(s1, asis)
if (present(asis)) then
if (asis) then
if (int(strlen(s2)) /= 6) then
stop 1
endif
else
if (len_trim(s1) /= int(strlen(s2))) then
stop 2
endif
endif
endif
end subroutine check
end program foo