OSDN Git Service

gcc/fortran:
authordfranke <dfranke@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 28 Mar 2008 22:57:25 +0000 (22:57 +0000)
committerdfranke <dfranke@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 28 Mar 2008 22:57:25 +0000 (22:57 +0000)
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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133701 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/primary.c
gcc/fortran/resolve.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/alloc_alloc_expr_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/allocate_stat.f90
gcc/testsuite/gfortran.dg/func_assign.f90
gcc/testsuite/gfortran.dg/implicit_11.f90
gcc/testsuite/gfortran.dg/proc_assign_1.f90
gcc/testsuite/gfortran.dg/proc_assign_2.f90
gcc/testsuite/gfortran.dg/procedure_lvalue.f90

index 5731e20..0658995 100644 (file)
@@ -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
index f6b1635..8f85873 100644 (file)
@@ -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.  */
index 0d39b2d..41b1add 100644 (file)
@@ -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)
index a42d59f..468a4db 100644 (file)
@@ -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
@@ -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" } }
index 76626f8..7f9eaf5 100644 (file)
@@ -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
index 1f7407c..7ecf329 100644 (file)
@@ -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
 
index 26cf5ae..d33acd1 100644 (file)
@@ -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
 
index 9f2952b..919089a 100644 (file)
@@ -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
index 5a92be5..8f313c5 100644 (file)
@@ -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
index 634eaca..741dc8c 100644 (file)
@@ -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