Re: [PATCH 2/2] Fortran: f_c_string intrinsic improvements

From a6b2fe7f54bffc4006bee4b20dd788c0a81a9e2e Mon Sep 17 00:00:00 2001
From: Sandra Loosemore <[email protected]>
Date: Thu, 28 May 2026 22:33:33 +0000
Subject: [PATCH 1/2] Fortran: Add c_f_strpointer intrinsic

This is a missing Fortran 2023 feature.

gcc/fortran/ChangeLog
	* check.cc (gfc_check_c_f_strpointer): New.
	* f95-lang.cc (gfc_init_builtin_functions): Add BUILT_IN_STRNLEN.
	* gfortran.h (enum gfc_isym_id): Add GFC_ISYM_C_F_STRPOINTER.
	* gfortran.texi (Interoperable Subroutines and Functions): Mention
	f_c_string and c_f_strpointer.
	* intrinsic.cc (add_subroutines): Add c_f_strpointer.  Fix nearby
	whitespace errors.
	(sort_actual): Handle first argument to c_f_strpointer specially.
	* intrinsic.h (gfc_check_c_f_strpointer): Declare.
	* intrinsic.texi (C_F_STRPOINTER): New section.  Add entry to menu
	and cross-references from similar functions.
	* iso-c-binding.def: Add c_f_strpointer.
	* trans-intrinsic.cc (conv_isocbinding_subroutine_strpointer): New.
	(gfc_conv_intrinsic_subroutine): Call it.

gcc/testsuite/ChangeLog
	* gfortran.dg/c_f_strpointer-1.f90: New.
	* gfortran.dg/c_f_strpointer-2.f90: New.
	* gfortran.dg/c_f_strpointer-3.f90: New.
	* gfortran.dg/c_f_strpointer-4.f90: New.
	* gfortran.dg/c_f_strpointer-5.f90: New.
	* gfortran.dg/c_f_strpointer-6.f90: New.
	* gfortran.dg/c_f_strpointer-7.f90: New.
	* gfortran.dg/c_f_strpointer-8.f90: New.
	* gfortran.dg/c_f_strpointer-9.f90: New.
	* gfortran.dg/c_f_strpointer-10.f90: New.
	* gfortran.dg/pr108961.f90: Rename locally-defined c_f_strpointer.

Co-authored-by: Tobias Burnus <[email protected]>
---
 gcc/fortran/check.cc                          | 142 ++++++++++++++++++
 gcc/fortran/f95-lang.cc                       |   5 +
 gcc/fortran/gfortran.h                        |   1 +
 gcc/fortran/gfortran.texi                     |   7 +
 gcc/fortran/intrinsic.cc                      |  48 +++++-
 gcc/fortran/intrinsic.h                       |   1 +
 gcc/fortran/intrinsic.texi                    |  86 ++++++++++-
 gcc/fortran/iso-c-binding.def                 |   2 +
 gcc/fortran/trans-intrinsic.cc                | 120 +++++++++++++++
 .../gfortran.dg/c_f_strpointer-1.f90          |  30 ++++
 .../gfortran.dg/c_f_strpointer-10.f90         |  39 +++++
 .../gfortran.dg/c_f_strpointer-2.f90          |  33 ++++
 .../gfortran.dg/c_f_strpointer-3.f90          |  37 +++++
 .../gfortran.dg/c_f_strpointer-4.f90          |  18 +++
 .../gfortran.dg/c_f_strpointer-5.f90          |  19 +++
 .../gfortran.dg/c_f_strpointer-6.f90          |  20 +++
 .../gfortran.dg/c_f_strpointer-7.f90          |  50 ++++++
 .../gfortran.dg/c_f_strpointer-8.f90          |  11 ++
 .../gfortran.dg/c_f_strpointer-9.f90          |  34 +++++
 gcc/testsuite/gfortran.dg/pr108961.f90        |   4 +-
 20 files changed, 699 insertions(+), 8 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-1.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-10.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-2.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-3.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-4.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-5.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-6.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-7.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-8.f90
 create mode 100644 gcc/testsuite/gfortran.dg/c_f_strpointer-9.f90

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index c4d9901a82d..ad6f66015d7 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -6306,6 +6306,148 @@ gfc_check_c_f_procpointer (gfc_expr *cptr, gfc_expr *fptr)
 }
 
 
