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

gcc/fortran/ChangeLog

+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

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.  */

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)

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/alloc_alloc_expr_3.f90

+! { 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" } }

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

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
 

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
 

gcc/testsuite/gfortran.dg/proc_assign_1.f90

@@ -30,11 +30,11 @@ contains
         end subroutine foobar
     end function foo
     subroutine bar()         ! This was the original bug.
-        foo = 10             ! { dg-error "is not a VALUE" }
+        foo = 10             ! { dg-error "is not a variable" }
     end subroutine bar
     integer function oh_no ()
         oh_no = 1
-        foo = 5              ! { dg-error "is not a VALUE" }
+        foo = 5              ! { dg-error "is not a variable" }
     end function oh_no
 end module simple
 
@@ -59,16 +59,16 @@ end module simpler
     stmt_fcn (w) = sin (w)     
     call x (y ())
     x = 10                   ! { dg-error "is not a variable" }
-    y = 20                   ! { dg-error "is not a VALUE" }
-    foo_er = 8               ! { dg-error "is not a VALUE" }
-    ext1 = 99                ! { dg-error "is not a VALUE" }
-    ext2 = 99                ! { dg-error "is not a VALUE" }
+    y = 20                   ! { dg-error "is not a variable" }
+    foo_er = 8               ! { dg-error "is not a variable" }
+    ext1 = 99                ! { dg-error "is not a variable" }
+    ext2 = 99                ! { dg-error "is not a variable" }
     stmt_fcn = 1.0           ! { dg-error "is not a variable" }
     w = stmt_fcn (1.0)
 contains
     subroutine x (i)
         integer i
-        y = i                ! { dg-error "is not a VALUE" }
+        y = i                ! { dg-error "is not a variable" }
     end subroutine x
     function y ()
         integer y

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

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