[gcc/devel/omp/gcc-16] Fortran: Add c_f_strpointer intrinsic
Sandra Loosemore via Gcc-cvs <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:4ecedc0952b6c86a0a1c6c3fd88a247918c8486e commit 4ecedc0952b6c86a0a1c6c3fd88a247918c8486e Author: Sandra Loosemore <[email protected]> Date: Thu May 28 22:33:33 2026 +0000 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]> (cherry picked from commit a6b2fe7f54bffc4006bee4b20dd788c0a81a9e2e) Diff: --- 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 ++++++++++++++++++++ gcc/testsuite/gfortran.dg/c_f_strpointer-1.f90 | 30 +++++ gcc/testsuite/gfortran.dg/c_f_strpointer-10.f90 | 39 +++++++ gcc/testsuite/gfortran.dg/c_f_strpointer-2.f90 | 33 ++++++ gcc/testsuite/gfortran.dg/c_f_strpointer-3.f90 | 37 ++++++ gcc/testsuite/gfortran.dg/c_f_strpointer-4.f90 | 18 +++ gcc/testsuite/gfortran.dg/c_f_strpointer-5.f90 | 19 ++++ gcc/testsuite/gfortran.dg/c_f_strpointer-6.f90 | 20 ++++ gcc/testsuite/gfortran.dg/c_f_strpointer-7.f90 | 50 +++++++++ gcc/testsuite/gfortran.dg/c_f_strpointer-8.f90 | 11 ++ gcc/testsuite/gfortran.dg/c_f_strpointer-9.f90 | 34 ++++++ gcc/testsuite/gfortran.dg/pr108961.f90 | 4 +- 20 files changed, 699 insertions(+), 8 deletions(-) diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index c4d9901a82d2..ad6f66015d72 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 45aab34865f3..1cdc83500a93 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 318856c81b84..e02073f76869 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -500,6 +500,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 16553508a58b..716e58cf1b3f 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 6ffd7237468e..1c97af087d52 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 0b520f033322..ad0c54f29593 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 f5a29606eb49..53014f478820 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 c7a672292738..041fcb2ff52d 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 9bb39597f40a..bfa8d3163de1 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -10273,6 +10273,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 @@ -13540,6 +13656,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 000000000000..cbdfd84f6a56 --- /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 000000000000..ac18336d2401 --- /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 000000000000..b4a44db68c5d --- /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 000000000000..958145a35859 --- /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 000000000000..e6268172f98f --- /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 000000000000..d9de7bf830b9 --- /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 000000000000..a90526af2848 --- /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 000000000000..b9531fc4c093 --- /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 000000000000..b8e8abe501f6 --- /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 000000000000..0e7043253b0d --- /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 3e6c9df48bb5..30eb502cbc48 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