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

Fortran: fix diagnostics for SELECT RANK [PR100607]

Browse source 
gcc/fortran/ChangeLog:

	PR fortran/100607
	* resolve.cc (resolve_select_rank): Remove duplicate error.
	(resolve_fl_var_and_proc): Prevent NULL pointer dereference and
	suppress error message for temporary.

gcc/testsuite/ChangeLog:

	PR fortran/100607
	* gfortran.dg/select_rank_6.f90: New test.
This commit is contained in:
Steve Kargl 2023-06-02 19:44:11 +02:00 • committed by Harald Anlauf
parent 934da923a7
commit fae09dfc0e
2 changed files with 52 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/fortran/resolve.cc
View file

@ -10020,11 +10020,6 @@ resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
|| gfc_expr_attr (code->expr1).pointer))
gfc_error ("RANK (*) at %L cannot be used with the pointer or "
"allocatable selector at %L", &c->where, &code->expr1->where);
if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
|| gfc_expr_attr (code->expr1).pointer))
gfc_error ("RANK (*) at %L cannot be used with the pointer or "
"allocatable selector at %L", &c->where, &code->expr1->where);
}
/* Add EXEC_SELECT to switch on rank. */
@ -13262,7 +13257,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
if (allocatable)
{
if (dimension && as->type != AS_ASSUMED_RANK)
if (dimension
&& as
&& as->type != AS_ASSUMED_RANK
&& !sym->attr.select_rank_temporary)
{
gfc_error ("Allocatable array %qs at %L must have a deferred "
"shape or assumed rank", sym->name, &sym->declared_at);

48
gcc/testsuite/gfortran.dg/select_rank_6.f90 Normal file
View file

@ -0,0 +1,48 @@
! { dg-do compile }
! PR fortran/100607 - fix diagnostics for SELECT RANK
! Contributed by T.Burnus
program p
implicit none
integer, allocatable :: A(:,:,:)
allocate(a(5:6,-2:2, 99:100))
call foo(a)
call bar(a)
contains
subroutine foo(x)
integer, allocatable :: x(..)
if (rank(x) /= 3) stop 1
if (any (lbound(x) /= [5, -2, 99])) stop 2
select rank (x)
rank(3)
if (any (lbound(x) /= [5, -2, 99])) stop 3
end select
select rank (x) ! { dg-error "pointer or allocatable selector at .2." }
rank(*) ! { dg-error "pointer or allocatable selector at .2." }
if (rank(x) /= 1) stop 4
if (lbound(x, 1) /= 1) stop 5
end select
end
subroutine bar(x)
integer :: x(..)
if (rank(x) /= 3) stop 6
if (any (lbound(x) /= 1)) stop 7
select rank (x)
rank(3)
if (any (lbound(x) /= 1)) stop 8
end select
select rank (x)
rank(*)
if (rank(x) /= 1) stop 9
if (lbound(x, 1) /= 1) stop 10
end select
end
end