Merge branch 'master' into gfortran-testdevel/gfortran-test

5 files changed, 100 insertions, 1 deletions

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index 057b850..440a32a 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,16 @@
+2025-08-06  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR libfortran/121234
+	* io/list_read.c (read_character): Add checks to bypass eating
+	semicolons when reading strings with decimal mode 'point'
+	(list_formatted_read_scalar): Likewise.
+
+2025-07-30  Yuao Ma  <c8ef@outlook.com>
+
+	* gfortran.map: Add split symbol.
+	* intrinsics/string_intrinsics_inc.c (string_split):
+	Runtime support for SPLIT.
+
 2025-06-18  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/82480
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 742dddf..98808dc 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -2032,3 +2032,9 @@ GFORTRAN_15.2 {
     _gfortran_mmaxloc1_16_m16;
     _gfortran_smaxloc1_16_m16;
 } GFORTRAN_15;
+
+GFORTRAN_16 {
+  global:
+    _gfortran_string_split;
+    _gfortran_string_split_char4;
+} GFORTRAN_15.2;
diff --git a/libgfortran/intrinsics/extends_type_of.c b/libgfortran/intrinsics/extends_type_of.c
index 8768b2d..dab14ee 100644
--- a/libgfortran/intrinsics/extends_type_of.c
+++ b/libgfortran/intrinsics/extends_type_of.c
@@ -58,7 +58,7 @@ is_extension_of (struct vtype *v1, struct vtype *v2)
 
   while (v1)
     {
-      if (v1->hash == v2->hash) return 1;
+      if (v1 == v2) return 1;
       v1 = v1->extends;
     }
   return 0;
diff --git a/libgfortran/intrinsics/string_intrinsics_inc.c b/libgfortran/intrinsics/string_intrinsics_inc.c
index d86bb6c..aeecf68 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,10 @@ export_proto(string_trim);
 extern void string_minmax (gfc_charlen_type *, CHARTYPE **, int, int, ...);
 export_proto(string_minmax);
 
+extern gfc_charlen_type 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 +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)], "
+		       "where POS = %ld and LEN (STRING) = %ld",
+		       pos, stringlen);
+
+      for (i = pos + 1; i <= stringlen; i++)
+	{
+	  for (j = 0; j < setlen; j++)
+	    {
+	      if (string[i - 1] == set[j])
+		return i;
+	    }
+	}
+
+      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], "
+		       "where POS = %ld and LEN (STRING) = %ld",
+		       pos, stringlen);
+
+      for (i = pos - 1; i != 0; i--)
+	{
+	  for (j = 0; j < setlen; j++)
+	    {
+	      if (string[i - 1] == set[j])
+		return i;
+	    }
+	}
+
+      return 0;
+    }
+}
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 83124b5..7c22f61 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -1262,6 +1262,11 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 
   if ((c = next_char (dtp)) == EOF)
     goto eof;
+  if (c == ';')
+    {
+      push_char (dtp, c);
+      goto get_string;
+    }
   switch (c)
     {
     CASE_DIGITS:
@@ -1294,6 +1299,13 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
   for (;;)
     {
       c = next_char (dtp);
+
+      if (c == ';')
+	{
+	  push_char (dtp, c);
+	  goto get_string;
+	}
+
       switch (c)
 	{
 	CASE_DIGITS:
@@ -1323,6 +1335,13 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
 
   if ((c = next_char (dtp)) == EOF)
     goto eof;
+
+  if (c == ';')
+    {
+      push_char (dtp, c);
+      goto get_string;
+    }
+
   switch (c)
     {
     CASE_SEPARATORS:
@@ -1346,6 +1365,13 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused)))
     {
       if ((c = next_char (dtp)) == EOF)
 	goto done_eof;
+
+      if (c == ';')
+	{
+	  push_char (dtp, c);
+	  continue;
+	}
+
       switch (c)
 	{
 	case '"':
@@ -2275,6 +2301,8 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
 	}
       if (c == ',' && dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA)
 	c = '.';
+      if (c == ';' && dtp->u.p.current_unit->decimal_status == DECIMAL_POINT)
+	unget_char (dtp, c);
       else if (is_separator (c))
 	{
 	  /* Found a null value.  */