[gcc r15-9759] Fortran: fix parsing of type parameter inquiries of substrings [PR101735]
Harald Anlauf
anlauf@gcc.gnu.org
Tue Jun 3 17:33:01 GMT 2025
https://gcc.gnu.org/g:25e46423bdfdf6e14cc1bc753f05b3b4fb5e8cc8
commit r15-9759-g25e46423bdfdf6e14cc1bc753f05b3b4fb5e8cc8
Author: Harald Anlauf <anlauf@gmx.de>
Date: Tue May 27 19:23:16 2025 +0200
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.
(cherry picked from commit 787a8dec1acedf5561c8ee43bed0b3653fca150d)
Diff:
---
gcc/fortran/expr.cc | 26 ++++++++++
gcc/fortran/primary.cc | 60 ++++++++++++++++++++---
gcc/testsuite/gfortran.dg/inquiry_type_ref_7.f90 | 62 ++++++++++++++++++++++++
3 files changed, 142 insertions(+), 6 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 827e1995a6a8..45f59fba6cf4 100644
--- 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 72ecc7ccf934..8443e8943dc0 100644
--- 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
index 000000000000..534225a742d2
--- /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" } }
More information about the Gcc-cvs
mailing list