+/* Handle both forms of this intrinsic, differentiated by whether
+   the first argument is a scalar or array.  */
+
+bool
+gfc_check_c_f_strpointer (gfc_expr *arg0, gfc_expr *fstrptr,
+			  gfc_expr *nchars)
+{
+  bool arg0_is_scalar = false;
+  const char *arg0name = "cstrarray";
+
+  if (arg0->rank == 0)
+    {
+      arg0_is_scalar = true;
+      arg0name = "cstrptr";
+
+      /* cstrptr is a scalar of type c_ptr.  It is an intent in argument
+	 holding the C address of a contiguous array s of nchars characters.
+	 Its value must not be the C address of a Fortran variable without
+	 the target attribute.  */
+      if (arg0->ts.type != BT_DERIVED
+	  || arg0->ts.u.derived->from_intmod != INTMOD_ISO_C_BINDING
+	  || arg0->ts.u.derived->intmod_sym_id != ISOCBINDING_PTR)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L shall be "
+		     "a scalar of type C_PTR",
+		     arg0name, gfc_current_intrinsic, &arg0->where);
+	  return false;
+	}
+
+      if (!nchars)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic shall be present "
+		     "when the %qs argument at %L is a C_PTR",
+		     gfc_current_intrinsic_arg[2]->name,
+		     gfc_current_intrinsic, arg0name, &arg0->where);
+	  return false;
+	}
+    }
+  else
+    {
+      /* arg0 is a rank-one character array of kind c_char and character
+	 length one.  It is an intent in argument.  Its actual argument
+	 must be simply contiguous and have the target attribute.  */
+      if (arg0->rank != 1
+	  || arg0->ts.type != BT_CHARACTER
+	  || arg0->ts.kind != gfc_default_character_kind
+	  || get_ul_from_cst_cl (arg0->ts.u.cl) != 1)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L shall be "
+		     "a rank-one character array of kind C_CHAR and "
+		     "character length one",
+		     arg0name, gfc_current_intrinsic, &arg0->where);
+	  return false;
+	}
+      if (!gfc_is_simply_contiguous (arg0, true, false))
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L shall be "
+		     "simply contiguous",
+		     arg0name, gfc_current_intrinsic, &arg0->where);
+	  return false;
+	}
+      if (!gfc_expr_attr (arg0).target)
+	{
+	  gfc_error ("%qs argument of %qs intrinsic at %L shall have "
+		     "the TARGET attribute",
+		     arg0name, gfc_current_intrinsic, &arg0->where);
+	  return false;
+	}
+
+      /* If cstrarray is assumed-size, nchars must be present.  */
+      if (!nchars)
+	{
+	  gfc_array_ref *ar = gfc_find_array_ref (arg0);
+	  if (ar->as && ar->as->type == AS_ASSUMED_SIZE
+	      && (ar->type == AR_FULL || ar->end[0] == nullptr))
+	    {
+	      gfc_error ("%qs argument of %qs intrinsic shall be present "
+			 "when the %qs argument at %L is assumed-size",
+			 gfc_current_intrinsic_arg[2]->name,
+			 gfc_current_intrinsic, arg0name, &arg0->where);
+	      return false;
+	    }
+	}
+    }
+
+  /* fstrptr is a scalar deferred-length character pointer of kind c_char.
+     It is an intent out argument [...]  */
+  if (fstrptr->rank != 0
+      || fstrptr->ts.type != BT_CHARACTER
+      || fstrptr->ts.kind != gfc_default_character_kind
+      || !fstrptr->ts.deferred
+      || !gfc_expr_attr (fstrptr).pointer)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L shall be "
+		 "a scalar deferred-length character pointer of kind C_CHAR",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &fstrptr->where);
+      return false;
+    }
+  if (gfc_expr_attr (fstrptr).intent == INTENT_IN)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L cannot be INTENT(IN)",
+		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
+		 &fstrptr->where);
+      return false;
+    }
+
+  /* For the array form: nchars is an optional integer scalar with intent in.
+     If nchars is present, its value must be nonnegative and not greater
+     than the size of cstrarray.
+     For the scalar form: nchars is an integer scalar with intent in.  Its
+     value must be nonnegative.  */
+  if (!nchars)
+    return true;
+  if (nchars->rank != 0 || nchars->ts.type != BT_INTEGER)
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L shall be "
+		 "a scalar integer",
+		 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
+		 &nchars->where);
+      return false;
+    }
+  if (nchars->expr_type != EXPR_CONSTANT)
+    return true;
+  if (!nonnegative_check (gfc_current_intrinsic_arg[2]->name, nchars))
+    return false;
+  if (!arg0_is_scalar)
+    {
+      mpz_t asize;
+      if (gfc_array_size (arg0, &asize)
+	  && mpz_cmp (nchars->value.integer, asize) > 0)
+	{
+	  gfc_error ("%qs at %L must not be greater than the size of %qs",
+		     gfc_current_intrinsic_arg[2]->name, &nchars->where,
+		     arg0name);
+	  return false;
+	}
+    }
+
+  return true;
+}
+
 bool
 gfc_check_c_funloc (gfc_expr *x)
 {
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 45aab34865f..1cdc83500a9 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -1036,6 +1036,11 @@ gfc_init_builtin_functions (void)
   gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC,
 		      "realloc", ATTR_NOTHROW_LEAF_LIST);
 
