Fortran: Implement f_c_string function.

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

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

	PR fortran/117643

gcc/fortran/ChangeLog:

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

gcc/testsuite/ChangeLog:

	* gfortran.dg/f_c_string1.f90: New test.
	* gfortran.dg/f_c_string2.f90: New test.

9 files changed, 329 insertions, 9 deletions

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f4fde83..08cc88b 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -1829,6 +1829,42 @@ gfc_check_image_status (gfc_expr *image, gfc_expr *team)
 }
 
 
+/* Check the arguments for f_c_string.  */
+
+bool
+gfc_check_f_c_string (gfc_expr *string, gfc_expr *asis)
+{
+
+  if (gfc_invalid_null_arg (string))
+    return false;
+
+  if (!scalar_check (string, 0))
+    return false;
+
+  if (string->ts.type != BT_CHARACTER
+      || (string->ts.type == BT_CHARACTER
+	  && (string->ts.kind != gfc_default_character_kind)))
+    {
+      gfc_error ("%qs argument of %qs intrinsic at %L shall have "
+		 "a type of CHARACTER(KIND=C_CHAR)",
+		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
+		 &string->where);
+      return false;
+    }
+
+  if (asis)
+    {
+      if (!type_check (asis, 1, BT_LOGICAL))
+	return false;
+
+      if (!scalar_check (asis, 1))
+	return false;
+    }
+
+  return true;
+}
+
+
 bool
 gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
 {
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 87307c5..a2c8ebc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -508,6 +508,7 @@ enum gfc_isym_id
   GFC_ISYM_EXP,
   GFC_ISYM_EXPONENT,
   GFC_ISYM_EXTENDS_TYPE_OF,
+  GFC_ISYM_F_C_STRING,
   GFC_ISYM_FAILED_IMAGES,
   GFC_ISYM_FDATE,
   GFC_ISYM_FE_RUNTIME_ERROR,
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index a2e2412..d4db6ab 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3145,6 +3145,14 @@ add_functions (void)
 	     x, BT_UNKNOWN, 0, REQUIRED);
   make_from_module();
 
+  add_sym_2 ("f_c_string", GFC_ISYM_F_C_STRING, CLASS_TRANSFORMATIONAL,
+	     ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F2023,
+	     gfc_check_f_c_string, NULL, NULL,
+	     stg, BT_CHARACTER, dc, REQUIRED,
+	     "asis", BT_CHARACTER, dc, OPTIONAL);
+  make_from_module();
+
   add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
 	     BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
 	     gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
@@ -3301,7 +3309,8 @@ add_functions (void)
 
   make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
 
-  add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
+  add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
+	     BT_CHARACTER, dc, GFC_STD_F95,
 	     gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
 	     stg, BT_CHARACTER, dc, REQUIRED);
 
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 61d85ee..640d1bc 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_dtime_etime (gfc_expr *);
 bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_f_c_string (gfc_expr *, gfc_expr *);
 bool gfc_check_failed_or_stopped_images (gfc_expr *, gfc_expr *);
 bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
 bool gfc_check_fgetput (gfc_expr *);
