mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2025-01-01 16:34:06 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

Fortran: ICE in resolve_allocate_deallocate for invalid STAT argument

Browse Source 
gcc/fortran/ChangeLog:

	PR fortran/101564
	* expr.c (gfc_check_vardef_context): Add check for KIND and LEN
	parameter inquiries.
	* match.c (gfc_match): Fix comment for %v code.
	(gfc_match_allocate, gfc_match_deallocate): Replace use of %v code
	by %e in gfc_match to allow for function references as STAT and
	ERRMSG arguments.
	* resolve.c (resolve_allocate_deallocate): Avoid NULL pointer
	dereferences and shortcut for bad STAT and ERRMSG argument to
	(DE)ALLOCATE.  Remove bogus parts of checks for STAT and ERRMSG.

gcc/testsuite/ChangeLog:

	PR fortran/101564
	* gfortran.dg/allocate_stat_3.f90: New test.
	* gfortran.dg/allocate_stat.f90: Adjust error messages.
	* gfortran.dg/implicit_11.f90: Likewise.
	* gfortran.dg/inquiry_type_ref_3.f90: Likewise.
This commit is contained in:
Harald Anlauf 2021-07-28 19:11:27 +02:00
parent 49e28c02a9
commit 7bf582e6cf
7 changed files with 117 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/expr.c
View File

@ -6199,6 +6199,16 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
if (!pointer)
check_intentin = false;
}
if (ref->type == REF_INQUIRY
&& (ref->u.i == INQUIRY_KIND || ref->u.i == INQUIRY_LEN))
{
if (context)
gfc_error ("%qs parameter inquiry for %qs in "
"variable definition context (%s) at %L",
ref->u.i == INQUIRY_KIND ? "KIND" : "LEN",
sym->name, context, &e->where);
return false;
}
}
if (check_intentin

11
gcc/fortran/match.c
View File

@ -1109,7 +1109,8 @@ gfc_match_char (char c)
%t Matches end of statement.
%o Matches an intrinsic operator, returned as an INTRINSIC enum.
%l Matches a statement label
%v Matches a variable expression (an lvalue)
%v Matches a variable expression (an lvalue, except function references
having a data pointer result)
% Matches a required space (in free form) and optional spaces. */
match
@ -4405,7 +4406,7 @@ gfc_match_allocate (void)
alloc_opt_list:
m = gfc_match (" stat = %v", &tmp);
m = gfc_match (" stat = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@ -4434,7 +4435,7 @@ alloc_opt_list:
goto alloc_opt_list;
}
m = gfc_match (" errmsg = %v", &tmp);
m = gfc_match (" errmsg = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@ -4777,7 +4778,7 @@ gfc_match_deallocate (void)
dealloc_opt_list:
m = gfc_match (" stat = %v", &tmp);
m = gfc_match (" stat = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
@ -4799,7 +4800,7 @@ dealloc_opt_list:
goto dealloc_opt_list;
}
m = gfc_match (" errmsg = %v", &tmp);
m = gfc_match (" errmsg = %e", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)

35
gcc/fortran/resolve.c
View File

@ -8155,16 +8155,21 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
/* Check the stat variable. */
if (stat)
{
gfc_check_vardef_context (stat, false, false, false,
_("STAT variable"));
if (!gfc_check_vardef_context (stat, false, false, false,
_("STAT variable")))
goto done_stat;
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
|| stat->ref->type == REF_COMPONENT)))
if (stat->ts.type != BT_INTEGER
|| stat->rank > 0)
gfc_error ("Stat-variable at %L must be a scalar INTEGER "
"variable", &stat->where);
if (stat->expr_type == EXPR_CONSTANT || stat->symtree == NULL)
goto done_stat;
/* F2018:9.7.4: The stat-variable shall not be allocated or deallocated
* within the ALLOCATE or DEALLOCATE statement in which it appears ...
*/
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name)
{
@ -8192,6 +8197,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
}
}
done_stat:
/* Check the errmsg variable. */
if (errmsg)
{
@ -8199,22 +8206,26 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
gfc_warning (0, "ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
gfc_check_vardef_context (errmsg, false, false, false,
_("ERRMSG variable"));
if (!gfc_check_vardef_context (errmsg, false, false, false,
_("ERRMSG variable")))
goto done_errmsg;
/* F18:R928 alloc-opt is ERRMSG = errmsg-variable
F18:R930 errmsg-variable is scalar-default-char-variable
F18:R906 default-char-variable is variable
F18:C906 default-char-variable shall be default character. */
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
&& (errmsg->ref->type == REF_ARRAY
|| errmsg->ref->type == REF_COMPONENT)))
if (errmsg->ts.type != BT_CHARACTER
|| errmsg->rank > 0
|| errmsg->ts.kind != gfc_default_character_kind)
gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER "
"variable", &errmsg->where);
if (errmsg->expr_type == EXPR_CONSTANT || errmsg->symtree == NULL)
goto done_errmsg;
/* F2018:9.7.5: The errmsg-variable shall not be allocated or deallocated
* within the ALLOCATE or DEALLOCATE statement in which it appears ...
*/
for (p = code->ext.alloc.list; p; p = p->next)
if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name)
{
@ -8242,6 +8253,8 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
}
}
done_errmsg:
/* Check that an allocate-object appears only once in the statement. */
for (p = code->ext.alloc.list; p; p = p->next)

