https://gcc.gnu.org/g:4a0e88c0c329ee69b13cdf2784c0c88edbca1f9e
commit r14-11765-g4a0e88c0c329ee69b13cdf2784c0c88edbca1f9e
Author: Harald Anlauf <anl...@gmx.de>
Date: Sat May 3 20:35:57 2025 +0200
Fortran: array subreferences and components of derived types [PR119986]
PR fortran/119986
gcc/fortran/ChangeLog:
* expr.cc (is_subref_array): When searching for array references,
do not terminate early so that inquiry references to complex
components work.
* primary.cc (gfc_variable_attr): A substring reference can refer
to either a scalar or array character variable. Adjust search
accordingly.
gcc/testsuite/ChangeLog:
* gfortran.dg/actual_array_subref.f90: New test.
(cherry picked from commit fceb6022798b587c9111d0241aaff72602dcd626)
Diff:
---
gcc/fortran/expr.cc | 1 +
gcc/fortran/primary.cc | 13 ++-
gcc/testsuite/gfortran.dg/actual_array_subref.f90 | 103 ++++++++++++++++++++++
3 files changed, 113 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 9ce0b950b617..c5b822ed0135 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1168,6 +1168,7 @@ is_subref_array (gfc_expr * e)
what follows cannot be a subreference array, unless there is a
substring reference. */
if (!seen_array && ref->type == REF_COMPONENT
+ && ref->next == NULL
&& ref->u.c.component->ts.type != BT_CHARACTER
&& ref->u.c.component->ts.type != BT_CLASS
&& !gfc_bt_struct (ref->u.c.component->ts.type))
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 478fbe2be61e..4ffa6d0d287f 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2765,6 +2765,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
gfc_symbol *sym;
gfc_component *comp;
bool has_inquiry_part;
+ bool has_substring_ref = false;
if (expr->expr_type != EXPR_VARIABLE
&& expr->expr_type != EXPR_FUNCTION
@@ -2827,7 +2828,12 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
has_inquiry_part = false;
for (ref = expr->ref; ref; ref = ref->next)
- if (ref->type == REF_INQUIRY)
+ if (ref->type == REF_SUBSTRING)
+ {
+ has_substring_ref = true;
+ optional = false;
+ }
+ else if (ref->type == REF_INQUIRY)
{
has_inquiry_part = true;
optional = false;
@@ -2875,9 +2881,8 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
*ts = comp->ts;
/* Don't set the string length if a substring reference
follows. */
- if (ts->type == BT_CHARACTER
- && ref->next && ref->next->type == REF_SUBSTRING)
- ts->u.cl = NULL;
+ if (ts->type == BT_CHARACTER && has_substring_ref)
+ ts->u.cl = NULL;
}
if (comp->ts.type == BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/actual_array_subref.f90
b/gcc/testsuite/gfortran.dg/actual_array_subref.f90
new file mode 100644
index 000000000000..932d7aba1214
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/actual_array_subref.f90
@@ -0,0 +1,103 @@
+! { dg-do run }
+! { dg-additional-options "-O2 -fcheck=bounds" }
+!
+! PR fortran/119986
+!
+! Check passing of inquiry references of complex arrays and substring
+! references of character arrays when these are components of derived types.
+!
+! Extended version of report by Neil Carlson.
+
+program main
+ implicit none
+ integer :: j
+
+ complex, parameter :: z0(*) = [(cmplx(j,-j),j=1,4)]
+ type :: cx
+ real :: re
+ real :: im
+ end type cx
+ type(cx), parameter :: c0(*) = [(cx (j,-j),j=1,4)]
+
+ type :: my_type
+ complex :: z(4) = z0
+ type(cx) :: c(4) = c0
+ end type my_type
+ type(my_type) :: x
+
+ character(*), parameter :: s0(*) = ["abcd","efgh","ijkl","mnop"]
+ character(*), parameter :: expect(*) = s0(:)(2:3)
+ character(len(s0)) :: s1(4) = s0
+
+ type :: str1
+ character(len(s0)) :: s(4) = s0
+ end type str1
+ type(str1) :: string1
+
+ type :: str2
+ character(:), allocatable :: s(:)
+ end type str2
+ type(str2) :: string2
+
+ integer :: stopcode = 0
+
+ if (len(expect) /= 2) stop 1
+ if (expect(4) /= "no") stop 2
+ if (any(c0 %re /= [ 1, 2, 3, 4])) stop 3
+ if (any(c0 %im /= [-1,-2,-3,-4])) stop 4
+
+ stopcode = 10
+ call fubar ( x%z %re, x%z %im)
+ call fubar ( x%c %re, x%c %im)
+
+ stopcode = 20
+ call fubar ((x%z %re), (x%z %im))
+ call fubar ((x%c %re), (x%c %im))
+
+ stopcode = 30
+ call fubar ([x%z %re], [x%z %im])
+ call fubar ([x%c %re], [x%c %im])
+
+ stopcode = 50
+ call chk ( s0(:)(2:3) )
+ call chk ((s0(:)(2:3)))
+ call chk ([s0(:)(2:3)])
+
+ stopcode = 60
+ call chk ( s1(:)(2:3) )
+ call chk ((s1(:)(2:3)))
+ call chk ([s1(:)(2:3)])
+
+ stopcode = 70
+ call chk ( string1%s(:)(2:3) )
+ call chk ((string1%s(:)(2:3)))
+ call chk ([string1%s(:)(2:3)])
+
+ string2% s = s0
+ if (len(string2%s) /= 4) stop 99
+ stopcode = 80
+ call chk ( string2%s(:)(2:3) )
+ call chk ((string2%s(:)(2:3)))
+ call chk ([string2%s(:)(2:3)])
+ deallocate (string2% s)
+
+contains
+
+ subroutine fubar(u, v)
+ real, intent(in) :: u(:), v(:)
+ if (any (u /= z0%re)) stop stopcode + 1
+ if (any (v /= z0%im)) stop stopcode + 2
+ if (any (u /= c0%re)) stop stopcode + 3
+ if (any (v /= c0%im)) stop stopcode + 4
+ stopcode = stopcode + 4
+ end subroutine
+
+ subroutine chk (s)
+ character(*), intent(in) :: s(:)
+ if (size(s) /= 4) stop stopcode + 1
+ if (len (s) /= 2) stop stopcode + 2
+ if (any (s /= expect)) stop stopcode + 3
+ stopcode = stopcode + 3
+ end subroutine chk
+
+end program