diff --git a/gcc/fortran/iso-c-binding.def b/gcc/fortran/iso-c-binding.def
index bad66b1..5ef4368 100644
--- a/gcc/fortran/iso-c-binding.def
+++ b/gcc/fortran/iso-c-binding.def
@@ -256,6 +256,9 @@ NAMED_FUNCTION (ISOCBINDING_LOC, "c_loc",
 NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
                 GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
 
+NAMED_FUNCTION (ISOCBINDING_F_C_STRING, "f_c_string", \
+                GFC_ISYM_F_C_STRING, GFC_STD_F2023)
+
 #undef NAMED_INTCST
 #undef NAMED_UINTCST
 #undef NAMED_REALCST
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index ab49eac..86c16af 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -4039,12 +4039,11 @@ gfc_match_rvalue (gfc_expr **result)
 	}
 
       /* Check here for the existence of at least one argument for the
-         iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
-         argument(s) given will be checked in gfc_iso_c_func_interface,
-         during resolution of the function call.  */
+	 iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  */
       if (sym->attr.is_iso_c == 1
 	  && (sym->from_intmod == INTMOD_ISO_C_BINDING
 	      && (sym->intmod_sym_id == ISOCBINDING_LOC
+		  || sym->intmod_sym_id == ISOCBINDING_F_C_STRING
 		  || sym->intmod_sym_id == ISOCBINDING_FUNLOC
 		  || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
         {
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 66da97b..edc4a87 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10024,11 +10024,39 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
 }
 
 
-/* The following routine generates code for the intrinsic
-   functions from the ISO_C_BINDING module:
-    * C_LOC
-    * C_FUNLOC
-    * C_ASSOCIATED  */
+/* Specialized trim for f_c_string.  */
+
+static void
+conv_trim (gfc_se *tse, gfc_se *str)
+{
+  tree cond, plen, pvar, tlen, ttmp, tvar;
+
+  tlen = gfc_create_var (gfc_charlen_type_node, "tlen");
+  plen = gfc_build_addr_expr (NULL_TREE, tlen);
+
+  tvar = gfc_create_var (pchar_type_node, "tstr");
+  pvar = gfc_build_addr_expr (ppvoid_type_node, tvar);
+
+  ttmp = build_call_expr_loc (input_location, gfor_fndecl_string_trim, 4,
+			      plen, pvar, str->string_length, str->expr);
+
+  gfc_add_expr_to_block (&tse->pre, ttmp);
+
+  /* Free the temporary afterwards, if necessary.  */
+  cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
+			  tlen, build_int_cst (TREE_TYPE (tlen), 0));
+  ttmp = gfc_call_free (tvar);
+  ttmp = build3_v (COND_EXPR, cond, ttmp, build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&tse->post, ttmp);
+
+  tse->expr = tvar;
+  tse->string_length = tlen;
+}
+
+
+/* The following routine generates code for the intrinsic functions from
+   the ISO_C_BINDING module: C_LOC, C_FUNLOC, C_ASSOCIATED, and
+   F_C_STRING.  */
 
 static void
 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
@@ -10103,6 +10131,149 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
 				      not_null_expr, eq_expr);
 	}
     }
