re PR fortran/32936 (ALLOCATE: "STAT expression ... must be a variable" - but it is one)
2007-08-01 Tobias Burnus <burnus@net-b.de> PR fortran/32936 * match.c (gfc_match_allocate): Better check that STAT is a variable. * check.c (gfc_check_allocated): Reorder checks to improve error message. 2007-08-01 Tobias Burnus <burnus@net-b.de> PR fortran/32936 * gfortran.dg/allocate_stat.f90: New. From-SVN: r127135
This commit is contained in:
parent
8fe428c670
commit
b8a0d3cfd7
|
@ -1,3 +1,12 @@
|
|||
2007-08-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/32936
|
||||
* match.c (gfc_match_allocate): Better check that STAT is
|
||||
a variable.
|
||||
|
||||
* check.c (gfc_check_allocated): Reorder checks to improve
|
||||
error message.
|
||||
|
||||
2007-08-01 Nick Clifton <nickc@redhat.com>
|
||||
|
||||
* arith.c: Change copyright header to refer to version 3 of the
|
||||
|
|
|
@ -488,9 +488,6 @@ gfc_check_allocated (gfc_expr *array)
|
|||
if (variable_check (array, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (array_check (array, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
attr = gfc_variable_attr (array, NULL);
|
||||
if (!attr.allocatable)
|
||||
{
|
||||
|
@ -500,6 +497,9 @@ gfc_check_allocated (gfc_expr *array)
|
|||
return FAILURE;
|
||||
}
|
||||
|
||||
if (array_check (array, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
|
|
@ -2000,6 +2000,8 @@ gfc_match_allocate (void)
|
|||
|
||||
if (stat != NULL)
|
||||
{
|
||||
bool is_variable;
|
||||
|
||||
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
|
||||
{
|
||||
gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
|
||||
|
@ -2014,7 +2016,38 @@ gfc_match_allocate (void)
|
|||
goto cleanup;
|
||||
}
|
||||
|
||||
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
|
||||
is_variable = false;
|
||||
if (stat->symtree->n.sym->attr.flavor == FL_VARIABLE)
|
||||
is_variable = true;
|
||||
else if (stat->symtree->n.sym->attr.function
|
||||
&& stat->symtree->n.sym->result == stat->symtree->n.sym
|
||||
&& (gfc_current_ns->proc_name == stat->symtree->n.sym
|
||||
|| (gfc_current_ns->parent
|
||||
&& gfc_current_ns->parent->proc_name
|
||||
== stat->symtree->n.sym)))
|
||||
is_variable = true;
|
||||
else if (gfc_current_ns->entries
|
||||
&& stat->symtree->n.sym->result == stat->symtree->n.sym)
|
||||
{
|
||||
gfc_entry_list *el;
|
||||
for (el = gfc_current_ns->entries; el; el = el->next)
|
||||
if (el->sym == stat->symtree->n.sym)
|
||||
{
|
||||
is_variable = true;
|
||||
}
|
||||
}
|
||||
else if (gfc_current_ns->parent && gfc_current_ns->parent->entries
|
||||
&& stat->symtree->n.sym->result == stat->symtree->n.sym)
|
||||
{
|
||||
gfc_entry_list *el;
|
||||
for (el = gfc_current_ns->parent->entries; el; el = el->next)
|
||||
if (el->sym == stat->symtree->n.sym)
|
||||
{
|
||||
is_variable = true;
|
||||
}
|
||||
}
|
||||
|
||||
if (!is_variable)
|
||||
{
|
||||
gfc_error ("STAT expression at %C must be a variable");
|
||||
goto cleanup;
|
||||
|
|
|
@ -1,3 +1,8 @@
|
|||
2007-08-01 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/32936
|
||||
* gfortran.dg/allocate_stat.f90: New.
|
||||
|
||||
2007-08-01 Nathan Froyd <froydnj@codesourcery.com>
|
||||
|
||||
* gcc.target/i386/pr23098.c: XFAIL on vxworks targets.
|
||||
|
|
|
@ -0,0 +1,76 @@
|
|||
! { dg-do compile }
|
||||
! PR fortran/32936
|
||||
!
|
||||
!
|
||||
function all_res()
|
||||
implicit none
|
||||
real, pointer :: gain
|
||||
integer :: all_res
|
||||
allocate (gain,STAT=all_res)
|
||||
deallocate(gain)
|
||||
call bar()
|
||||
contains
|
||||
subroutine bar()
|
||||
real, pointer :: gain2
|
||||
allocate (gain2,STAT=all_res)
|
||||
deallocate(gain2)
|
||||
end subroutine bar
|
||||
end function all_res
|
||||
|
||||
function func()
|
||||
implicit none
|
||||
real, pointer :: gain
|
||||
integer :: all_res2, func
|
||||
func = 0
|
||||
entry all_res2
|
||||
allocate (gain,STAT=all_res2)
|
||||
deallocate(gain)
|
||||
contains
|
||||
subroutine test
|
||||
implicit none
|
||||
real, pointer :: gain2
|
||||
allocate (gain2,STAT=all_res2)
|
||||
deallocate(gain2)
|
||||
end subroutine test
|
||||
end function func
|
||||
|
||||
function func2() result(res)
|
||||
implicit none
|
||||
real, pointer :: gain
|
||||
integer :: res
|
||||
allocate (gain,STAT=func2) ! { dg-error "Expected VARIABLE" }
|
||||
deallocate(gain)
|
||||
res = 0
|
||||
end function func2
|
||||
|
||||
subroutine sub()
|
||||
implicit none
|
||||
interface
|
||||
integer function func2()
|
||||
end function
|
||||
end interface
|
||||
real, pointer :: gain
|
||||
integer, parameter :: res = 2
|
||||
allocate (gain,STAT=func2) ! { dg-error "STAT expression at .1. must be a variable" }
|
||||
deallocate(gain)
|
||||
end subroutine sub
|
||||
|
||||
module test
|
||||
contains
|
||||
function one()
|
||||
integer :: one, two
|
||||
integer, pointer :: ptr
|
||||
allocate(ptr, stat=one)
|
||||
if(one == 0) deallocate(ptr)
|
||||
entry two
|
||||
allocate(ptr, stat=two)
|
||||
if(associated(ptr)) deallocate(ptr)
|
||||
end function one
|
||||
subroutine sub()
|
||||
integer, pointer :: p
|
||||
allocate(p, stat=one) ! { dg-error "STAT expression at .1. must be a variable" }
|
||||
if(associated(p)) deallocate(p)
|
||||
allocate(p, stat=two) ! { dg-error "STAT expression at .1. must be a variable" }
|
||||
if(associated(p)) deallocate(p)
|
||||
end subroutine sub
|
||||
end module test
|
Loading…
Reference in New Issue