[gcc/devel/omp/gcc-16] Fortran: f_c_string intrinsic improvements

https://gcc.gnu.org/g:2125b5f91dab0d48baecb9bb7e74b8df94c9347f

commit 2125b5f91dab0d48baecb9bb7e74b8df94c9347f
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.
    
    (cherry picked from commit 656d97bbc4b0f4614f1f074ab3ca7c425fe569d2)

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 bfa8d3163de1..a2a6c6979d98 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -9846,37 +9846,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.  */
@@ -9971,141 +9940,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