From: burnus Date: Wed, 1 Aug 2007 17:55:24 +0000 (+0000) Subject: 2007-08-01 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=commitdiff_plain;h=03a36ba087ba2252140023a085ccaa9dad97d03e 2007-08-01 Tobias Burnus 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 PR fortran/32936 * gfortran.dg/allocate_stat.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127135 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5729982bbad..81bff2b42ca 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2007-08-01 Tobias Burnus + + 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 * arith.c: Change copyright header to refer to version 3 of the diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index d111d0fb38d..b615f7334cb 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; } diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2b379c3786d..39e39af29a6 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 13be84a8da8..0755f4f73d0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-08-01 Tobias Burnus + + PR fortran/32936 + * gfortran.dg/allocate_stat.f90: New. + 2007-08-01 Nathan Froyd * gcc.target/i386/pr23098.c: XFAIL on vxworks targets. diff --git a/gcc/testsuite/gfortran.dg/allocate_stat.f90 b/gcc/testsuite/gfortran.dg/allocate_stat.f90 new file mode 100644 index 00000000000..1361d779226 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_stat.f90 @@ -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