Attached is the revised patch incorporating handling of optional
arguments of a calling procedure and simplified checking for C
interoperability.
See the PR for much discussion.
Regression tested on x86_64_linux_gnu.
Two test cases.
OK for trunk?
Author: Steven G. Kargl <kar...@comcast.net>
Date: Sun Dec 29 14:19:18 2024 -0800
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.
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index f4fde83e8ab..08cc88ba7cb 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 87307c5531e..a2c8ebc6b3e 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 a2e241280c3..d4db6abe7b4 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 61d85eedc69..640d1bc15eb 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 bad66b1dcbc..5ef4368222c 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 ab49eac450f..86c16afffa1 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 66da97bc6e3..edc4a8773b2 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 00000000000..00f319fba2e
--- /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 00000000000..11c19b2f9f7
--- /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
