Fortran: fix parsing of type parameter inquiries of substrings [PR101735]

Handling of type parameter inquiries of substrings failed to due either
parsing issues or not following or handling reference chains properly.

	PR fortran/101735

gcc/fortran/ChangeLog:

	* expr.cc (find_inquiry_ref): If an inquiry reference applies to
	a substring, use that, and calculate substring length if needed.
	* primary.cc (extend_ref): Also handle attaching to end of
	reference chain for appending.
	(gfc_match_varspec): Discrimate between arrays of character and
	substrings of them.  If a substring is taken from a character
	component of a derived type, get the proper typespec so that
	inquiry references work correctly.
	(gfc_match_rvalue): Handle corner case where we hit a seemingly
	dangling '%' and missed an inquiry reference. Try another match.

gcc/testsuite/ChangeLog:

	* gfortran.dg/inquiry_type_ref_7.f90: New test.

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 92a9ebdcbe8edaab99c64ff2b4be6aad85977f92..bf858ea5791f7a203fdac972415d7a82ec8e7e4d 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1846,6 +1846,7 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
   gfc_ref *ref;
   gfc_ref *inquiry = NULL;
   gfc_ref *inquiry_head;
+  gfc_ref *ref_ss = NULL;
   gfc_expr *tmp;
 
   tmp = gfc_copy_expr (p);
@@ -1862,6 +1863,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
          {
            inquiry = ref->next;
            ref->next = NULL;
+           if (ref->type == REF_SUBSTRING)
+             ref_ss = ref;
+           break;
          }
     }
 
@@ -1891,6 +1895,28 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
          if (!gfc_notify_std (GFC_STD_F2003, "LEN part_ref at %C"))
            goto cleanup;
 
+         /* Inquire length of substring?  */
+         if (ref_ss)
+           {
+             if (ref_ss->u.ss.start->expr_type == EXPR_CONSTANT
+                 && ref_ss->u.ss.end->expr_type == EXPR_CONSTANT)
+               {
+                 HOST_WIDE_INT istart, iend, length;
+                 istart = gfc_mpz_get_hwi (ref_ss->u.ss.start->value.integer);
+                 iend = gfc_mpz_get_hwi (ref_ss->u.ss.end->value.integer);
+
+                 if (istart <= iend)
+                   length = iend - istart + 1;
+                 else
+                   length = 0;
+                 *newp = gfc_get_int_expr (gfc_default_integer_kind,
+                                           NULL, length);
+                 break;
+               }
+             else
+               goto cleanup;
+           }
+
          if (tmp->ts.u.cl->length
              && tmp->ts.u.cl->length->expr_type == EXPR_CONSTANT)
            *newp = gfc_copy_expr (tmp->ts.u.cl->length);

diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index ec4e13548c4cf7e7423112bf6c8aab9283b8d3c6..426c994e67d175dec7dc3d46a0f4acfd5a2fad88 100644 (file)
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2102,10 +2102,18 @@ extend_ref (gfc_expr *primary, gfc_ref *tail)
 {
   if (primary->ref == NULL)
     primary->ref = tail = gfc_get_ref ();
+  else if (tail == NULL)
+    {
+      /* Set tail to end of reference chain.  */
+      for (gfc_ref *ref = primary->ref; ref; ref = ref->next)
+       if (ref->next == NULL)
+         {
+           tail = ref;
+           break;
+         }
+    }
   else
     {
-      if (tail == NULL)
-       gfc_internal_error ("extend_ref(): Bad tail");
       tail->next = gfc_get_ref ();
       tail = tail->next;
     }
@@ -2302,9 +2310,22 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       gfc_array_spec *as;
       bool coarray_only = sym->attr.codimension && !sym->attr.dimension
                          && sym->ts.type == BT_CHARACTER;
+      gfc_ref *ref, *strarr = NULL;
 
       tail = extend_ref (primary, tail);
-      tail->type = REF_ARRAY;
+      if (sym->ts.type == BT_CHARACTER && tail->type == REF_SUBSTRING)
+       {
+         gcc_assert (sym->attr.dimension);
+         /* Find array reference for substrings of character arrays.  */
+         for (ref = primary->ref; ref && ref->next; ref = ref->next)
+           if (ref->type == REF_ARRAY && ref->next->type == REF_SUBSTRING)
+             {
+               strarr = ref;
+               break;
+             }
+       }
+      else
+       tail->type = REF_ARRAY;
 
       /* In EQUIVALENCE, we don't know yet whether we are seeing
         an array, character variable or array of character
@@ -2317,7 +2338,8 @@ 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,
+      ref = strarr ? strarr : tail;
+      m = gfc_match_array_ref (&ref->u.ar, as, equiv_flag, as ? as->corank : 0,
                               coarray_only);
       if (m != MATCH_YES)
        return m;
@@ -2483,6 +2505,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
     {
       bool t;
       gfc_symtree *tbp;
+      gfc_typespec *ts = &primary->ts;
 
       m = gfc_match_name (name);
       if (m == MATCH_NO)
@@ -2490,8 +2513,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       if (m != MATCH_YES)
        return MATCH_ERROR;
 
+      /* For derived type components find typespec of ultimate component.  */
+      if (ts->type == BT_DERIVED && primary->ref)
+       {
+         for (gfc_ref *ref = primary->ref; ref; ref = ref->next)
+           {
+             if (ref->type == REF_COMPONENT && ref->u.c.component)
+               ts = &ref->u.c.component->ts;
+           }
+       }
+
       intrinsic = false;
-      if (primary->ts.type != BT_CLASS && primary->ts.type != BT_DERIVED)
+      if (ts->type != BT_CLASS && ts->type != BT_DERIVED)
        {
          inquiry = is_inquiry_ref (name, &tmp);
          if (inquiry)
@@ -2564,7 +2597,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
                        return MATCH_ERROR;
                    }
                  else if (tmp->u.i == INQUIRY_LEN
-                          && primary->ts.type != BT_CHARACTER)
+                          && ts->type != BT_CHARACTER)
                    {
                        gfc_error ("The LEN part_ref at %C must be applied "
                                   "to a CHARACTER expression");
@@ -2653,6 +2686,10 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       else if (component == NULL && !inquiry)
        return MATCH_ERROR;
 
+      /* Find end of reference chain if inquiry reference and tail not set.  */
+      if (tail == NULL && inquiry && tmp)
+       tail = extend_ref (primary, tail);
+
       /* Extend the reference chain determined by gfc_find_component or
         is_inquiry_ref.  */
       if (primary->ref == NULL)
@@ -2828,6 +2865,7 @@ check_substring:
          if (substring)
            primary->ts.u.cl = NULL;
 
+         gfc_gobble_whitespace ();
          if (gfc_peek_ascii_char () == '(')
            {
              gfc_error_now ("Unexpected array/substring ref at %C");
@@ -4271,6 +4309,16 @@ gfc_match_rvalue (gfc_expr **result)
       return MATCH_ERROR;
     }
 
+  /* Scan for possible inquiry references.  */
+  if (m == MATCH_YES
+      && e->expr_type == EXPR_VARIABLE
+      && gfc_peek_ascii_char () == '%')
+      {
+       m = gfc_match_varspec (e, 0, false, false);
+       if (m == MATCH_NO)
+         m = MATCH_YES;
+      }
+
   if (m == MATCH_YES)
     {
       e->where = where;

diff --git a/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90
new file mode 100644 (file)
index 0000000..534225a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90
@@ -0,0 +1,62 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/101735 - substrings and parsing of type parameter inquiries
+
+program p
+  implicit none
+  integer, parameter :: ck = 4
+  character(len=5)         :: str  = ""
+  character(len=5)         :: str2(4)
+  character(len=5,kind=ck) :: str4 = ck_""
+  type t
+     character(len=5) :: str(4)
+  end type t
+  type(t) :: var
+  integer :: x, y 
+
+  integer, parameter :: i1 = kind (str(1:3))
+  integer, parameter :: j1 = str (1:3) % kind
+  integer, parameter :: k1 = (str(1:3) % kind)
+  integer, parameter :: kk = str (1:3) % kind % kind
+
+  integer, parameter :: i4 = kind (str4(1:3))
+  integer, parameter :: j4 = str4 (1:3) % kind
+  integer, parameter :: ll = str4 (1:3) % len
+
+  integer, parameter :: i2 = len (str(1:3))
+  integer, parameter :: j2 = str (1:3) % len
+  integer, parameter :: k2 = (str(1:3) % len)
+  integer, parameter :: lk = str (1:3) % len  % kind
+
+  integer, parameter :: l4 = str2      (:) (2:3) % len
+  integer, parameter :: l5 = var % str (:) (2:4) % len
+  integer, parameter :: k4 = str2      (:) (2:3) % kind
+  integer, parameter :: k5 = var % str (:) (2:4) % kind
+  integer, parameter :: k6 = str2      (:) (2:3) % len % kind
+  integer, parameter :: k7 = var % str (:) (2:4) % len % kind
+
+  if (i1 /= 1) stop 1
+  if (j1 /= 1) stop 2
+  if (k1 /= 1) stop 3
+
+  if (i4 /= ck) stop 4
+  if (j4 /= ck) stop 5
+  if (ll /= 3)  stop 6
+
+  if (kk /= 4) stop 7
+  if (lk /= 4) stop 8
+
+  if (i2 /= 3) stop 9
+  if (j2 /= 3) stop 10
+  if (k2 /= 3) stop 11
+
+  if (l4 /= 2) stop 12
+  if (l5 /= 3) stop 13
+  if (k4 /= 1) stop 14
+  if (k5 /= 1) stop 15
+  if (k6 /= 4) stop 16
+  if (k7 /= 4) stop 17
+end
+
+! { dg-final { scan-tree-dump-not "_gfortran_stop_numeric" "original" } }