+  ftype = build_function_type_list (size_type_node, pchar_type_node,
+				    size_type_node, NULL_TREE);
+  gfc_define_builtin ("__builtin_strnlen", ftype, BUILT_IN_STRNLEN,
+		      "strnlen", ATTR_PURE_NOTHROW_LEAF_LIST);
+
   /* Type-generic floating-point classification built-ins.  */
 
   ftype = build_function_type (integer_type_node, NULL_TREE);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6c45e9b1682..67b351347c4 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -501,6 +501,7 @@ enum gfc_isym_id
   GFC_ISYM_C_ASSOCIATED,
   GFC_ISYM_C_F_POINTER,
   GFC_ISYM_C_F_PROCPOINTER,
+  GFC_ISYM_C_F_STRPOINTER,
   GFC_ISYM_C_FUNLOC,
   GFC_ISYM_C_LOC,
   GFC_ISYM_C_SIZEOF,
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 16553508a58..716e58cf1b3 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3117,6 +3117,13 @@ example, we ignore the return value:
   end
 @end smallexample
 
+Fortran 2023 added two new intrinsic functions for converting between
+C and Fortran string representations: @code{f_c_string} transforms a
+Fortran string into a C string by appending a null character, and
+@code{c_f_strpointer} allows access to a null-terminated C string or
+simply contiguous array of @code{c_char} as a Fortran deferred-length
+character pointer.
+
 The intrinsic procedures are described in @ref{Intrinsic Procedures}.
 
 @node Working with C Pointers
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 6ffd7237468..1c97af087d5 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3957,14 +3957,27 @@ add_subroutines (void)
 	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
 	      "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN,
 	      "lower", BT_INTEGER, di, OPTIONAL, INTENT_IN);
-  make_from_module();
+  make_from_module ();
 
   add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
 	      BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
 	      NULL, NULL,
 	      "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
 	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
-  make_from_module();
+  make_from_module ();
+
+  /* This represents both forms of the intrinsic; the one with the
+     signature given here, and the one that accepts a scalar for the
+     first argument with name "cstrptr" instead of "cstrarray".
+     This is handled by special-casing in sort_actual as well as
+     in the check function.  */
+  add_sym_3s ("c_f_strpointer", GFC_ISYM_C_F_STRPOINTER, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_F2023, gfc_check_c_f_strpointer,
+	      NULL, NULL,
+	      "cstrarray", BT_VOID, dc, REQUIRED, INTENT_IN,
+	      "fstrptr", BT_UNKNOWN, dc, REQUIRED, INTENT_OUT,
+	      "nchars", BT_INTEGER, di, OPTIONAL, INTENT_IN);
+  make_from_module ();
 
   /* Internal subroutine for emitting a runtime error.  */
 