+  else if (expr->value.function.isym->id == GFC_ISYM_F_C_STRING)
+    {
+      /* There are three cases:
+	 f_c_string(string)          -> trim(string) // c_null_char
+	 f_c_string(string, .false.) -> trim(string) // c_null_char
+	 f_c_string(string, .true.)  -> string       // c_null_char  */
+
+      gfc_se lse, rse, tse;
+      tree len, tmp, var;
+      gfc_expr *string = arg->expr;
+      gfc_expr *asis = arg->next->expr;
+      gfc_expr *cnc;
+
+      /* Convert string. */
+      gfc_init_se (&lse, se);
+      gfc_conv_expr (&lse, string);
+      gfc_conv_string_parameter (&lse);
+
+      /* Create a string for C_NULL_CHAR and convert it.  */
+      cnc = gfc_get_character_expr (gfc_default_character_kind,
+				    &string->where, "\0", 1);
+      gfc_init_se (&rse, se);
+      gfc_conv_expr (&rse, cnc);
+      gfc_conv_string_parameter (&rse);
+      gfc_free_expr (cnc);
+
+#ifdef cnode
+#undef cnode
+#endif
+#define cnode gfc_charlen_type_node
+      if (asis)
+	{
+	  stmtblock_t block;
+	  gfc_se asis_se, vse;
+	  tree elen, evar, tlen, tvar;
+	  tree else_branch, then_branch;
+
+	  elen = evar = tlen = tvar = NULL_TREE;
+
+	  /* f_c_string(string, .true.) -> string // c_null_char  */
+
+	  gfc_init_block (&block);
+
+	  gfc_add_block_to_block (&block, &lse.pre);
+	  gfc_add_block_to_block (&block, &rse.pre);
+
+	  tlen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
+				  fold_convert (cnode, lse.string_length),
+				  fold_convert (cnode, rse.string_length));
+
+	  gfc_init_se (&vse, se);
+	  tvar = gfc_conv_string_tmp (&vse, pchar_type_node, tlen);
+	  gfc_add_block_to_block (&block, &vse.pre);
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
+				     6, tlen, tvar,
+				     lse.string_length, lse.expr,
+				     rse.string_length, rse.expr);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  then_branch = gfc_finish_block (&block);
+
+	  /* f_c_string(string, .false.) = trim(string) // c_null_char  */
+
+	  gfc_init_block (&block);
+
+	  gfc_init_se (&tse, se);
+	  conv_trim (&tse, &lse);
+	  gfc_add_block_to_block (&block, &tse.pre);
+	  gfc_add_block_to_block (&block, &rse.pre);
+
+	  elen = fold_build2_loc (input_location, PLUS_EXPR, cnode,
+				  fold_convert (cnode, tse.string_length),
+				  fold_convert (cnode, rse.string_length));
+
+	  gfc_init_se (&vse, se);
+	  evar = gfc_conv_string_tmp (&vse, pchar_type_node, elen);
+	  gfc_add_block_to_block (&block, &vse.pre);
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
+				     6, elen, evar,
+				     tse.string_length, tse.expr,
+				     rse.string_length, rse.expr);
+	  gfc_add_expr_to_block (&block, tmp);
+
+	  else_branch = gfc_finish_block (&block);
+
+	  gfc_init_se (&asis_se, se);
+	  gfc_conv_expr (&asis_se, asis);
+	  if (asis->expr_type == EXPR_VARIABLE
+	    && asis->symtree->n.sym->attr.dummy
+	    && asis->symtree->n.sym->attr.optional)
+	    {
+	      tree present = gfc_conv_expr_present (asis->symtree->n.sym);
+	      asis_se.expr = build3_loc (input_location, COND_EXPR,
+					 logical_type_node, present,
+					 asis_se.expr,
+					 build_int_cst (logical_type_node, 0));
+	    }
+	  gfc_add_block_to_block (&se->pre, &asis_se.pre);
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 asis_se.expr, then_branch, else_branch);
+
+	  gfc_add_expr_to_block (&se->pre, tmp);
+
+	  var = fold_build3_loc (input_location, COND_EXPR, pchar_type_node,
+				 asis_se.expr, tvar, evar);
+	  gfc_add_expr_to_block (&se->pre, var);
+
+	  len = fold_build3_loc (input_location, COND_EXPR, cnode,
+				 asis_se.expr, tlen, elen);
+	  gfc_add_expr_to_block (&se->pre, len);
+	}
+      else
+	{
+	  /* f_c_string(string) = trim(string) // c_null_char  */
+
+	  gfc_add_block_to_block (&se->pre, &lse.pre);
+	  gfc_add_block_to_block (&se->pre, &rse.pre);
+
+	  gfc_init_se (&tse, se);
+	  conv_trim (&tse, &lse);
+	  gfc_add_block_to_block (&se->pre, &tse.pre);
+	  gfc_add_block_to_block (&se->post, &tse.post);
+
+	  len = fold_build2_loc (input_location, PLUS_EXPR, cnode,
+				 fold_convert (cnode, tse.string_length),
+				 fold_convert (cnode, rse.string_length));
+
+	  var = gfc_conv_string_tmp (se, pchar_type_node, len);
+
+	  tmp = build_call_expr_loc (input_location, gfor_fndecl_concat_string,
+				     6, len, var,
+				     tse.string_length, tse.expr,
+				     rse.string_length, rse.expr);
+	  gfc_add_expr_to_block (&se->pre, tmp);
+	}
+
+      se->expr = var;
+      se->string_length = len;
+
+#undef cnode
+    }
   else
     gcc_unreachable ();
 }
