Hi Mikael,
On 7/17/2025 3:47 PM, Mikael Morin wrote:
How did you declare gfor_fndecl_string_split?
More exactly what is the declaration type for the POS argument?
For the POS argument type, I'm using
build_pointer_type(gfc_charlen_type_node). I got this from
string_minmax, but I'm unsure if it's the right fit here.
Also, I'm encountering an issue with pointer declarations. I've found
two methods: gfc_build_addr_expr and se.want_pointer. Are these the
same, or do they have different uses? I've tried both, and they give me
the same errors in my tests.
I've attached a minimal patch below that reproduces the issue, even
though it's incomplete. Hopefully, this helps with troubleshooting.
Thanks,
Yuao
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 838d523f7c4..be323639e52 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -5560,6 +5560,25 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z,
gfc_expr *kind)
}
+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))
+ 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 4c85548bc30..7233ea277ca 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 9e07627503d..0ed2bd078bf 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_IMPURE,
+ 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 fd54588054f..8a0ab935e1f 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/iresolve.cc b/gcc/fortran/iresolve.cc
index 10013096c70..1968bb8a325 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -3864,6 +3864,18 @@ gfc_resolve_sleep_sub (gfc_code *c)
}
+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(). */
void
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 43bd7be54cb..e0475ab3859 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,11 @@ 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 . . ",
+ void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node, build_pointer_type
(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 +3648,11 @@ 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 . . ",
+ void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node, build_pointer_type
(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 be984271d6a..2d259d7fbaf 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3466,6 +3466,48 @@ else
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_split (gfc_code *code) {
+ stmtblock_t block;
+ gfc_se se;
+ tree stringlen, string;
+ tree setlen, set;
+ tree pos, back;
+ tree tmp;
+
+
+ gfc_start_block (&block);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr(&se, code->ext.actual->expr);
+ gfc_conv_string_parameter(&se);
+ stringlen = se.string_length;
+ gfc_add_block_to_block(&block, &se.pre);
+ gfc_add_block_to_block(&block, &se.post);
+ string = se.expr;
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr(&se, code->ext.actual->next->expr);
+ gfc_conv_string_parameter(&se);
+ setlen = se.string_length;
+ gfc_add_block_to_block(&block, &se.pre);
+ gfc_add_block_to_block(&block, &se.post);
+ set = se.expr;
+
+ gfc_init_se (&se, NULL);
+
+ gfc_conv_expr(&se, code->ext.actual->next->next->expr);
+ gfc_add_block_to_block(&block, &se.pre);
+ gfc_add_block_to_block(&block, &se.post);
+ pos = se.expr;
+ pos = gfc_build_addr_expr(NULL_TREE, pos);
+
+ back = build_int_cst (gfc_get_logical_type (4), 0);
+
+ tmp = build_call_expr_loc (input_location, gfor_fndecl_string_split, 6,
stringlen, string, setlen, set, pos, back);
+ gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+}
/* Return a character string containing the tty name. */
@@ -13261,6 +13303,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.h b/gcc/fortran/trans.h
index 461b0cdac71..40680e97cbc 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;
diff --git a/gcc/testsuite/gfortran.dg/split_1.f90
b/gcc/testsuite/gfortran.dg/split_1.f90
new file mode 100644
index 00000000000..8f381a9e995
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/split_1.f90
@@ -0,0 +1,12 @@
+! { dg-do run }
+program b
+ CHARACTER (LEN=:), ALLOCATABLE :: INPUT
+ CHARACTER (LEN=2) :: SET = ', '
+ INTEGER P
+ INPUT = "one,last example"
+ P = 4
+ ISTART = P + 1
+ CALL SPLIT (INPUT, SET, P)
+ IEND = P - 1
+ PRINT '(T7,A)', INPUT (ISTART:IEND)
+end program b
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 742dddfe559..0eb2cf6936e 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -1262,6 +1262,8 @@ GFORTRAN_8 {
_gfortran_string_minmax_char4;
_gfortran_string_scan;
_gfortran_string_scan_char4;
+ _gfortran_string_split;
+ _gfortran_string_split_char4;
_gfortran_string_trim;
_gfortran_string_trim_char4;
_gfortran_string_verify;
diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c
b/libgfortran/intrinsics/string_intrinsics_inc.c
index d86bb6c8833..0c2f326990d 100644
--- a/libgfortran/intrinsics/string_intrinsics_inc.c
+++ b/libgfortran/intrinsics/string_intrinsics_inc.c
@@ -33,6 +33,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If
not, see
#define string_verify SUFFIX(string_verify)
#define string_trim SUFFIX(string_trim)
#define string_minmax SUFFIX(string_minmax)
+#define string_split SUFFIX(string_split)
#define zero_length_string SUFFIX(zero_length_string)
#define compare_string SUFFIX(compare_string)
@@ -72,6 +73,9 @@ export_proto(string_trim);
extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
export_proto(string_minmax);
+extern void string_split (gfc_charlen_type, const CHARTYPE *, gfc_charlen_type,
+ const CHARTYPE *, gfc_charlen_type *, GFC_LOGICAL_4);
+export_proto (string_split);
/* Use for functions which can return a zero-length string. */
static CHARTYPE zero_length_string = 0;
@@ -459,3 +463,73 @@ string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest,
int op, int nargs, ...)
*dest = tmp;
}
}
+
+void
+string_split (gfc_charlen_type stringlen, const CHARTYPE *string,
+ gfc_charlen_type setlen, const CHARTYPE *set,
+ gfc_charlen_type *pos, GFC_LOGICAL_4 back)
+{
+ // *pos = 4;
+ gfc_charlen_type i, j;
+
+ if (!back)
+ {
+ if (*pos < 0 || *pos > stringlen)
+ runtime_error ("If BACK is present with the value false, the value of "
+ "POS shall be in the range [0, LEN (STRING)=%llu],
*pos=%llu", stringlen, *pos);
+
+ if (stringlen == 0 || setlen == 0)
+ {
+ *pos = stringlen + 1;
+ return;
+ }
+
+ for (i = *pos + 1; i < stringlen; i++)
+ {
+ for (j = 0; j < setlen; j++)
+ {
+ if (string[i] == set[j])
+ {
+ *pos = i + 1;
+ return;
+ }
+ }
+ }
+
+ if (i == stringlen && j == setlen)
+ {
+ *pos = stringlen + 1;
+ return;
+ }
+ }
+ else
+ {
+ if (*pos < 1 || *pos > (stringlen + 1))
+ runtime_error ("If BACK is present with the value true, the value of "
+ "POS shall be in the range [1, LEN (STRING) + 1]");
+
+ if (stringlen == 0 || setlen == 0)
+ {
+ *pos = 0;
+ return;
+ }
+
+ for (i = *pos; i != 0; i--)
+ {
+ for (j = 0; j < setlen; j++)
+ {
+ if (string[i - 1] == set[j])
+ {
+ *pos = i;
+ return;
+ }
+ }
+ }
+
+ if (i == 0 && j == setlen)
+ {
+ *pos = 0;
+ return;
+ }
+ }
+}
