https://gcc.gnu.org/g:656d97bbc4b0f4614f1f074ab3ca7c425fe569d2
commit r17-922-g656d97bbc4b0f4614f1f074ab3ca7c425fe569d2 Author: Sandra Loosemore <[email protected]> Date: Thu May 28 22:33:33 2026 +0000 Fortran: f_c_string intrinsic improvements The existing implementation of f_c_string is quite inefficient, doing either 2 or 3 allocations and copies of the input string prefix. This rewrite adds folding for constant string arguments and handles other cases with a single allocation and copy. This patch also adds the missing documentation for this intrinsic to the gfortran manual. gcc/fortran/ChangeLog * intrinsic.texi (F_C_STRING): New section. * trans-intrinsic.cc (conv_trim): Delete. (conv_isocbinding_function): Rewrite the F_C_STRING case. gcc/testsuite/ChangeLog * gfortran.dg/f_c_string3.f90: New. * gfortran.dg/f_c_string4.f90: New. * gfortran.dg/f_c_string5.f90: New. Diff: --- gcc/fortran/intrinsic.texi | 59 +++++- gcc/fortran/trans-intrinsic.cc | 312 ++++++++++++++++-------------- gcc/testsuite/gfortran.dg/f_c_string3.f90 | 53 +++++ gcc/testsuite/gfortran.dg/f_c_string4.f90 | 26 +++ gcc/testsuite/gfortran.dg/f_c_string5.f90 | 20 ++ 5 files changed, 321 insertions(+), 149 deletions(-) diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 53014f478820..64309fd852ca 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -159,6 +159,7 @@ Some basic guidelines for editing this document: * @code{EXP}: EXP, Exponential function * @code{EXPONENT}: EXPONENT, Exponent function * @code{EXTENDS_TYPE_OF}: EXTENDS_TYPE_OF, Query dynamic type for extension +* @code{F_C_STRING}: F_C_STRING, Convert character scalar to C string * @code{FDATE}: FDATE, Subroutine (or function) to get the current time as a string * @code{FGET}: FGET, Read a single character in stream mode from stdin * @code{FGETC}: FGETC, Read a single character in stream mode @@ -3557,7 +3558,8 @@ Fortran 2023 and later. @item @emph{See also}: @ref{C_LOC}, @* @ref{C_F_POINTER}, @* -@ref{C_F_PROCPOINTER} +@ref{C_F_PROCPOINTER}, @* +@ref{F_C_STRING} @end table @@ -6394,6 +6396,61 @@ Fortran 2003 and later +@node F_C_STRING +@section @code{F_C_STRING} --- Convert Fortran character scalar to C string +@fnindex F_C_STRING +@cindex string, convert Fortran to C + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = F_C_STRING(STRING[, ASIS])} + +@item @emph{Description}: +The @code{F_C_STRING} intrinsic is equivalent to @code{STRING//C_NULL_CHAR} +if the @code{ASIS} argument is present and true, and to +@code{TRIM(STRING)//C_NULL_CHAR} otherwise. + +@item @emph{Class}: +Transformational function + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{STRING} @tab A character scalar of kind @code{C_CHAR}. +@item @var{ASIS} @tab An optional logical scalar. +@end multitable + +@item @emph{Return value}: +The result is a null-terminated character scalar of the same type and kind +as @code{STRING}, suitable for passing to a C function that accepts a +@code{char *} argument. + +@item @emph{Example}: +@smallexample +program main + use iso_c_binding, only: f_c_string, c_char + implicit none (external, type) + character(:, c_char), allocatable :: s1, s2, s3 + + ! s1 is null-terminated "hello, world! " + s1 = f_c_string ("hello, world! ", .true.) + + ! s2 is null-terminated "hello, world!" + s2 = f_c_string ("hello, world! ", .false.) + + ! s3 is null-terminated "hello, world!" (same as s2 example) + s3 = f_c_string ("hello, world! ") +end program main + +@end smallexample + +@item @emph{Standard}: +Fortran 2023 and later. + +@item @emph{See also}: +@ref{C_F_STRPOINTER} +@end table + + @node FDATE @section @code{FDATE} --- Get the current time as a string @fnindex FDATE diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index a18a64360628..fdb9ddb52eaa 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -9840,37 +9840,6 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) se->expr = temp_var; } - -/* 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. */ @@ -9965,141 +9934,188 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr) 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; + bool need_asis = false, need_trim = false; + gfc_se asis_se; - /* 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) + 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); - + need_trim = true; + need_asis = false; + } + else if (asis->expr_type == EXPR_CONSTANT) + { + need_asis = asis->value.logical; + need_trim = !need_asis; + } + else + { + /* A conditional expression is needed. */ + need_asis = true; + need_trim = true; 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) + && 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)); + asis_se.expr + = build3_loc (input_location, COND_EXPR, + logical_type_node, present, + asis_se.expr, logical_false_node); } - 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_make_safe_expr (&asis_se); + } - gfc_add_expr_to_block (&se->pre, tmp); + /* Handle the case of a constant string argument first. */ + if (string->expr_type == EXPR_CONSTANT) + { + /* Output for the asis "then" case goes tlen/tstr, and the + trimmed case in elen/estr. */ + tree elen, estr, tlen, tstr; + elen = estr = tlen = tstr = NULL_TREE; - var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node, - asis_se.expr, tvar, evar); - gfc_add_expr_to_block (&se->pre, var); + gfc_char_t *orig_string = string->value.character.string; + gfc_charlen_t orig_len = string->value.character.length; + gfc_charlen_t n; + gfc_char_t *buf + = (gfc_char_t *) alloca ((orig_len + 1) * sizeof (gfc_char_t)); + memcpy (buf, orig_string, orig_len * sizeof (gfc_char_t)); + buf[orig_len] = '\0'; + int kind = gfc_default_character_kind; + gcc_assert (string->ts.kind == kind); - len = fold_build3_loc (input_location, COND_EXPR, cnode, - asis_se.expr, tlen, elen); - gfc_add_expr_to_block (&se->pre, len); + /* Build the new string constant(s). */ + if (need_asis) + { + tstr = gfc_build_wide_string_const (kind, orig_len + 1, buf); + tlen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tstr))); + if (!need_trim) + { + se->expr = tstr; + se->string_length = tlen; + return; + } + } + if (need_trim) + { + for (n = orig_len; n; n--) + if (buf[n - 1] != ' ') + break; + buf[n] = '\0'; + if (need_asis && n == orig_len) + { + /* Special case; trimming is a no-op. Add side-effects + from the condition and then just return the string + without a conditional. */ + gfc_add_block_to_block (&se->pre, &asis_se.pre); + se->expr = tstr; + se->string_length = tlen; + return; + } + else + { + estr = gfc_build_wide_string_const (kind, n + 1, buf); + elen = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (estr))); + } + if (!need_asis) + { + se->expr = estr; + se->string_length = elen; + return; + } + } + gcc_assert (need_asis && need_trim); + gfc_add_block_to_block (&se->pre, &asis_se.pre); + se->expr + = fold_build3_loc (input_location, COND_EXPR, + pchar_type_node, asis_se.expr, + tstr, estr); + se->string_length + = fold_build3_loc (input_location, COND_EXPR, + gfc_charlen_type_node, asis_se.expr, + tlen, elen); + return; } 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); + /* We have to generate code to do the string transformation(s) at + runtime. */ + { + tree tmp; + + /* Convert input string. */ + gfc_se sse; + gfc_init_se (&sse, se); + gfc_conv_expr (&sse, string); + gfc_conv_string_parameter (&sse); + gfc_make_safe_expr (&sse); + gfc_add_block_to_block (&se->pre, &sse.pre); + + /* Use a temporary for the (possibly trimmed) string length. */ + tree lenvar = gfc_create_var (gfc_charlen_type_node, NULL); + gfc_add_modify (&se->pre, lenvar, sse.string_length); + + /* Build the expression for a call to LEN_TRIM if we may need + to trim the string. If it's conditional, handle that too. */ + if (need_trim) + { + tree trimlen + = build_call_expr_loc (input_location, + gfor_fndecl_string_len_trim, 2, + lenvar, sse.expr); + if (need_asis) + { + gfc_add_block_to_block (&se->pre, &asis_se.pre); + tmp = fold_build3_loc (input_location, COND_EXPR, + gfc_charlen_type_node, asis_se.expr, + lenvar, trimlen); + gfc_add_modify (&se->pre, lenvar, tmp); + } + else + gfc_add_modify (&se->pre, lenvar, trimlen); + } - tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string, - 6, len, var, - tse.string_length, tse.expr, - rse.string_length, rse.expr); + /* Allocate a new string newvar that is lenvar+1 bytes long. + memcpy the first lenvar bytes from the input string, and + add a null character. Note that lenvar, the length of + the (trimmed) original string, has type gfc_charlen_type_node, + but newlen is size_type_node. */ + tree string_type_node = build_pointer_type (char_type_node); + tree newvar = gfc_create_var (string_type_node, NULL); + tree newlen = fold_build2_loc (input_location, PLUS_EXPR, + size_type_node, + fold_convert (size_type_node, + lenvar), + size_one_node); + gfc_add_modify (&se->pre, newvar, + gfc_call_malloc (&se->pre, string_type_node, + newlen)); + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMCPY), + 3, + fold_convert (pvoid_type_node, newvar), + fold_convert (pvoid_type_node, sse.expr), + fold_convert (size_type_node, lenvar)); gfc_add_expr_to_block (&se->pre, tmp); - } - - se->expr = var; - se->string_length = len; + tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR, + string_type_node, newvar, + fold_convert (size_type_node, lenvar)); + tmp = fold_build1_loc (input_location, INDIRECT_REF, + char_type_node, tmp); + gfc_add_modify (&se->pre, tmp, + fold_convert (char_type_node, integer_zero_node)); + + /* Remember to free the string later. */ + tmp = gfc_call_free (newvar); + gfc_add_expr_to_block (&se->post, tmp); -#undef cnode + /* Return the result. */ + se->expr = newvar; + se->string_length = fold_convert (gfc_charlen_type_node, newlen); + return; + } } else gcc_unreachable (); diff --git a/gcc/testsuite/gfortran.dg/f_c_string3.f90 b/gcc/testsuite/gfortran.dg/f_c_string3.f90 new file mode 100644 index 000000000000..3e9d4a79d3b5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/f_c_string3.f90 @@ -0,0 +1,53 @@ +! Test f_c_string cases that can be fully constant-folded +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +use iso_c_binding, only: f_c_string, c_char +implicit none (external, type) +character(*, c_char), parameter :: str1 = "blah1" +character(*, c_char), parameter :: str2 = "blah2" +character(*, c_char), parameter :: str3 = "blah3" +character(*, c_char), parameter :: str4 = "blah4 " +character(*, c_char), parameter :: str5 = "blah5 " +character(*, c_char), parameter :: str6 = "blah6 " +external foo + +call foo(f_c_string("hello world1", asis=.true.)) +! { dg-final { scan-tree-dump-times "hello world1.\[^\\n\\r\]*, 13" 1 "original" } } + +call foo(f_c_string("hello world2", asis=.false.)) +! { dg-final { scan-tree-dump-times "hello world2.\[^\\n\\r\]*, 13" 1 "original" } } + +call foo(f_c_string("hello world3")) +! { dg-final { scan-tree-dump-times "hello world3.\[^\\n\\r\]*, 13" 1 "original" } } + +call foo(f_c_string("hello1 ", asis=.true.)) +! { dg-final { scan-tree-dump-times "hello1 .\[^\\n\\r\]*, 8" 1 "original" } } + +call foo(f_c_string("hello2 ", asis=.false.)) +! { dg-final { scan-tree-dump-times "hello2.\[^\\n\\r\]*, 7" 1 "original" } } + +call foo(f_c_string("hello3 ")) +! { dg-final { scan-tree-dump-times "hello3.\[^\\n\\r\]*, 7" 1 "original" } } + +call foo(f_c_string(str1, asis=.true.)) +! { dg-final { scan-tree-dump-times "blah1.\[^\\n\\r\]*, 6" 1 "original" } } + +call foo(f_c_string(str2, asis=.false.)) +! { dg-final { scan-tree-dump-times "blah2.\[^\\n\\r\]*, 6" 1 "original" } } + +call foo(f_c_string(str3)) +! { dg-final { scan-tree-dump-times "blah3.\[^\\n\\r\]*, 6" 1 "original" } } + +call foo(f_c_string(str4, asis=.true.)) +! { dg-final { scan-tree-dump-times "blah4 .\[^\\n\\r\]*, 9" 1 "original" } } + +call foo(f_c_string(str5, asis=.false.)) +! { dg-final { scan-tree-dump-times "blah5.\[^\\n\\r\]*, 6" 1 "original" } } + +call foo(f_c_string(str6)) +! { dg-final { scan-tree-dump-times "blah6.\[^\\n\\r\]*, 6" 1 "original" } } + +end + + diff --git a/gcc/testsuite/gfortran.dg/f_c_string4.f90 b/gcc/testsuite/gfortran.dg/f_c_string4.f90 new file mode 100644 index 000000000000..d38e16f02686 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/f_c_string4.f90 @@ -0,0 +1,26 @@ +! Test f_c_string cases with constant strings but that need a conditional. +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine doit (x) + +use iso_c_binding, only: f_c_string, c_char +implicit none (external, type) +logical :: x +character(*, c_char), parameter :: str1 = "blah1" +character(*, c_char), parameter :: str2 = "blah2 " +external foo + +call foo(f_c_string("hello world1", asis=x)) +! { dg-final { scan-tree-dump-times "hello world1.\[^\\n\\r\]*, 13" 1 "original" } } + +call foo(f_c_string("hello1 ", asis=x)) +! { dg-final { scan-tree-dump-times "hello1 .\[^\\n\\r\]* 8 : 7" 1 "original" } } + +call foo(f_c_string(str1, asis=x)) +! { dg-final { scan-tree-dump-times "blah1.\[^\\n\\r\]*, 6" 1 "original" } } + +call foo(f_c_string(str2, asis=x)) +! { dg-final { scan-tree-dump-times "blah2 .\[^\\n\\r\]* 9 : 6" 1 "original" } } + +end subroutine diff --git a/gcc/testsuite/gfortran.dg/f_c_string5.f90 b/gcc/testsuite/gfortran.dg/f_c_string5.f90 new file mode 100644 index 000000000000..25c5115f2141 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/f_c_string5.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! This is the example from the manual. + +program main + use iso_c_binding, only: f_c_string, c_char + implicit none (external, type) + character(:, c_char), allocatable :: s1, s2, s3 + + ! s1 is null-terminated "hello, world! " + s1 = f_c_string ("hello, world! ", .true.) + if (len(s1) .ne. 17) stop 100 + + ! s2 is null-terminated "hello, world!" + s2 = f_c_string ("hello, world! ", .false.) + if (len(s2) .ne. 14) stop 200 + + ! s3 is null-terminated "hello, world!" (same as s2 example) + s3 = f_c_string ("hello, world! ") + if (len(s3) .ne. 14) stop 200 +end program main