@@ -4516,6 +4529,7 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
 {
   gfc_actual_arglist *actual, *a;
   gfc_intrinsic_arg *f;
+  bool is_c_f_strpointer = false;
 
   remove_nullargs (ap);
   actual = *ap;
@@ -4536,7 +4550,9 @@ sort_actual (const char *name, gfc_actual_arglist **ap,
     return true;
 
   /* ALLOCATED has two mutually exclusive keywords, but only one
-     can be present at time and neither is optional. */
+     can be present at time and neither is optional.  Likewise
+     C_F_STRPOINTER, but since that subroutine has multiple arguments
+     it has to be handled in the keywords loop below.  */
   if (strcmp (name, "allocated") == 0)
     {
       if (!a)
@@ -4605,9 +4621,32 @@ whoops:
 keywords:
   /* Associate the remaining actual arguments, all of which have
      to be keyword arguments.  */
+  is_c_f_strpointer = strcmp (name, "c_f_strpointer") == 0;
   for (; a; a = a->next)
     {
       int idx;
+
+      /* Special case C_F_STRPOINTER.  The first argument can either
+	 be an array named "cstrarray" or a scalar named "cstrptr".  */
+      if (is_c_f_strpointer)
+	{
+	  idx = 0;
+	  if (strcmp (a->name, "cstrarray") == 0)
+	    {
+	      if (a->expr->rank != 0)
+		goto got_keyword;
+	      gfc_error ("Array entity required at %L", &a->expr->where);
+	      return false;
+	    }
+	  else if (strcmp (a->name, "cstrptr") == 0)
+	    {
+	      if (a->expr->rank == 0)
+		goto got_keyword;
+	      gfc_error ("Scalar entity required at %L", &a->expr->where);
+	      return false;
+	    }
+	}
+
       FOR_EACH_VEC_ELT (dummy_args, idx, f)
 	if (strcmp (a->name, f->name) == 0)
 	  break;
@@ -4623,10 +4662,11 @@ keywords:
 	  return false;
 	}
 
+    got_keyword:
       if (ordered_actual_args[idx] != NULL)
 	{
 	  gfc_error ("Argument %qs appears twice in call to %qs at %L",
-		     f->name, name, where);
+		     a->name, name, where);
 	  return false;
 	}
       ordered_actual_args[idx] = a;
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 0b520f03332..ad0c54f2959 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -168,6 +168,7 @@ bool gfc_check_sizeof (gfc_expr *);
 bool gfc_check_c_associated (gfc_expr *, gfc_expr *);
 bool gfc_check_c_f_pointer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_c_f_procpointer (gfc_expr *, gfc_expr *);
+bool gfc_check_c_f_strpointer (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_c_funloc (gfc_expr *);
 bool gfc_check_c_loc (gfc_expr *);
 bool gfc_check_c_sizeof (gfc_expr *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index f5a29606eb4..53014f47882 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -106,6 +106,7 @@ Some basic guidelines for editing this document:
 * @code{C_ASSOCIATED}:  C_ASSOCIATED, Status of a C pointer
 * @code{C_F_POINTER}:   C_F_POINTER, Convert C into Fortran pointer
 * @code{C_F_PROCPOINTER}: C_F_PROCPOINTER, Convert C into Fortran procedure pointer
+* @code{C_F_STRPOINTER}: C_F_STRPOINTER, Convert C string to Fortran string pointer
 * @code{C_FUNLOC}:      C_FUNLOC,  Obtain the C address of a procedure
 * @code{C_LOC}:         C_LOC,     Obtain the C address of an object
 * @code{C_SIZEOF}:      C_SIZEOF,  Size in bytes of an expression
@@ -3417,7 +3418,8 @@ Fortran 2003 and later, with @var{LOWER} argument Fortran 2023 and later
 
 @item @emph{See also}:
 @ref{C_LOC}, @*
-@ref{C_F_PROCPOINTER}
+@ref{C_F_PROCPOINTER}, @*
+@ref{C_F_STRPOINTER}
 @end table
 
 
@@ -3475,7 +3477,87 @@ Fortran 2003 and later
 
 @item @emph{See also}:
 @ref{C_LOC}, @*
-@ref{C_F_POINTER}
+@ref{C_F_POINTER}, @*
+@ref{C_F_STRPOINTER}
+@end table
+
+
+@node C_F_STRPOINTER
+@section @code{C_F_STRPOINTER} --- Convert C string into Fortran string pointer
+@fnindex C_F_STRPOINTER
+@cindex string, convert C to Fortran
+
+@table @asis
+@item @emph{Synopsis}:
+@multitable @columnfractions .80
+@item @code{CALL C_F_STRPOINTER(CSTRARRAY, FSTRPTR[, NCHARS])}
+@item @code{CALL C_F_STRPOINTER(CSTRPTR, FSTRPTR, NCHARS)}
+@end multitable
+
+@item @emph{Description}:
+@code{C_F_STRPOINTER(CSTRARRAY, FSTRPTR[, NCHARS])}
+pointer-associates the deferred-length character pointer
+@code{FSTRPTR} with the initial substring of the simply contiguous
+Fortran character array @code{STRARRAY}, up to the first null character,
+the length @code{NCHARS} if specified, or the actual size of @code{CSTRARRAY}.
+
+@code{CALL C_F_STRPOINTER(CSTRPTR, FSTRPTR, NCHARS)}
+pointer-associates the deferred-length array pointer @code{FSTRPTR} with the
+initial substring of the continguous array of characters pointed to by
+the C pointer @code{CSTRPTR}, up to the first null character or
+length @code{NCHARS}.
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{CSTRARRAY}  @tab Rank-one character array of kind @code{C_CHAR}
+and character length one, which must be simply contiguous and have the
+@code{TARGET} attribute. It is @code{INTENT(IN)}.
+@item @var{CSTRPTR}  @tab Scalar of the type @code{C_PTR}. It is
+@code{INTENT(IN)}.
+@item @var{FSTRPTR}  @tab Scalar deferred-length character pointer of kind
+@code{C_CHAR}.  It is @code{INTENT(OUT)}.
+@item @var{NCHARS} @tab (Optional) Integer scalar.  It is @code{INTENT(IN)}.
+This argument can only be omitted for the @code{CSTRARRAY} form of the
+intrinsic, and only if @code{STRARRAY} is not assumed-size.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program main
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+  type(c_ptr) :: p
+  character (len=:, kind=c_char), pointer :: fp1, fp2
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  ! give array a terminating null so its C string length is 12.
+  a(13) = C_NULL_CHAR
+
+  ! p is a C pointer to the the first character in the array
+  p = C_LOC (a(1))
+
+  ! Make both fp1 and fp2 point to a with Fortran string length 12.
+  call c_f_strpointer (p, fp1, 15)
+  call c_f_strpointer (a, fp2)
+end program main
+
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2023 and later.
+
+@item @emph{See also}:
+@ref{C_LOC}, @*
+@ref{C_F_POINTER}, @*
+@ref{C_F_PROCPOINTER}
 @end table
 
 
diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def
index c7a67229273..041fcb2ff52 100644
--- a/gcc/fortran/iso-c-binding.def
+++ b/gcc/fortran/iso-c-binding.def
@@ -190,6 +190,8 @@ NAMED_SUBROUTINE (ISOCBINDING_F_POINTER, "c_f_pointer",
                   GFC_ISYM_C_F_POINTER, GFC_STD_F2003)
 NAMED_SUBROUTINE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer",
                   GFC_ISYM_C_F_PROCPOINTER, GFC_STD_F2003)
+NAMED_SUBROUTINE (ISOCBINDING_F_STRPOINTER, "c_f_strpointer",
+                  GFC_ISYM_C_F_STRPOINTER, GFC_STD_F2023)
 
 NAMED_FUNCTION (ISOCBINDING_ASSOCIATED, "c_associated",
 		GFC_ISYM_C_ASSOCIATED, GFC_STD_F2003)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 391e8061db7..a18a6436062 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10267,6 +10267,122 @@ conv_isocbinding_subroutine (gfc_code *code)
 }
 
 
+/* The following routine generates code for both forms of the intrinsic
+   subroutine C_F_STRPOINTER from the ISO_C_BINDING module.  */
+static tree
+conv_isocbinding_subroutine_strpointer (gfc_code *code)
+{
+  gfc_actual_arglist *arg = code->ext.actual;
+  gfc_expr *arg0 = arg->expr;
+  gfc_expr *fstrptr = arg->next->expr;
+  gfc_expr *nchars = arg->next->next->expr;
+  tree ptr;
+  tree size = NULL_TREE;
+  tree nc = NULL_TREE;
+  tree fstrptr_ptr, fstrptr_len;
+  stmtblock_t block;
+  gfc_init_block (&block);
+  gfc_se se0, se1, se2;
+  gfc_init_se (&se0, NULL);
+  gfc_init_se (&se1, NULL);
+  gfc_init_se (&se2, NULL);
+
+  /* arg0 can either be a simply contiguous rank-one character array,
+     or a scalar of type c_ptr that points to a contiguous array.
+     In the first case nchars may be omitted and defaults to the size
+     of the array.  */
+  if (arg0->rank == 1)
+    {
+      gfc_array_ref *ar = gfc_find_array_ref (arg0);
+      if (ar->as && ar->as->type == AS_ASSUMED_SIZE
+	  && (ar->type == AR_FULL || ar->end[0] == nullptr))
+	/* No size available.  */
+	gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, NULL);
+      else
+	{
+	  gfc_conv_array_parameter (&se0, arg0, true, NULL, NULL, &size);
+	  gcc_assert (size);
+	}
+      ptr = se0.expr;
+    }
+  else if (arg0->rank == 0)
+    {
+      /* Scalar case.  arg0 is a C pointer to the string, and the
+	 nchars argument is required.  */
+      gfc_conv_expr (&se0, arg0);
+      ptr = se0.expr;
+      /* We already issued a diagnostic for this in parsing.  */
+      gcc_assert (nchars);
+    }
+  else
+    gcc_unreachable ();
+
+  /* Translate the fortran array pointer argument.  AFAICT the
+     representation here is that this returns the pointer location in
+     se1.expr and there is a separate decl for the length.
+     Of course none of this is properly documented....  :-(  */
+  gfc_conv_expr (&se1, fstrptr);
+  fstrptr_ptr = se1.expr;
+  gcc_assert (fstrptr->ts.u.cl && fstrptr->ts.u.cl->backend_decl);
+  fstrptr_len = fstrptr->ts.u.cl->backend_decl;
+
+  /* Translate nchars, if provided.  If we have both the array size
+     and nchars, take the minimum value.  NC is the tree expr to hold
+     the value.  */
+  if (nchars)
+    {
+      gfc_conv_expr (&se2, nchars);
+      nc = se2.expr;
+      if (size)
+	nc = fold_build2_loc (input_location, MIN_EXPR,
+			      TREE_TYPE (nc), nc, size);
+      /* Check for the case where an optional dummy parameter is
+	 passed as the optional nchars argument.  It's not supposed to
+	 be omitted if we don't also have an array size; rather than
+	 produce a run-time error, assume size 0.  */
+      if (nchars->expr_type == EXPR_VARIABLE
+	  && nchars->symtree->n.sym->attr.dummy
+	  && nchars->symtree->n.sym->attr.optional)
+	{
+	  tree present = gfc_conv_expr_present (nchars->symtree->n.sym);
+	  nc = build3_loc (input_location, COND_EXPR,
+			   TREE_TYPE (nc), present, nc,
+			   size ? size : build_int_cst (TREE_TYPE (nc), 0));
+	}
+    }
+  else
+    {
+      gcc_assert (size);
+      nc = size;
+    }
+
+  /* Collect argument side-effect statements.  */
+  gfc_add_block_to_block (&block, &se0.pre);
+  gfc_add_block_to_block (&block, &se1.pre);
+  gfc_add_block_to_block (&block, &se2.pre);
+
+  /* Generate a call to builtin_strnlen to get the C string length
+     for the output fstrptr.  */
+  ptr = gfc_evaluate_now (ptr, &block);
+  size = build_call_expr_loc (input_location,
+			      builtin_decl_explicit (BUILT_IN_STRNLEN), 2,
+			      fold_convert (const_ptr_type_node, ptr),
+			      fold_convert (size_type_node, nc));
+
+  /* Stuff the raw C char pointer PTR and actual length SIZE into fstrptr.  */
+  gfc_add_modify (&block, fstrptr_ptr,
+		  fold_convert (TREE_TYPE (fstrptr_ptr), ptr));
+  gfc_add_modify (&block, fstrptr_len,
+		  fold_convert (gfc_charlen_type_node, size));
+
+  /* Collect argument cleanups.  */
+  gfc_add_block_to_block (&block, &se2.post);
+  gfc_add_block_to_block (&block, &se1.post);
+  gfc_add_block_to_block (&block, &se0.post);
+
+  return gfc_finish_block (&block);
+}
+
 /* Save and restore floating-point state.  */
 
 tree
@@ -13534,6 +13650,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_isocbinding_subroutine (code);
       break;
 
+    case GFC_ISYM_C_F_STRPOINTER:
+      res = conv_isocbinding_subroutine_strpointer (code);
+      break;
+
     case GFC_ISYM_CAF_SEND:
       res = conv_caf_send_to_remote (code);
       break;
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-1.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-1.f90
new file mode 100644
index 00000000000..cbdfd84f6a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-1.f90
@@ -0,0 +1,30 @@
+! { dg-do run }
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+  type(c_ptr) :: p
+  character (len=:, kind=c_char), pointer :: fp1, fp2
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  p = C_LOC (a(1))
+
+  ! check length is correct
+  call c_f_strpointer (p, fp1, 15)
+  if (len (fp1) .ne. 12) stop 100
+  call c_f_strpointer (a, fp2)
+  if (len (fp2) .ne. 12) stop 101
+
+  ! check that fp1 and fp2 both point to the contents of array a.
+  if (fp1(1:1) .ne. 'h') stop 200
+  if (fp2(1:1) .ne. 'h') stop 201
+  a(1) = 'H'
+  if (fp1(1:1) .ne. 'H') stop 202
+  if (fp2(1:1) .ne. 'H') stop 203
+     
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-10.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-10.f90
new file mode 100644
index 00000000000..ac18336d240
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-10.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+! Check handling of optional dummy nchars argument to c_f_strpointer
+! when its corresponding actual argument is an optional dummy that is
+! not present, and the C string argument has no size information (C 
+! pointer or assumed-size array).
+! The Fortran spec says this is not allowed, but it's a runtime error
+! and the gfortran implementation assumes size 0 in this case rather than
+! diagnosing it.
+
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  call doit (a, 12, 15)
+  call doit (a, 0)
+contains
+
+subroutine doit (aa, n, m)
+  character (kind=c_char, len=1), dimension(*), target, intent(inout) :: aa
+  integer, intent(in) :: n
+  integer, intent(in), optional :: m
+  character (len=:, kind=c_char), pointer :: fp
+  type(c_ptr) :: p
+
+  p = C_LOC (aa(1))
+  call c_f_strpointer (p, fp, m)
+  if (len(fp) .ne. n) stop 100
+  call c_f_strpointer (aa, fp, m)
+  if (len(fp) .ne. n) stop 200
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-2.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-2.f90
new file mode 100644
index 00000000000..b4a44db68c5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-2.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  call doit (a, 12, 15)
+  call doit (a(7:), 6, 9)
+
+contains
+
+subroutine doit (aa, n, m)
+  character (kind=c_char, len=1), dimension(*), target, intent(inout) :: aa
+  integer, intent(in) :: n, m
+  character (len=:, kind=c_char), pointer :: fp
+
+  ! check length is correct
+  call c_f_strpointer (aa, fp, m)
+  if (len (fp) .ne. n) stop 100
+
+  ! check that fp points to the contents of array aa.
+  if (fp(1:1) .ne. aa(1)) stop 101
+  aa(1) = '?'
+  if (fp(1:1) .ne. '?') stop 102
+end subroutine
+     
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-3.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-3.f90
new file mode 100644
index 00000000000..958145a3585
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-3.f90
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! Test that missing size argument is rejected.
+
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  call doit (a, 12)
+
+contains
+
+subroutine doit (aa, n)
+  character (kind=c_char, len=1), dimension(*), target, intent(inout) :: aa
+  integer, intent(in) :: n
+  character (len=:, kind=c_char), pointer :: fp
+  type(c_ptr) :: p
+
+  p = C_LOC (aa(1))
+  call c_f_strpointer (p, fp)  ! { dg-error ".nchars. argument of .c_f_strpointer. intrinsic shall be present when the .cstrptr. argument at .1. is a C_PTR" }
+  call c_f_strpointer (aa, fp) ! { dg-error ".nchars. argument of .c_f_strpointer. intrinsic shall be present when the .cstrarray. argument at .1. is assumed-size" }
+
+  ! These are all OK, they are known-size array sections of the assumed-size
+  ! array aa.
+  call c_f_strpointer (aa(:10), fp)
+  call c_f_strpointer (aa(:huge(1)), fp)
+  call c_f_strpointer (aa(5:10), fp)
+
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-4.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-4.f90
new file mode 100644
index 00000000000..e6268172f98
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-4.f90
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Test that non-contiguous array section argument is rejected.
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+  character (len=:, kind=c_char), pointer :: fp
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+
+  call c_f_strpointer (a(1:13), fp)
+  call c_f_strpointer (a(1:13:2), fp)  ! { dg-error ".cstrarray. argument of .c_f_strpointer. intrinsic at .1. shall be simply contiguous" }
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-5.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-5.f90
new file mode 100644
index 00000000000..d9de7bf830b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-5.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! Test that multi-dimensional array arguments are rejected.
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), target :: a(15), b(3,5)
+  character (len=:, kind=c_char), pointer :: fp
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  b = reshape (a, shape (b))
+
+  call c_f_strpointer (a, fp)
+  call c_f_strpointer (b, fp)  ! { dg-error ".cstrarray. argument of .c_f_strpointer. intrinsic at .1. shall be a rank-one character array of kind C_CHAR and character length one" }
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-6.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-6.f90
new file mode 100644
index 00000000000..a90526af284
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-6.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! Test that lack of target attribute and wrong-length character array are
+! rejected.
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15) :: a
+  character (kind=c_char, len=4), dimension(15), target :: b
+  character (len=:, kind=c_char), pointer :: fp
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  b = a
+  call c_f_strpointer (a, fp)  ! { dg-error ".cstrarray. argument of .c_f_strpointer. intrinsic at .1. shall have the TARGET attribute" }
+  call c_f_strpointer (b, fp)  ! { dg-error ".cstrarray. argument of .c_f_strpointer. intrinsic at .1. shall be a rank-one character array of kind C_CHAR and character length one" }
+end program
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-7.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-7.f90
new file mode 100644
index 00000000000..b9531fc4c09
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-7.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! Test that c_f_strpointer works with strings/arrays of known length but
+! no null terminator character.
+
+module mod
+use iso_c_binding
+implicit none(type, external)
+type t
+  type(c_ptr) :: cptr
+  character(1, c_char) :: carr(10)
+end type t
+contains
+subroutine sub(x, y)
+  type(t), target :: x
+  character, pointer, contiguous, intent(in) :: y(:)
+  character(:), pointer :: fstr
+
+  call c_f_strpointer (x%cptr, fstr, 10)
+  print *, len(fstr), fstr
+  if (len(fstr) /= 10 .or. fstr /= "1234567890") stop 1
+
+  call c_f_strpointer (x%carr, fstr)
+  print *, len(fstr), fstr
+  if (len(fstr) /= 10 .or. fstr /= "abcdefghij") stop 2
+
+  call c_f_strpointer (y, fstr)
+  if (len(fstr) /= 10 .or. fstr /= "abcdefghij") stop 3
+
+  call c_f_strpointer (y(5:), fstr)
+  if (len(fstr) /= 6 .or. fstr /= "efghij") stop 4
+
+  call c_f_strpointer (x%carr(2:4), fstr)
+  if (len(fstr) /= 3 .or. fstr /= "bcd") stop 5
+end
+end module
+
+use mod
+implicit none
+character(10,c_char), target :: str10
+character(1,c_char), target :: arr10(10)
+
+type(t) :: arg
+
+str10 = '1234567890'
+arr10 = ['a','b','c','d','e','f','g','h','i', 'j']
+
+arg%cptr = c_loc(str10)
+arg%carr = arr10
+call sub(arg, arr10)
+end
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-8.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-8.f90
new file mode 100644
index 00000000000..b8e8abe501f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-8.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Test that c_f_strpointer rejects assumed-rank array argument.
+
+subroutine sub(y)
+  use iso_c_binding
+  implicit none (type, external)
+  character, pointer, contiguous, intent(in) :: y(..)
+  character(:), pointer :: fstr
+
+  call c_f_strpointer (y, fstr, 10) ! { dg-error "Assumed-rank argument at .1. is only permitted as actual argument to intrinsic inquiry functions or to RESHAPE." }
+end
diff --git a/gcc/testsuite/gfortran.dg/c_f_strpointer-9.f90 b/gcc/testsuite/gfortran.dg/c_f_strpointer-9.f90
new file mode 100644
index 00000000000..0e7043253b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c_f_strpointer-9.f90
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! Test that problems with the fstrptr argument are diagnosed.
+
+program test
+
+  use iso_c_binding
+  implicit none
+
+  character (kind=c_char, len=1), dimension(15), target :: a
+  character (len=:, kind=c_char), pointer :: fp
+
+  a = [ character :: 'h', 'e', 'l', 'l', 'o', ' ', &
+                     'w', 'o', 'r', 'l', 'd', '!', &
+                     ' ', ' ', ' ']
+  a(13) = C_NULL_CHAR
+  call doit (a, 12, fp)
+
+contains
+
+subroutine doit (aa, n, fp1)
+  character (kind=c_char, len=1), dimension(*), target, intent(inout) :: aa
+  integer, intent(in) :: n
+  character (len=:, kind=c_char), pointer, intent(in) :: fp1
+  character (len=42, kind=c_char), pointer :: fp2
+  character (len=:, kind=c_char), allocatable :: fp3
+  type(c_ptr) :: p
+
+  p = C_LOC (aa(1))
+  call c_f_strpointer (p, fp1, n) ! { dg-error ".fstrptr. argument of .c_f_strpointer. intrinsic at .1. cannot be INTENT.IN." }
+  call c_f_strpointer (p, fp2, n) ! { dg-error ".fstrptr. argument of .c_f_strpointer. intrinsic at .1. shall be a scalar deferred-length character pointer of kind C_CHAR" }
+  call c_f_strpointer (p, fp3, n) ! { dg-error ".fstrptr. argument of .c_f_strpointer. intrinsic at .1. shall be a scalar deferred-length character pointer of kind C_CHAR" }
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/pr108961.f90 b/gcc/testsuite/gfortran.dg/pr108961.f90
index 3e6c9df48bb..30eb502cbc4 100644
--- a/gcc/testsuite/gfortran.dg/pr108961.f90
+++ b/gcc/testsuite/gfortran.dg/pr108961.f90
@@ -5,7 +5,7 @@
 module associate_ptr
     use iso_c_binding
 contains
