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 | 82 ++++++++++
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, 697 insertions(+), 6 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..8a33fff68f9 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
@@ -3418,6 +3419,7 @@ 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_STRPOINTER}
@end table
@@ -3476,6 +3478,86 @@ Fortran 2003 and later
@item @emph{See also}:
@ref{C_LOC}, @*
@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
