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.  Report error on
	unexpected additional ref.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr102532.f90: Fix dg-errors: Add new error.
	* gfortran.dg/coarray/substring_1.f90: New test.

diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 1fa61ebfe2a0549b4c30083483ffbcbf467db19b..ed8cb54803b8d3e57d21166d16dc136f6ebc2e55 100644 (file)
--- 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 84d84b818259a9ed12252528ba6ce8ddd83359a1..2c76afb179afedb8992429dfa3ce89a19ee1d4f6 100644 (file)
--- 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 09add925fcd196c0599f8ae27b8ef6c10d6f82fa..c11359a559b21d87a07dad94e446b541686f5de6 100644 (file)
--- 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)
                {
@@ -2815,6 +2823,11 @@ check_substring:
          if (substring)
            primary->ts.u.cl = NULL;
 
+         if (gfc_peek_ascii_char () == '(')
+           {
+             gfc_error_now ("Unexpected array/substring ref at %C");
+             return MATCH_ERROR;
+           }
          break;
 
        case MATCH_NO:

diff --git a/gcc/testsuite/gfortran.dg/coarray/substring_1.f90 b/gcc/testsuite/gfortran.dg/coarray/substring_1.f90
new file mode 100644 (file)
index 0000000..3c3ddc7
--- /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 714379a6ac27110be2688ec84979b6db443cb607..cc6e2e9215a8419102f801819eca2f8b4b4e3d49 100644 (file)
--- a/gcc/testsuite/gfortran.dg/pr102532.f90
+++ b/gcc/testsuite/gfortran.dg/pr102532.f90
@@ -5,12 +5,18 @@
 !
 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 "Unexpected array/substring ref|Invalid association target" }
+   end associate ! { dg-error "Expecting END SUBROUTINE" }
+   associate (a => c(:)(:)(2:)) ! { dg-error "Unexpected array/substring ref|Invalid association target" }
+   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
+   character(:), allocatable :: c
+   
+   associate (y => x(:)(:)) ! { dg-error "Unexpected array/substring ref|Invalid association target" }
+   end associate ! { dg-error "Expecting END SUBROUTINE" }
+   c = x(:)(2:5) ! { dg-error "Unexpected array/substring ref" }
+end