Hello,
here are a few more comments on the patch below.
It's not ready yet, but the remarks should be easily addressed.
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index be984271d6a..c2a91c93d28 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3466,6 +3466,73 @@ else
return gfc_finish_block (&block);
}
+static tree
+conv_intrinsic_split (gfc_code *code)
+{
+ stmtblock_t block;
+ gfc_se se;
+ tree string, string_len;
+ tree set, set_len;
+ tree pos, pos_for_call;
+ tree back;
+ tree fndecl, call;
+ gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr;
+
+ 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_se (&se, NULL);
+ gfc_conv_expr (&se, string_expr);
+ gfc_conv_string_parameter (&se);
+ string_len = se.string_length;
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&block, &se.post);
+ string = se.expr;
+
Be careful with this.
se.expr is only guaranteed to be valid after se.pre and before se.post.
Did you check that it works for example if the string actual argument is
an allocatable function?
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, set_expr);
+ gfc_conv_string_parameter (&se);
+ set_len = se.string_length;
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&block, &se.post);
+ set = se.expr;
+
Same here.
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, pos_expr);
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&block, &se.post);
+ pos = se.expr;
+ pos_for_call = fold_convert (gfc_charlen_type_node, pos);
+
... and here.
For simple variables like pos, we can store the value to a variable, and
then the se.post code can be executed without impacting the value.
+ 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 (&block, &se.post);
+ back = se.expr;
same.
+ }
+ else
+ back = build_int_cst (gfc_get_logical_type (4), 0);
+
You can use logical_false_node here.
+ if (string_expr->ts.kind == 1)
+ fndecl = gfor_fndecl_string_split;
+ else
+ fndecl = gfor_fndecl_string_split_char4;
+
+ call = build_call_expr_loc (input_location, fndecl, 6, string_len, string,
+ set_len, set, pos_for_call, back);
+ gfc_add_expr_to_block (&block, call);
+
+ gfc_add_modify (&block, pos,
+ fold_convert (gfc_typenode_for_spec (&pos_expr->ts), call));
+
You can use TREE_TYPE (pos) to get the type.
+ return gfc_finish_block (&block);
+}
/* Return a character string containing the tty name. */
@@ -13261,6 +13328,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/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 742dddfe559..d8d8c7b0aae 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -2031,4 +2031,6 @@ GFORTRAN_15.2 {
_gfortran_maxloc1_16_m16;
_gfortran_mmaxloc1_16_m16;
_gfortran_smaxloc1_16_m16;
+ _gfortran_string_split;
+ _gfortran_string_split_char4;
} GFORTRAN_15;
I think they should be in a new GFORTRAN_16 block inheriting GFORTRAN_15.2.
diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c
b/libgfortran/intrinsics/string_intrinsics_inc.c
index d86bb6c8833..64b3d878a74 100644
--- a/libgfortran/intrinsics/string_intrinsics_inc.c
+++ b/libgfortran/intrinsics/string_intrinsics_inc.c
@@ -459,3 +464,50 @@ string_minmax (gfc_charlen_type *rlen, CHARTYPE **dest,
int op, int nargs, ...)
*dest = tmp;
}
}
+
+gfc_charlen_type
+string_split (gfc_charlen_type stringlen, const CHARTYPE *string,
+ gfc_charlen_type setlen, const CHARTYPE *set,
+ gfc_charlen_type pos, GFC_LOGICAL_4 back)
+{
+ gfc_charlen_type i, j;
+
+ if (!back)
+ {
+ if (pos > stringlen)
+ runtime_error ("If BACK is present with the value false, the value of "
+ "POS shall be in the range [0, LEN (STRING)]");
+
The condition doesn't check pos >= 0; I think the case pos < 0 doesn't work.
Obviously there are tests missing that check the runtime error.
+ for (i = pos + 1; i <= stringlen; i++)
+ {
+ for (j = 0; j < setlen; j++)
+ {
+ if (string[i - 1] == set[j])
+ {
+ return i;
+ }
Style issue: No brace for a single statement.
+ }
+ }
+
+ return stringlen + 1;
+ }
+ 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]");
+
+ for (i = pos - 1; i != 0; i--)
+ {
+ for (j = 0; j < setlen; j++)
+ {
+ if (string[i - 1] == set[j])
+ {
+ return i;
+ }
Same here.
+ }
+ }
+
+ return 0;
+ }
+}
--
2.43.0
