https://gcc.gnu.org/g:5f5074fe7aaf9524defb265299a985eecba7f914
commit r15-633-g5f5074fe7aaf9524defb265299a985eecba7f914
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Fri May 17 15:19:26 2024 +0100
Fortran: Fix select type regression due to r14-9489 [PR114874]
2024-05-17 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 a left parenthesis has been detected,
check the current namespace 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:
---
gcc/fortran/gfortran.h | 4 +++
gcc/fortran/match.cc | 21 +++++++++++++
gcc/fortran/primary.cc | 10 +++---
gcc/fortran/resolve.cc | 17 +++++++---
gcc/testsuite/gfortran.dg/pr114874_1.f90 | 32 +++++++++++++++++++
gcc/testsuite/gfortran.dg/pr114874_2.f90 | 53 ++++++++++++++++++++++++++++++++
6 files changed, 128 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index a7a0fdba3dd3..de1a7cd09352 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 4539c9bb1344..1851a8f94a54 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -6721,6 +6721,27 @@ gfc_match_select_type (void)
goto cleanup;
}
+ /* Select type namespaces are not filled until resolution. Therefore, the
+ namespace must be marked as having an inferred type associate name if
+ either expr1 is an inferred type variable or expr2 is. In the latter
+ case, as well as the symbol being marked as inferred type, it might be
+ that it has not been detected to be so. In this case the target has
+ unknown type. Once the namespace is marked, the fixups in resolution can
+ be triggered. */
+ if (!expr2
+ && expr1->symtree->n.sym->assoc
+ && expr1->symtree->n.sym->assoc->inferred_type)
+ gfc_current_ns->assoc_name_inferred = 1;
+ else 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;
+ }
+
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 8e7833769a8f..76f6bcb8a789 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 4368627041ed..d7a0856fcca1 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 000000000000..e385bb156be9
--- /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 000000000000..5028830cacae
--- /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