@@ -11243,6 +11414,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
     case GFC_ISYM_C_ASSOCIATED:
     case GFC_ISYM_C_FUNLOC:
     case GFC_ISYM_C_LOC:
+    case GFC_ISYM_F_C_STRING:
       conv_isocbinding_function (se, expr);
       break;
 
diff --git a/gcc/testsuite/gfortran.dg/f_c_string1.f90 b/gcc/testsuite/gfortran.dg/f_c_string1.f90
new file mode 100644
index 0000000..00f319f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f_c_string1.f90
@@ -0,0 +1,49 @@
+!
+! { dg-do run }
+!
+! PR117643 F_C_STRING from F23 is missing.
+! Test case and initial patch provided by Steve Kargl.
+program foo
+
+   use iso_c_binding, only : c_null_char, c_char, f_c_string, c_size_t
+
+   implicit none
+
+   logical asis
+   character(len=6, kind=c_char) :: s1
+   character(len=:, kind=c_char), allocatable :: s2
+
+   interface
+      !
+      ! strlen() counts up to '\0', and excludes it from the count
+      !
+      function strlen(s) bind(c,name="strlen")
+         import c_char, c_size_t
+         integer(c_size_t) strlen
+         character(len=1,kind=c_char), intent(in) :: s(*)
+      end function strlen
+   end interface
+
+   s1 = 'abc   '
+   s2 = f_c_string(s1)
+   if (len_trim(s1) /= int(strlen(s2), 4)) stop 1
+
+   s1 = ' ghij '
+   s2 = f_c_string(s1)
+   if (len_trim(s1) /= int(strlen(s2), 4)) stop 2
+
+   s2 = f_c_string(s1, .true.)
+   if (len(s1) /= int(strlen(s2), 4)) stop 3
+
+   s2 = f_c_string(s1, .false.)
+   if (len_trim(s1) /= int(strlen(s2), 4)) stop 4
+
+   asis = .true.
+   s2 = f_c_string(s1, asis)
+   if (len(s1) /= int(strlen(s2), 4)) stop 5
+
+   asis = .false.
+   s2 = f_c_string(s1, asis)
+   if (len_trim(s1) /= int(strlen(s2), 4)) stop 6
+
+end program foo
diff --git a/gcc/testsuite/gfortran.dg/f_c_string2.f90 b/gcc/testsuite/gfortran.dg/f_c_string2.f90
new file mode 100644
index 0000000..11c19b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/f_c_string2.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+! See pr117643, this tests passing of the optional argument when it is
+! not present. 
+
+program foo
+   use iso_c_binding, only : c_null_char, c_char, f_c_string, c_size_t
+   implicit none
+
+   logical asis
+   character(len=6, kind=c_char) :: s1
+   character(len=:, kind=c_char), allocatable :: s2
+
+   interface
+      !
+      ! strlen() counts up to '\0', and excludes it from the count
+      !
+      function strlen(s) bind(c,name="strlen")
+         import c_char, c_size_t
+         integer(c_size_t) strlen
+         character(len=1,kind=c_char), intent(in) :: s(*)
+      end function strlen
+   end interface
+
+   s1 = 'abc   '
+   asis = .true.
+   call check (asis) ! OK
+   asis = .false.
+   call check (asis) ! OK
+   call check ()     ! segfault fixed
+
+ contains
+
+  subroutine check (asis)
+    logical, optional, intent(in) :: asis
+  
+    s2 = f_c_string(s1, asis)
+    if (present(asis)) then
+      if (asis) then
+        if (int(strlen(s2)) /= 6) then
+          stop 1
+        endif
+      else
+        if (len_trim(s1) /= int(strlen(s2))) then
+          stop 2
+        endif
+      endif
+    endif
+  end subroutine check
+
+end program foo