re PR fortran/34714 (ICE-on-invalid in gfc_conv_descriptor_dtype)

gcc/fortran:
2008-03-28  Daniel Franke  <franke.daniel@gmail.com>
            Paul Richard Thomas <paul.richard.thomas@gmail.com>

	PR fortran/34714
        * primary.c (match_variable): Improved matching of function
        result variables.
        * resolve.c (resolve_allocate_deallocate): Removed checks if
        the actual argument for STAT is a variable.

gcc/testsuite:
2008-03-28  Daniel Franke  <franke.daniel@gmail.com>

        PR fortran/34714
        * gfortran.dg/alloc_alloc_expr_3.f90: New test.
        * gfortran.dg/allocate_stat.f90: Adjusted error-match text.
        * gfortran.dg/func_assign.f90: Likewise.
        * gfortran.dg/implicit_11.f90: Likewise.
        * gfortran.dg/proc_assign_1.f90: Likewise.
        * gfortran.dg/proc_assign_2.f90: Likewise.
        * gfortran.dg/procedure_lvalue.f90: Likewise.

Co-Authored-By: Paul Richard Thomas <paul.richard.thomas@gmail.com>
From-SVN: r133701

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5731e2017c9abb87ae1426ebf259d2cca8d3ab60..06589954ead61fb0877a9d80b4c8b99954625d4b 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2008-03-28  Daniel Franke  <franke.daniel@gmail.com>
+           Paul Richard Thomas <paul.richard.thomas@gmail.com>
+
+       PR fortran/34714
+       * primary.c (match_variable): Improved matching of function 
+       result variables.
+       * resolve.c (resolve_allocate_deallocate): Removed checks if
+       the actual argument for STAT is a variable.
+
 2008-03-28  Tobias Burnus  <burnus@net-b.de>
 
        * symbol.c (gfc_get_default_type): Fix error message; option

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index f6b163503b346dae875fdaded7a072b522939864..8f85873ce0316d5d471397013c697f9f69dd8f6d 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2561,8 +2561,18 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
       break;
 
     case FL_PROCEDURE:
-      /* Check for a nonrecursive function result */
-      if (sym->attr.function && sym->result == sym && !sym->attr.external)
+      /* Check for a nonrecursive function result variable.  */
+      if (sym->attr.function
+          && !sym->attr.external
+          && sym->result == sym
+          && ((sym == gfc_current_ns->proc_name
+               && sym == gfc_current_ns->proc_name->result)
+              || (gfc_current_ns->parent
+                  && sym == gfc_current_ns->parent->proc_name->result)
+              || (sym->attr.entry
+                  && sym->ns == gfc_current_ns)
+              || (sym->attr.entry
+                  && sym->ns == gfc_current_ns->parent)))
        {
          /* If a function result is a derived type, then the derived
             type may still have to be resolved.  */

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0d39b2df8496aa2505307634be28f8935349b795..41b1addbab334b838c3d952b6fc78b6db963fe4e 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4878,7 +4878,6 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
 {
   gfc_symbol *s = NULL;
   gfc_alloc *a;
-  bool is_variable;
 
   if (code->expr)
     s = code->expr->symtree->n.sym;
@@ -4892,45 +4891,6 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
       if (gfc_pure (NULL) && gfc_impure_variable (s))
        gfc_error ("Illegal STAT variable in %s statement at %C "
                   "for a PURE procedure", fcn);
-
-      is_variable = false;
-      if (s->attr.flavor == FL_VARIABLE)
-       is_variable = true;
-      else if (s->attr.function && s->result == s
-                && (gfc_current_ns->proc_name == s
-                       ||
-                   (gfc_current_ns->parent
-                      && gfc_current_ns->parent->proc_name == s)))
-       is_variable = true;
-      else if (gfc_current_ns->entries && s->result == s)
-       {
-         gfc_entry_list *el;
-         for (el = gfc_current_ns->entries; el; el = el->next)
-           if (el->sym == s)
-             {
-               is_variable = true;
-             }
-       }
-      else if (gfc_current_ns->parent && gfc_current_ns->parent->entries
-                && s->result == s)
-       {
-         gfc_entry_list *el;
-         for (el = gfc_current_ns->parent->entries; el; el = el->next)
-           if (el->sym == s)
-             {
-               is_variable = true;
-             }
-       }
-
-      if (s->attr.flavor == FL_UNKNOWN
-           && gfc_add_flavor (&s->attr, FL_VARIABLE,
-                              s->name, NULL) == SUCCESS)
-       is_variable = true;
-
-      if (!is_variable)
-       gfc_error ("STAT tag in %s statement at %L must be "
-                  "a variable", fcn, &code->expr->where);
-
     }
 
   if (s && code->expr->ts.type != BT_INTEGER)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a42d59f228ed0a01848a94a107a1e46cde124e9b..468a4dbefd1d7feded19bfe6110b2e35c880de6b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,14 @@
+2008-03-28  Daniel Franke  <franke.daniel@gmail.com>
+
+       PR fortran/34714
+       * gfortran.dg/alloc_alloc_expr_3.f90: New test.
+       * gfortran.dg/allocate_stat.f90: Adjusted error-match text.
+       * gfortran.dg/func_assign.f90: Likewise.
+       * gfortran.dg/implicit_11.f90: Likewise.
+       * gfortran.dg/proc_assign_1.f90: Likewise.
+       * gfortran.dg/proc_assign_2.f90: Likewise.
+       * gfortran.dg/procedure_lvalue.f90: Likewise.
+
 2008-03-28  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
        PR fortran/35699

diff --git a/gcc/testsuite/gfortran.dg/alloc_alloc_expr_3.f90 b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_3.f90
new file mode 100644 (file)
index 0000000..13b2230
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/alloc_alloc_expr_3.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+!
+! PR fortran/34714 - ICE on invalid
+! Testcase contributed by Martin Reinecke <martin AT mpa-garching DOT mpg DOT de>
+!
+
+module foo
+  type bar
+    logical, pointer, dimension(:) :: baz
+  end type
+contains
+
+function func1()
+  type(bar) func1
+  allocate(func1%baz(1))
+end function
+
+function func2()
+  type(bar) func2
+  allocate(func1%baz(1))      ! { dg-error "is not a variable" }
+end function
+
+end module foo
+
+! { dg-final { cleanup-modules "foo" } }

diff --git a/gcc/testsuite/gfortran.dg/allocate_stat.f90 b/gcc/testsuite/gfortran.dg/allocate_stat.f90
index 76626f822bc2863c601955fb13e089cbe38547ba..7f9eaf58d6d0dffe78ef56dfb949fa9f3f655a80 100644 (file)
--- a/gcc/testsuite/gfortran.dg/allocate_stat.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_stat.f90
@@ -51,7 +51,7 @@ subroutine sub()
   end interface
   real, pointer :: gain 
   integer, parameter :: res = 2
-  allocate (gain,STAT=func2) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+  allocate (gain,STAT=func2) ! { dg-error "is not a variable" }
   deallocate(gain)
 end subroutine sub
 
@@ -68,9 +68,9 @@ contains
  end function one
  subroutine sub()
    integer, pointer :: p
-   allocate(p, stat=one) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+   allocate(p, stat=one) ! { dg-error "is not a variable" }
    if(associated(p)) deallocate(p)
-   allocate(p, stat=two) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
+   allocate(p, stat=two) ! { dg-error "is not a variable" }
    if(associated(p)) deallocate(p)
  end subroutine sub
 end module test

diff --git a/gcc/testsuite/gfortran.dg/func_assign.f90 b/gcc/testsuite/gfortran.dg/func_assign.f90
index 1f7407c7ccfe892fd2b302ae2d89c6852cf32528..7ecf32941ca737eca0c58988bc3438fac2f9d7bf 100644 (file)
--- a/gcc/testsuite/gfortran.dg/func_assign.f90
+++ b/gcc/testsuite/gfortran.dg/func_assign.f90
@@ -25,8 +25,8 @@ contains
    end interface
    sub = 'a'  ! { dg-error "is not a variable" }
    fun = 4.4  ! { dg-error "is not a variable" }
-   funget = 4 ! { dg-error "is not a VALUE" }
-   bar = 5    ! { dg-error "is not a VALUE" }
+   funget = 4 ! { dg-error "is not a variable" }
+   bar = 5    ! { dg-error "is not a variable" }
   end subroutine a
 end module mod
 

diff --git a/gcc/testsuite/gfortran.dg/implicit_11.f90 b/gcc/testsuite/gfortran.dg/implicit_11.f90
index 26cf5ae8795a938463445a1ee967157dead4484e..d33acd10a41f66aad470c06843a3c66ed177a2a7 100644 (file)
--- a/gcc/testsuite/gfortran.dg/implicit_11.f90
+++ b/gcc/testsuite/gfortran.dg/implicit_11.f90
@@ -31,7 +31,7 @@
      SUBROUTINE AD0001
        REAL RLA1(:)
        ALLOCATABLE RLA1
-       ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "must be a variable" }
+       ALLOCATE (RLA1(NF10), STAT = ISTAT2) ! { dg-error "is not a variable" }
      END SUBROUTINE
      END MODULE tests2
 