-    subroutine c_f_strpointer(cptr, ptr2)
+    subroutine my_c_f_strpointer(cptr, ptr2)
         type(c_ptr), target, intent(in) :: cptr
         character(kind=c_char,len=4), pointer :: ptr1
         character(kind=c_char,len=:), pointer, intent(out) :: ptr2
@@ -21,6 +21,6 @@ program test_associate_ptr
     character(kind=c_char,len=:), pointer :: ptr2
     char_array = ['a', 'b', 'c', 'd', c_null_char, 'e', 'f']
 ! The first argument was providing a constant hidden string length => segfault
-    call c_f_strpointer(c_loc(char_array), ptr2)
+    call my_c_f_strpointer(c_loc(char_array), ptr2)
     if (ptr2 .ne. 'abcd') stop 2
 end program
-- 
2.39.5

From 656d97bbc4b0f4614f1f074ab3ca7c425fe569d2 Mon Sep 17 00:00:00 2001
From: Sandra Loosemore <[email protected]>
Date: Thu, 28 May 2026 22:33:33 +0000
Subject: [PATCH 2/2] 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.
---
 gcc/fortran/intrinsic.texi                |  59 +++-
 gcc/fortran/trans-intrinsic.cc            | 328 ++++++++++++----------
 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, 329 insertions(+), 157 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/f_c_string3.f90
 create mode 100644 gcc/testsuite/gfortran.dg/f_c_string4.f90
 create mode 100644 gcc/testsuite/gfortran.dg/f_c_string5.f90

diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 53014f47882..64309fd852c 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 a18a6436062..fdb9ddb52ea 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);
-
-	  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);
+	  need_trim = true;
+	  need_asis = false;
+	}
+      else if (asis->expr_type == EXPR_CONSTANT)
+	{
+	  need_asis = asis->value.logical;
+	  need_trim = !need_asis;
 	}
       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);
+	  /* 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)
+	    {
+	      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, logical_false_node);
+	    }
+	  gfc_make_safe_expr (&asis_se);
 	}
 
-      se->expr = var;
-      se->string_length = len;
+      /* 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;
 
-#undef cnode
+	  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);
+
+	  /* 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
+	/* 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);
+	    }
+
+	  /* 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);
+	  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);
+
+	  /* 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 00000000000..3e9d4a79d3b
--- /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 00000000000..d38e16f0268
--- /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 00000000000..25c5115f214
--- /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
-- 
2.39.5