aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog25
-rw-r--r--gcc/fortran/check.cc21
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/intrinsic.cc8
-rw-r--r--gcc/fortran/intrinsic.h2
-rw-r--r--gcc/fortran/intrinsic.texi64
-rw-r--r--gcc/fortran/iresolve.cc13
-rw-r--r--gcc/fortran/trans-array.cc12
-rw-r--r--gcc/fortran/trans-array.h5
-rw-r--r--gcc/fortran/trans-decl.cc14
-rw-r--r--gcc/fortran/trans-intrinsic.cc72
-rw-r--r--gcc/fortran/trans-stmt.cc7
-rw-r--r--gcc/fortran/trans.h2
13 files changed, 232 insertions, 15 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 52bd14c..70b93dd 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,28 @@
+2025-07-30 Mikael Morin <morin-mikael@orange.fr>
+
+ * trans-array.cc (gfc_array_init_size): Remove the nelems
+ argument.
+ (gfc_array_allocate): Update caller. Remove the nelems
+ argument.
+ * trans-stmt.cc (gfc_trans_allocate): Update caller. Remove the
+ nelems variable.
+ * trans-array.h (gfc_array_allocate): Update prototype.
+
+2025-07-30 Yuao Ma <c8ef@outlook.com>
+
+ * check.cc (gfc_check_split): Argument check for SPLIT.
+ * gfortran.h (enum gfc_isym_id): Define GFC_ISYM_SPLIT.
+ * intrinsic.cc (add_subroutines): Register SPLIT intrinsic.
+ * intrinsic.h (gfc_check_split): New decl.
+ (gfc_resolve_split): Ditto.
+ * intrinsic.texi: SPLIT documentation.
+ * iresolve.cc (gfc_resolve_split): Add resolved_sym for SPLIT.
+ * trans-decl.cc (gfc_build_intrinsic_function_decls): Add decl for
+ SPLIT in libgfortran.
+ * trans-intrinsic.cc (conv_intrinsic_split): SPLIT codegen.
+ (gfc_conv_intrinsic_subroutine): Handle SPLIT case.
+ * trans.h (GTY): Declare gfor_fndecl_string_split{, _char4}.
+
2025-07-27 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/121185
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 838d523..8626526 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5559,6 +5559,27 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
return true;
}
+bool
+gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back)
+{
+ if (!type_check (string, 0, BT_CHARACTER))
+ return false;
+
+ if (!type_check (set, 1, BT_CHARACTER))
+ return false;
+
+ if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2))
+ return false;
+
+ if (back != NULL
+ && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3)))
+ return false;
+
+ if (!same_type_check (string, 0, set, 1))
+ return false;
+
+ return true;
+}
bool
gfc_check_secnds (gfc_expr *r)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 85feb18..d9dcd1b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -729,6 +729,8 @@ enum gfc_isym_id
GFC_ISYM_COSPI,
GFC_ISYM_SINPI,
GFC_ISYM_TANPI,
+
+ GFC_ISYM_SPLIT,
};
enum init_local_logical
diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc
index 9e07627..c99a7a8 100644
--- a/gcc/fortran/intrinsic.cc
+++ b/gcc/fortran/intrinsic.cc
@@ -3933,6 +3933,14 @@ add_subroutines (void)
pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+ add_sym_4s ("split", GFC_ISYM_SPLIT, CLASS_PURE,
+ BT_UNKNOWN, 0, GFC_STD_F2023,
+ gfc_check_split, NULL, gfc_resolve_split,
+ "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ "set", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
+ "pos", BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+ "back", BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
+
/* The following subroutines are part of ISO_C_BINDING. */
add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fd54588..8a0ab93 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -215,6 +215,7 @@ bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
bool gfc_check_random_init (gfc_expr *, gfc_expr *);
bool gfc_check_random_number (gfc_expr *);
bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_split (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
@@ -693,6 +694,7 @@ void gfc_resolve_link_sub (gfc_code *);
void gfc_resolve_symlnk_sub (gfc_code *);
void gfc_resolve_signal_sub (gfc_code *);
void gfc_resolve_sleep_sub (gfc_code *);
+void gfc_resolve_split (gfc_code *);
void gfc_resolve_stat_sub (gfc_code *);
void gfc_resolve_system_clock (gfc_code *);
void gfc_resolve_system_sub (gfc_code *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 3103da3..a24b234 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -313,6 +313,7 @@ Some basic guidelines for editing this document:
* @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression
* @code{SLEEP}: SLEEP, Sleep for the specified number of seconds
* @code{SPACING}: SPACING, Smallest distance between two numbers of a given type
+* @code{SPLIT}: SPLIT, Parse a string into tokens, one at a time.
* @code{SPREAD}: SPREAD, Add a dimension to an array
* @code{SQRT}: SQRT, Square-root function
* @code{SRAND}: SRAND, Reinitialize the random number generator
@@ -14203,6 +14204,69 @@ Fortran 90 and later
+@node SPLIT
+@section @code{SPLIT} --- Parse a string into tokens, one at a time
+@fnindex SPLIT
+@cindex string, split
+
+@table @asis
+@item @emph{Synopsis}:
+@code{RESULT = SPLIT(STRING, SET, POS [, BACK])}
+
+@item @emph{Description}:
+Updates the integer @var{POS} to the position of the next (or previous)
+separator in @var{STRING}.
+
+If @var{BACK} is absent or is present with the value false, @var{POS} is
+assigned the position of the leftmost token delimiter in @var{STRING} whose
+position is greater than @var{POS}, or if there is no such character, it is
+assigned a value one greater than the length of @var{STRING}. This identifies
+a token with starting position one greater than the value of @var{POS} on
+invocation, and ending position one less than the value of @var{POS} on return.
+
+If @var{BACK} is present with the value true, @var{POS} is assigned the
+position of the rightmost token delimiter in @var{STRING} whose position is
+less than @var{POS}, or if there is no such character, it is assigned the value
+zero. This identifies a token with ending position one less than the value of
+@var{POS} on invocation, and starting position one greater than the value of
+@var{POS} on return.
+
+@item @emph{Class}:
+Subroutine
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{STRING} @tab Shall be of type @code{CHARACTER}.
+@item @var{SET} @tab Shall be of type @code{CHARACTER}.
+@item @var{POS} @tab Shall be of type @code{INTEGER}.
+@item @var{BACK} @tab (Optional) Shall be of type @code{LOGICAL}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+character(len=:), allocatable :: input
+character(len=2) :: set = ', '
+integer :: p
+input = "one,last example"
+p = 0
+do
+ if (p > len(input)) exit
+ istart = p + 1
+ call split(input, set, p)
+ iend = p - 1
+ print '(t7, a)', input(istart:iend)
+end do
+@end smallexample
+
+@item @emph{Standard}:
+Fortran 2023
+
+@item @emph{See also}:
+@ref{SCAN}
+@end table
+
+
+
@node SPREAD
@section @code{SPREAD} --- Add a dimension to an array
@fnindex SPREAD
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 1001309..da354ab 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3863,6 +3863,19 @@ gfc_resolve_sleep_sub (gfc_code *c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+void
+gfc_resolve_split (gfc_code *c)
+{
+ const char *name;
+ gfc_expr *string;
+
+ string = c->ext.actual->expr;
+ if (string->ts.type == BT_CHARACTER && string->ts.kind == 4)
+ name = "__split_char4";
+ else
+ name = "__split";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
/* G77 compatibility function srand(). */
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6b759d1..0f7637d 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6296,8 +6296,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
- tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr,
+ tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc,
+ bool e3_has_nodescriptor, gfc_expr *expr,
tree *element_size, bool explicit_ts)
{
tree type;
@@ -6573,7 +6573,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
if (rank == 0)
return *element_size;
- *nelems = gfc_evaluate_now (stride, pblock);
stride = fold_convert (size_type_node, stride);
/* First check for overflow. Since an array of type character can
@@ -6662,9 +6661,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in)
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3, tree e3_arr_desc,
- bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc,
- bool explicit_ts)
+ gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor,
+ gfc_omp_namelist *omp_alloc, bool explicit_ts)
{
tree tmp;
tree pointer;
@@ -6795,7 +6793,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
coarray ? ref->u.ar.as->corank : 0,
&offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3, e3_arr_desc,
+ expr3_elem_size, expr3, e3_arr_desc,
e3_has_nodescriptor, expr, &element_size,
explicit_ts);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294..29098fd 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -20,9 +20,8 @@ along with GCC; see the file COPYING3. If not see
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
-bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *, tree, bool,
- gfc_omp_namelist *, bool);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, tree,
+ gfc_expr *, tree, bool, gfc_omp_namelist *, bool);
/* Allow the bounds of a loop to be set from a callee's array spec. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index d5acdca..741acc0 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -197,6 +197,7 @@ tree gfor_fndecl_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
tree gfor_fndecl_string_minmax;
+tree gfor_fndecl_string_split;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
tree gfor_fndecl_select_string;
@@ -208,6 +209,7 @@ tree gfor_fndecl_string_scan_char4;
tree gfor_fndecl_string_verify_char4;
tree gfor_fndecl_string_trim_char4;
tree gfor_fndecl_string_minmax_char4;
+tree gfor_fndecl_string_split_char4;
tree gfor_fndecl_adjustl_char4;
tree gfor_fndecl_adjustr_char4;
tree gfor_fndecl_select_string_char4;
@@ -3569,6 +3571,12 @@ gfc_build_intrinsic_function_decls (void)
build_pointer_type (pchar1_type_node), integer_type_node,
integer_type_node);
+ gfor_fndecl_string_split = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("string_split")), ". . R . R . . ",
+ gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node,
+ gfc_logical4_type_node);
+
gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustl")), ". W . R ",
void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
@@ -3641,6 +3649,12 @@ gfc_build_intrinsic_function_decls (void)
build_pointer_type (pchar4_type_node), integer_type_node,
integer_type_node);
+ gfor_fndecl_string_split_char4 = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX ("string_split_char4")), ". . R . R . . ",
+ gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
+ gfc_logical4_type_node);
+
gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustl_char4")), ". W . R ",
void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index be98427..f68ceb1 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3466,6 +3466,74 @@ else
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_split (gfc_code *code)
+{
+ stmtblock_t block, post_block;
+ gfc_se se;
+ gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
+ tree string, string_len;
+ tree set, set_len;
+ tree pos, pos_for_call;
+ tree back;
+ tree fndecl, call;
+
+ string_expr = code->ext.actual->expr;
+ set_expr = code->ext.actual->next->expr;
+ pos_expr = code->ext.actual->next->next->expr;
+ back_expr = code->ext.actual->next->next->next->expr;
+
+ gfc_start_block (&block);
+ gfc_init_block (&post_block);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, string_expr);
+ gfc_conv_string_parameter (&se);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post_block, &se.post);
+ string = se.expr;
+ string_len = se.string_length;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, set_expr);
+ gfc_conv_string_parameter (&se);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post_block, &se.post);
+ set = se.expr;
+ set_len = se.string_length;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, pos_expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post_block, &se.post);
+ pos = se.expr;
+ pos_for_call = fold_convert (gfc_charlen_type_node, pos);
+
+ if (back_expr)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, back_expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post_block, &se.post);
+ back = se.expr;
+ }
+ else
+ back = logical_false_node;
+
+ if (string_expr->ts.kind == 1)
+ fndecl = gfor_fndecl_string_split;
+ else if (string_expr->ts.kind == 4)
+ fndecl = gfor_fndecl_string_split_char4;
+ else
+ gcc_unreachable ();
+
+ call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
+ set_len, set, pos_for_call, back);
+ gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call));
+
+ gfc_add_block_to_block (&block, &post_block);
+ return gfc_finish_block (&block);
+}
/* Return a character string containing the tty name. */
@@ -13261,6 +13329,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_system_clock (code);
break;
+ case GFC_ISYM_SPLIT:
+ res = conv_intrinsic_split (code);
+ break;
+
default:
res = NULL_TREE;
break;
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f105401..b4ddf75 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -6710,7 +6710,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
stmtblock_t block;
stmtblock_t post;
stmtblock_t final_block;
- tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
bool needs_caf_sync, caf_refs_comp;
bool e3_has_nodescriptor = false;
@@ -7242,7 +7241,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
to handle the complete array allocation. Only the element size
needs to be provided, which is done most of the time by the
pre-evaluation step. */
- nelems = NULL_TREE;
if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
|| code->expr3->ts.type == BT_CLASS))
{
@@ -7313,9 +7311,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
}
- if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems,
- e3rhs ? e3rhs : code->expr3,
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
+ tmp, e3rhs ? e3rhs : code->expr3,
e3_is == E3_DESC ? expr3 : NULL_TREE,
e3_has_nodescriptor, omp_alloc_item,
code->ext.alloc.ts.type != BT_UNKNOWN))
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 461b0cd..40680e9 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -961,6 +961,7 @@ extern GTY(()) tree gfor_fndecl_string_scan;
extern GTY(()) tree gfor_fndecl_string_verify;
extern GTY(()) tree gfor_fndecl_string_trim;
extern GTY(()) tree gfor_fndecl_string_minmax;
+extern GTY(()) tree gfor_fndecl_string_split;
extern GTY(()) tree gfor_fndecl_adjustl;
extern GTY(()) tree gfor_fndecl_adjustr;
extern GTY(()) tree gfor_fndecl_select_string;
@@ -972,6 +973,7 @@ extern GTY(()) tree gfor_fndecl_string_scan_char4;
extern GTY(()) tree gfor_fndecl_string_verify_char4;
extern GTY(()) tree gfor_fndecl_string_trim_char4;
extern GTY(()) tree gfor_fndecl_string_minmax_char4;
+extern GTY(()) tree gfor_fndecl_string_split_char4;
extern GTY(()) tree gfor_fndecl_adjustl_char4;
extern GTY(()) tree gfor_fndecl_adjustr_char4;
extern GTY(()) tree gfor_fndecl_select_string_char4;
generated by cgit v1.1 at 2025-07-31 21:37:01 +0000