From 1d5e0abd0e6df0ec05c3dfb4bf7cee433b885994 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Tue, 1 Oct 2024 09:30:59 +0200
Subject: [PATCH] [Fortran] Fix parsing of substring refs in coarrays.
 [PR51815]

The parser was greadily taking the substring ref as an array ref because
an array_spec was present.  Fix this by only parsing the coarray (pseudo)
ref when no regular array is present.

gcc/fortran/ChangeLog:

	PR fortran/51815

	* array.cc (gfc_match_array_ref): Only parse coarray part of
	ref.
	* match.h (gfc_match_array_ref): Add flag.
	* primary.cc (gfc_match_varspec): Request only coarray ref
	parsing when no regular array is present.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr102532.f90: Fix dg-errors: Now a syntax error.
	* gfortran.dg/coarray/substring_1.f90: New test.
---
 gcc/fortran/array.cc                          |  9 ++++--
 gcc/fortran/match.h                           |  3 +-
 gcc/fortran/primary.cc                        | 30 ++++++++++++-------
 .../gfortran.dg/coarray/substring_1.f90       | 16 ++++++++++
 gcc/testsuite/gfortran.dg/pr102532.f90        | 13 ++++----
 5 files changed, 51 insertions(+), 20 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/coarray/substring_1.f90

diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 1fa61ebfe2a..ed8cb54803b 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -179,7 +179,7 @@ matched:

 match
 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
-		     int corank)
+		     int corank, bool coarray_only)
 {
   match m;
   bool matched_bracket = false;
@@ -198,6 +198,8 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
        matched_bracket = true;
        goto coarray;
     }
+  else if (coarray_only && corank != 0)
+    goto coarray;

   if (gfc_match_char ('(') != MATCH_YES)
     {
@@ -243,11 +245,12 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
 coarray:
   if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
     {
-      if (ar->dimen > 0)
+      int dim = coarray_only ? 0 : ar->dimen;
+      if (dim > 0 || coarray_only)
 	{
 	  if (corank != 0)
 	    {
-	      for (int i = ar->dimen; i < GFC_MAX_DIMENSIONS; ++i)
+	      for (int i = dim; i < GFC_MAX_DIMENSIONS; ++i)
 		ar->dimen_type[i] = DIMEN_THIS_IMAGE;
 	      ar->codimen = corank;
 	    }
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 84d84b81825..2c76afb179a 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -317,7 +317,8 @@ match gfc_match_init_expr (gfc_expr **);

 /* array.cc.  */
 match gfc_match_array_spec (gfc_array_spec **, bool, bool);
-match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int);
+match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int,
+			   bool = false);
 match gfc_match_array_constructor (gfc_expr **);

 /* interface.cc.  */
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 09add925fcd..d73d5eaed84 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2192,7 +2192,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   bool intrinsic;
   bool inferred_type;
   locus old_loc;
-  char sep;
+  char peeked_char;

   tail = NULL;

@@ -2282,9 +2282,10 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	sym->ts.u.derived = tgt_expr->ts.u.derived;
     }

-  if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(')
-      || (equiv_flag && gfc_peek_ascii_char () == '(')
-      || gfc_peek_ascii_char () == '[' || sym->attr.codimension
+  peeked_char = gfc_peek_ascii_char ();
+  if ((inferred_type && !sym->as && peeked_char == '(')
+      || (equiv_flag && peeked_char == '(') || peeked_char == '['
+      || sym->attr.codimension
       || (sym->attr.dimension && sym->ts.type != BT_CLASS
 	  && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary)
 	  && !(gfc_matching_procptr_assignment
@@ -2295,6 +2296,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	      || CLASS_DATA (sym)->attr.codimension)))
     {
       gfc_array_spec *as;
+      bool coarray_only = sym->attr.codimension && !sym->attr.dimension
+			  && sym->ts.type == BT_CHARACTER;

       tail = extend_ref (primary, tail);
       tail->type = REF_ARRAY;
@@ -2310,12 +2313,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       else
 	as = sym->as;

-      m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
-			       as ? as->corank : 0);
+      m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, as ? as->corank : 0,
+			       coarray_only);
       if (m != MATCH_YES)
 	return m;

       gfc_gobble_whitespace ();
+      if (coarray_only)
+	{
+	  primary->ts = sym->ts;
+	  goto check_substring;
+	}
+
       if (equiv_flag && gfc_peek_ascii_char () == '(')
 	{
 	  tail = extend_ref (primary, tail);
@@ -2333,14 +2342,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
     return MATCH_YES;

   /* With DEC extensions, member separator may be '.' or '%'.  */
-  sep = gfc_peek_ascii_char ();
+  peeked_char = gfc_peek_ascii_char ();
   m = gfc_match_member_sep (sym);
   if (m == MATCH_ERROR)
     return MATCH_ERROR;

   inquiry = false;
-  if (m == MATCH_YES && sep == '%'
-      && primary->ts.type != BT_CLASS
+  if (m == MATCH_YES && peeked_char == '%' && primary->ts.type != BT_CLASS
       && (primary->ts.type != BT_DERIVED || inferred_type))
     {
       match mm;
@@ -2453,7 +2461,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
            && m == MATCH_YES && !inquiry)
     {
       gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
-		 sep, sym->name);
+		 peeked_char, sym->name);
       return MATCH_ERROR;
     }

@@ -2484,7 +2492,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  if (inquiry)
 	    sym = NULL;

-	  if (sep == '%')
+	  if (peeked_char == '%')
 	    {
 	      if (tmp)
 		{
diff --git a/gcc/testsuite/gfortran.dg/coarray/substring_1.f90 b/gcc/testsuite/gfortran.dg/coarray/substring_1.f90
new file mode 100644
index 00000000000..3c3ddc7fac4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/substring_1.f90
@@ -0,0 +1,16 @@
+!{ dg-do run }
+
+! Test PR51815 is fixed
+! Contributed by Bill Long  <longb ad cray dot com>
+
+PROGRAM pr51815
+   implicit none
+   character(10) :: s[*]
+   character(18) :: d = 'ABCDEFGHIJKLMNOPQR'
+   integer       :: img
+
+   img = this_image()
+   s = d(img:img+9)
+   if (img == 1 .and. s(2:4) /= 'BCD') stop 1
+END PROGRAM
+
diff --git a/gcc/testsuite/gfortran.dg/pr102532.f90 b/gcc/testsuite/gfortran.dg/pr102532.f90
index 714379a6ac2..999ca88482f 100644
--- a/gcc/testsuite/gfortran.dg/pr102532.f90
+++ b/gcc/testsuite/gfortran.dg/pr102532.f90
@@ -5,12 +5,15 @@
 !
 subroutine foo
    character(:), allocatable :: x[:]
-   associate (y => x(:)(2:)) ! { dg-error "Rank mismatch|deferred type parameter" }
-   end associate
+   character(:), dimension(:), allocatable :: c[:]
+   associate (y => x(:)(2:)) ! { dg-error "Expected '\\)' or ','" }
+   end associate ! { dg-error "Expecting END SUBROUTINE" }
+   associate (a => c(:)(:)(2:)) ! { dg-error "Expected '\\)' or ','" }
+   end associate ! { dg-error "Expecting END SUBROUTINE" }
 end

 subroutine bar
    character(:), allocatable :: x[:]
-   associate (y => x(:)(:)) ! { dg-error "Rank mismatch|deferred type parameter" }
-   end associate
-end
\ No newline at end of file
+   associate (y => x(:)(:)) ! { dg-error "Expected '\\)' or ','" }
+   end associate ! { dg-error "Expecting END SUBROUTINE" }
+end
--
2.46.2

