FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Fix select type regression due to r14-9489 [PR114874]

Browse source 
2024-05-17  Paul Thomas  <pault@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.

(cherry picked from commit 5f5074fe7aaf9524defb265299a985eecba7f914)
This commit is contained in:
Paul Thomas 2024-05-17 15:19:26 +01:00
parent e909d360df
commit c887341432
6 changed files with 128 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
gcc/fortran/gfortran.h
View file

@ -2241,6 +2241,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;

21
gcc/fortran/match.cc
View file

@ -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;

10
gcc/fortran/primary.cc
View file

@ -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;

17
gcc/fortran/resolve.cc
View file

@ -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);
}

32
gcc/testsuite/gfortran.dg/pr114874_1.f90 Normal file
View file

@ -0,0 +1,32 @@
! { dg-do compile }
! Test fix for regression caused by r14-9489 - valid code only.
! Contributed by Harald Anlauf <anlauf@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

53
gcc/testsuite/gfortran.dg/pr114874_2.f90 Normal file
View file

@ -0,0 +1,53 @@
! { dg-do compile }
! Test fix for regression caused by r14-9489 - invalid code.
! Contributed by Harald Anlauf <anlauf@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