re PR fortran/32936 (ALLOCATE: "STAT expression ... must be a variable" - but it...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5729982bbadeb32b427fc9ec49ad44e49bf7148f..81bff2b42ca545fb75490cd14f8bca8146afd67a 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index d111d0fb38d919b584e5715b73f6b11951de2757..b615f7334cbd159b702b3af4f04d662f16e8f99d 100644 (file)
--- 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 2b379c3786da8d3172a0f0ebffd7cb6c931f976d..39e39af29a6a209473c7583dc8ddbfbb0bde3751 100644 (file)
--- 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 13be84a8da8c500dea1254400cafbb471ead141d..0755f4f73d05fcff12de77ed5b625c1340b14b0c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.

diff --git a/gcc/testsuite/gfortran.dg/allocate_stat.f90 b/gcc/testsuite/gfortran.dg/allocate_stat.f90
new file mode 100644 (file)
index 0000000..1361d77
--- /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