8
gcc/testsuite/gfortran.dg/allocate_stat.f90
View File

@ -38,7 +38,7 @@ function func2() result(res)
implicit none
real, pointer :: gain
integer :: res
allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
allocate (gain,STAT=func2) ! { dg-error "requires an argument list" }
deallocate(gain)
res = 0
end function func2
@ -51,7 +51,7 @@ subroutine sub()
end interface
real, pointer :: gain
integer, parameter :: res = 2
allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
allocate (gain,STAT=func2) ! { dg-error "requires an argument list" }
deallocate(gain)
end subroutine sub
@ -68,9 +68,9 @@ contains
end function one
subroutine sub()
integer, pointer :: p
allocate(p, stat=one) ! { dg-error "is not a variable" }
allocate(p, stat=one) ! { dg-error "requires an argument list" }
if(associated(p)) deallocate(p)
allocate(p, stat=two) ! { dg-error "is not a variable" }
allocate(p, stat=two) ! { dg-error "requires an argument list" }
if(associated(p)) deallocate(p)
end subroutine sub
end module test

71
gcc/testsuite/gfortran.dg/allocate_stat_3.f90 Normal file
View File

@ -0,0 +1,71 @@
! { dg-do compile }
! PR fortran/101564 - ICE in resolve_allocate_deallocate
program p
implicit none
integer, allocatable :: x(:)
integer :: stat
integer, pointer :: A
integer, target :: ptr
real, target :: r
character(80) :: c
type t
integer :: stat
real :: r
complex :: z
end type t
type(t), allocatable :: y
type tc
character(len=:), allocatable :: s
end type tc
type(tc) :: z
allocate (character(42) :: z%s, stat=stat)
allocate (x(2), stat=stat)
deallocate (x, stat=stat)
allocate (A, stat=f())
deallocate (A, stat=f())
allocate (A, stat=y%stat)
deallocate (A, stat=y%stat)
allocate (A, stat=stat, errmsg=c(2:79))
deallocate (A, stat=stat, errmsg=c(2:79))
allocate (A, stat=stat, errmsg=z%s)
deallocate (A, stat=stat, errmsg=z%s)
allocate (A, stat=stat, errmsg=z%s(2:39))
deallocate (A, stat=stat, errmsg=z%s(2:39))
allocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" }
deallocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" }
allocate (x(2), stat=stat%kind) ! { dg-error "STAT tag" }
deallocate (x, stat=stat%kind) ! { dg-error "STAT variable" }
allocate (A, stat=A%kind) ! { dg-error "STAT tag" }
deallocate (A, stat=A%kind) ! { dg-error "STAT variable" }
allocate (A, stat=c%len) ! { dg-error "STAT tag" }
deallocate (A, stat=c%len) ! { dg-error "STAT variable" }
allocate (A, stat=y%stat%kind) ! { dg-error "STAT tag" }
deallocate (A, stat=y%stat%kind) ! { dg-error "STAT variable" }
allocate (y, stat=y%stat) ! { dg-error "within the same ALLOCATE statement" }
allocate (y, stat=r) ! { dg-error "must be a scalar INTEGER variable" }
allocate (A, stat=y%z%re) ! { dg-error "must be a scalar INTEGER variable" }
deallocate (A, stat=y%z%im) ! { dg-error "must be a scalar INTEGER variable" }
allocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" }
deallocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" }
allocate (A, stat=f) ! { dg-error "requires an argument list" }
deallocate (A, stat=f) ! { dg-error "requires an argument list" }
allocate (y, stat=g) ! { dg-error "requires an argument list" }
deallocate (y, stat=g) ! { dg-error "requires an argument list" }
allocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" }
deallocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" }
allocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" }
deallocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" }
allocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" }
deallocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" }
deallocate (z%s, stat=stat, errmsg=z%s) ! { dg-error "within the same DEALLOCATE statement" }
contains
integer function f()
pointer :: f
f => ptr
end function f
real function g()
pointer :: g
g => r
end function g
end

2
gcc/testsuite/gfortran.dg/implicit_11.f90
View File

@ -31,6 +31,6 @@
SUBROUTINE AD0001
REAL RLA1(:)
ALLOCATABLE RLA1
ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "is not a variable" }
ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "requires an argument list" }
END SUBROUTINE
END MODULE tests2

2
gcc/testsuite/gfortran.dg/inquiry_type_ref_3.f90
View File

@ -17,7 +17,7 @@ program main
type(t) :: s
b = "abcdefg"
a%kind = 2 ! { dg-error "Assignment to a constant expression" }
b%len = 2 ! { dg-error "Assignment to a LEN or KIND part_ref" }
b%len = 2 ! { dg-error "parameter inquiry" }
i = a%kind ! OK
i = b%len ! OK
print *, z%re ! { dg-error "must be applied to a COMPLEX expression" }