diff --git a/gcc/testsuite/gfortran.dg/proc_assign_1.f90 b/gcc/testsuite/gfortran.dg/proc_assign_1.f90
index 9f2952b5d03d848aa177a32fafbcd600969d413d..919089acb425443683c18ce6b67a6a9ae1836886 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_assign_1.f90
+++ b/gcc/testsuite/gfortran.dg/proc_assign_1.f90
@@ -30,11 +30,11 @@ contains
         end subroutine foobar\r
     end function foo\r
     subroutine bar()         ! This was the original bug.\r
-        foo = 10             ! { dg-error "is not a VALUE" }\r
+        foo = 10             ! { dg-error "is not a variable" }\r
     end subroutine bar\r
     integer function oh_no ()\r
         oh_no = 1\r
-        foo = 5              ! { dg-error "is not a VALUE" }\r
+        foo = 5              ! { dg-error "is not a variable" }\r
     end function oh_no\r
 end module simple\r
 \r
@@ -59,16 +59,16 @@ end module simpler
     stmt_fcn (w) = sin (w)     \r
     call x (y ())\r
     x = 10                   ! { dg-error "is not a variable" }\r
-    y = 20                   ! { dg-error "is not a VALUE" }\r
-    foo_er = 8               ! { dg-error "is not a VALUE" }\r
-    ext1 = 99                ! { dg-error "is not a VALUE" }\r
-    ext2 = 99                ! { dg-error "is not a VALUE" }\r
+    y = 20                   ! { dg-error "is not a variable" }\r
+    foo_er = 8               ! { dg-error "is not a variable" }\r
+    ext1 = 99                ! { dg-error "is not a variable" }\r
+    ext2 = 99                ! { dg-error "is not a variable" }\r
     stmt_fcn = 1.0           ! { dg-error "is not a variable" }\r
     w = stmt_fcn (1.0)\r
 contains\r
     subroutine x (i)\r
         integer i\r
-        y = i                ! { dg-error "is not a VALUE" }\r
+        y = i                ! { dg-error "is not a variable" }\r
     end subroutine x\r
     function y ()\r
         integer y\r

diff --git a/gcc/testsuite/gfortran.dg/proc_assign_2.f90 b/gcc/testsuite/gfortran.dg/proc_assign_2.f90
index 5a92be5cabce40d565f284280c9cf926ccc1fe69..8f313c58fa31908757bdf663d2e68680740a81e0 100644 (file)
--- a/gcc/testsuite/gfortran.dg/proc_assign_2.f90
+++ b/gcc/testsuite/gfortran.dg/proc_assign_2.f90
@@ -14,7 +14,7 @@ CONTAINS
     END FUNCTION
 
     LOGICAL FUNCTION f2()
-      f1 = .FALSE.  ! { dg-error "not a VALUE" }
+      f1 = .FALSE.  ! { dg-error "is not a variable" }
     END FUNCTION
   END FUNCTION
 END MODULE

diff --git a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90 b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
index 634eaca0e27e1814174e3ad0599e5dfd33c5e5f7..741dc8c34a3fa36556c124aa7bba4422c42e5666 100644 (file)
--- a/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
+++ b/gcc/testsuite/gfortran.dg/procedure_lvalue.f90
@@ -14,7 +14,7 @@ end module t
 
 subroutine r
   use t
-  b = 1.       ! { dg-error "is not a VALUE" }
+  b = 1.       ! { dg-error "is not a variable" }
   y = a(1.)
 end subroutine r