Hi All,
I have been around several circuits with a patch for this regression. I
posted one in Bugzilla but rejected it because it was not direct enough.
This one, however, is more to my liking and fixes another bug lurking in
the shadows.
The way in which select type has been implemented is a bit weird in that
the select type temporaries don't get their assoc set until resolution.
Therefore, if the selector is of inferred type, the namespace is tagged by
setting 'assoc_name_inferred'. This narrows down the range of select type
temporaries that are picked out by the chunk in primary.cc, thereby fixing
the problem.
The chunks in resolve.cc fix a problem found on the way, where invalid
array references, either cause an ICE or were silently absorbed.
OK for mainline and 14-branch?
Paul
Fortran: Fix select type regression due to r14-9489 [PR114874]
2024-05-15 Paul Thomas <pa...@gcc.gnu.org>
gcc/fortran
PR fortran/114874
* gfortran.h: Add 'assoc_name_inferred' to gfc_namespace.
* match.cc (gfc_match_select_type) : Set 'assoc_name_inferred'
in select type namespace if the selector has inferred type.
* primary.cc (gfc_match_varspec): If a select type temporary
is apparently scalar and '(' has been detected, check to see if
the current name space has 'assoc_name_inferred' set. If so,
set inferred_type.
* resolve.cc (resolve_variable): If the namespace of a select
type temporary is marked with 'assoc_name_inferred' call
gfc_fixup_inferred_type_refs to ensure references are OK.
(gfc_fixup_inferred_type_refs): Catch invalid array refs..
gcc/testsuite/
PR fortran/114874
* gfortran.dg/pr114874_1.f90: New test for valid code.
* gfortran.dg/pr114874_2.f90: New test for invalid code.
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a7a0fdba3dd..de1a7cd0935 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2242,6 +2242,10 @@ typedef struct gfc_namespace
/* Set when resolve_types has been called for this namespace. */
unsigned types_resolved:1;
+ /* Set if the associate_name in a select type statement is an
+ inferred type. */
+ unsigned assoc_name_inferred:1;
+
/* Set to 1 if code has been generated for this namespace. */
unsigned translated:1;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 4539c9bb134..b7441b9b074 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6721,6 +6721,20 @@ gfc_match_select_type (void)
goto cleanup;
}
+ if (expr2 && expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->assoc)
+ {
+ if (expr2->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+ else if (expr2->symtree->n.sym->assoc->target
+ && expr2->symtree->n.sym->assoc->target->ts.type == BT_UNKNOWN)
+ gfc_current_ns->assoc_name_inferred = 1;
+ }
+ else if (!expr2
+ && expr1->symtree->n.sym->assoc
+ && expr1->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+
new_st.op = EXEC_SELECT_TYPE;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8e7833769a8..76f6bcb8a78 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2113,13 +2113,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
inferred_type = IS_INFERRED_TYPE (primary);
- /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose
- selector has not been parsed, can generate errors with array and component
- refs.. Use 'inferred_type' as a flag to suppress these errors. */
+ /* SELECT TYPE temporaries within an ASSOCIATE block, whose selector has not
+ been parsed, can generate errors with array refs.. The SELECT TYPE
+ namespace is marked with 'assoc_name_inferred'. During resolution, this is
+ detected and gfc_fixup_inferred_type_refs is called. */
if (!inferred_type
- && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- && !sym->attr.codimension
&& sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred
&& !sym->attr.select_rank_temporary)
inferred_type = true;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4368627041e..d7a0856fcca 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5888,6 +5888,9 @@ resolve_variable (gfc_expr *e)
if (e->expr_type == EXPR_CONSTANT)
return true;
}
+ else if (sym->attr.select_type_temporary
+ && sym->ns->assoc_name_inferred)
+ gfc_fixup_inferred_type_refs (e);
/* For variables that are used in an associate (target => object) where
the object's basetype is array valued while the target is scalar,
@@ -6231,10 +6234,12 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
free (new_ref);
}
else
- {
- e->ref = ref->next;
- free (ref);
- }
+ {
+ if (e->ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
+ e->ref = ref->next;
+ free (ref);
+ }
}
/* It is possible for an inquiry reference to be mistaken for a
@@ -6315,6 +6320,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
&& e->ref->u.ar.type != AR_ELEMENT)
{
ref = e->ref;
+ if (ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
e->ref = ref->next;
free (ref);
@@ -6337,6 +6344,8 @@ gfc_fixup_inferred_type_refs (gfc_expr *e)
&& e->ref->next->u.ar.type != AR_ELEMENT)
{
ref = e->ref->next;
+ if (ref->u.ar.type == AR_UNKNOWN)
+ gfc_error ("Invalid array reference at %L", &e->where);
e->ref->next = e->ref->next->next;
free (ref);
}
diff --git a/gcc/testsuite/gfortran.dg/pr114874_1.f90 b/gcc/testsuite/gfortran.dg/pr114874_1.f90
new file mode 100644
index 00000000000..e385bb156be
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114874_1.f90
@@ -0,0 +1,32 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - valid code only.
+! Contributed by Harald Anlauf <anl...@gcc.gnu.org>
+!
+module p
+ implicit none
+contains
+ subroutine foo
+ class(*), allocatable :: c
+ c = 'abc'
+ select type (c)
+ type is (character(*))
+ if (c .ne. 'abc') stop 1
+! Regression caused ICE here - valid substring reference
+ if (c(2:2) .ne. 'b') stop 2
+ end select
+ end
+ subroutine bar ! This worked correctly
+ class(*), allocatable :: c(:)
+ c = ['abc','def']
+ select type (c)
+ type is (character(*))
+ if (any (c .ne. ['abc','def'])) stop 3
+ if (any (c(:)(2:2) .ne. ['b','e'])) stop 4
+ end select
+ end
+end module p
+
+ use p
+ call foo
+ call bar
+end
diff --git a/gcc/testsuite/gfortran.dg/pr114874_2.f90 b/gcc/testsuite/gfortran.dg/pr114874_2.f90
new file mode 100644
index 00000000000..5028830caca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr114874_2.f90
@@ -0,0 +1,53 @@
+! { dg-do compile }
+! Test fix for regression caused by r14-9489 - invalid code.
+! Contributed by Harald Anlauf <anl...@gcc.gnu.org>
+
+module q
+ type :: s
+ integer :: j
+ end type
+ type :: t
+ integer :: i
+ class(s), allocatable :: ca
+ end type
+contains
+ subroutine foobar
+ class(*), allocatable :: c
+ c = t (1)
+ select type (c)
+ type is (t)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+ if (c(1)%i .ne. 1) stop 5 ! { dg-error "Syntax error in IF-expression" }
+ if (allocated (c%ca)) then
+! Make sure that response is correct if problem is "nested".
+ select type (ca => c%ca)
+ type is (s)
+! Regression caused ICE here in translation or error was missed - invalid array reference
+ if (ca(1)%j .ne. 1) stop 6 ! { dg-error "Syntax error in IF-expression" }
+ end select
+ select type (ca(1) => c%ca) ! { dg-error "parse error in SELECT TYPE" }
+ type is (s) ! { dg-error "Unexpected TYPE IS statement" }
+ if (ca(1)%j .ne. 1) stop 6 ! { dg-error "nonderived-type variable" }
+ end select ! { dg-error " Expecting END IF statement" }
+ endif
+ end select
+
+! This problem was found in the course of the fix: Chunk taken from associate_64.f90,
+! the derived type and component names adapted and the invalid array reference added.
+ associate (var4 => bar4())
+ if (var4%i .ne. 84) stop 33
+ if (var4%ca%j .ne. 168) stop 34
+ select type (x => var4)
+ type is (t)
+ if (x(1)%i .ne. var4%i) stop 35 ! { dg-error "Invalid array reference" }
+ if (x%ca%j .ne. var4%ca%j) stop 36
+ class default
+ stop 37
+ end select
+ end associate
+ end
+ function bar4() result(res)
+ class(t), allocatable :: res
+ res = t(84, s(168))
+ end
+end module q
