re PR fortran/32760 (Error defining subroutine named PRINT)

2008-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/32760
	* resolve.c (resolve_allocate_deallocate): New function.
	(resolve_code): Call it for allocate and deallocate.
	* match.c (gfc_match_allocate, gfc_match_deallocate) : Remove
	the checking of the STAT tag and put in above new function.
	* primary,c (match_variable): Do not fix flavor of host
	associated symbols yet if the type is not known.

2008-02-03  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/32760
	* gfortran.dg/host_assoc_variable_1.f90: New test.
	* gfortran.dg/allocate_stat.f90: Change last three error messages.

From-SVN: r132078

gcc/fortran/ChangeLog

+2008-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32760
+	* resolve.c (resolve_allocate_deallocate): New function.
+	(resolve_code): Call it for allocate and deallocate.
+	* match.c (gfc_match_allocate, gfc_match_deallocate) : Remove
+	the checking of the STAT tag and put in above new function.
+	* primary,c (match_variable): Do not fix flavor of host
+	associated symbols yet if the type is not known.
+
 2008-01-31  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/34910

gcc/fortran/match.c

@@ -2235,62 +2235,7 @@ 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 "
-		     "be INTENT(IN)", stat->symtree->n.sym->name);
-	  goto cleanup;
-	}
-
-      if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
-	{
-	  gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
-		     "for a PURE procedure");
-	  goto cleanup;
-	}
-
-      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;
-	}
-
-      gfc_check_do_variable(stat->symtree);
-    }
+    gfc_check_do_variable(stat->symtree);
 
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;
@@ -2432,29 +2377,7 @@ gfc_match_deallocate (void)
     }
 
   if (stat != NULL)
-    {
-      if (stat->symtree->n.sym->attr.intent == INTENT_IN)
-	{
-	  gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
-		     "cannot be INTENT(IN)", stat->symtree->n.sym->name);
-	  goto cleanup;
-	}
-
-      if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
-	{
-	  gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
-		     "for a PURE procedure");
-	  goto cleanup;
-	}
-
-      if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
-	{
-	  gfc_error ("STAT expression at %C must be a variable");
-	  goto cleanup;
-	}
-
-      gfc_check_do_variable(stat->symtree);
-    }
+    gfc_check_do_variable(stat->symtree);
 
   if (gfc_match (" )%t") != MATCH_YES)
     goto syntax;

gcc/fortran/primary.c

@@ -2534,6 +2534,14 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	if (sym->attr.external || sym->attr.procedure
 	    || sym->attr.function || sym->attr.subroutine)
 	  flavor = FL_PROCEDURE;
+
+	/* If it is not a procedure, is not typed and is host associated,
+	   we cannot give it a flavor yet.  */
+	else if (sym->ns == gfc_current_ns->parent
+		   && sym->ts.type == BT_UNKNOWN)
+	  break;
+
+	/* These are definitive indicators that this is a variable.  */
 	else if (gfc_peek_char () != '(' || sym->ts.type != BT_UNKNOWN
 		 || sym->attr.pointer || sym->as != NULL)
 	  flavor = FL_VARIABLE;

gcc/fortran/resolve.c

@@ -4864,6 +4864,81 @@ check_symbols:
   return SUCCESS;
 }
 
+static void
+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;
+
+  if (s)
+    {
+      if (s->attr.intent == INTENT_IN)
+	gfc_error ("STAT variable '%s' of %s statement at %C cannot "
+		   "be INTENT(IN)", s->name, 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)
+	gfc_error ("STAT tag in %s statement at %L must be "
+		       "of type INTEGER", fcn, &code->expr->where);
+
+  if (strcmp (fcn, "ALLOCATE") == 0)
+    {
+      for (a = code->ext.alloc_list; a; a = a->next)
+	resolve_allocate_expr (a->expr, code);
+    }
+  else
+    {
+      for (a = code->ext.alloc_list; a; a = a->next)
+	resolve_deallocate_expr (a->expr);
+    }
+}
 
 /************ SELECT CASE resolution subroutines ************/
 
@@ -6090,7 +6165,6 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
   int omp_workshare_save;
   int forall_save;
   code_stack frame;
-  gfc_alloc *a;
   try t;
 
   frame.prev = cs_base;
@@ -6275,25 +6349,14 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	  break;
 
 	case EXEC_ALLOCATE:
-	  if (t == SUCCESS && code->expr != NULL
-	      && code->expr->ts.type != BT_INTEGER)
-	    gfc_error ("STAT tag in ALLOCATE statement at %L must be "
-		       "of type INTEGER", &code->expr->where);
-
-	  for (a = code->ext.alloc_list; a; a = a->next)
-	    resolve_allocate_expr (a->expr, code);
+	  if (t == SUCCESS)
+	    resolve_allocate_deallocate (code, "ALLOCATE");
 
 	  break;
 
 	case EXEC_DEALLOCATE:
-	  if (t == SUCCESS && code->expr != NULL
-	      && code->expr->ts.type != BT_INTEGER)
-	    gfc_error
-	      ("STAT tag in DEALLOCATE statement at %L must be of type "
-	       "INTEGER", &code->expr->where);
-
-	  for (a = code->ext.alloc_list; a; a = a->next)
-	    resolve_deallocate_expr (a->expr);
+	  if (t == SUCCESS)
+	    resolve_allocate_deallocate (code, "DEALLOCATE");
 
 	  break;
 

gcc/testsuite/ChangeLog

+2008-02-03  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/32760
+	* gfortran.dg/host_assoc_variable_1.f90: New test.
+	* gfortran.dg/allocate_stat.f90: Change last three error messages.
+
 2008-02-02  Michael Matz  <matz@suse.de>
 
 	PR target/35045

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 expression at .1. must be a variable" }
+  allocate (gain,STAT=func2) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be 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 expression at .1. must be a variable" }
+   allocate(p, stat=one) ! { dg-error "STAT tag in ALLOCATE statement 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" }
+   allocate(p, stat=two) ! { dg-error "STAT tag in ALLOCATE statement at .1. must be a variable" }
    if(associated(p)) deallocate(p)
  end subroutine sub
 end module test

gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90

+! { dg-do compile }
+! This tests that PR32760, in its various manifestations is fixed.
+!
+! Contributed by Harald Anlauf <anlauf@gmx.de>
+!
+! This is the original bug - the frontend tried to fix the flavor of
+! 'PRINT' too early so that the compile failed on the subroutine 
+! declaration.
+!
+module gfcbug68
+  implicit none
+  public :: print
+contains
+  subroutine foo (i)
+    integer, intent(in)  :: i
+    print *, i
+  end subroutine foo
+  subroutine print (m)
+    integer, intent(in) :: m
+  end subroutine print
+end module gfcbug68
+
+! This version of the bug appears in comment # 21.
+!
+module m
+  public :: volatile
+contains
+  subroutine foo
+    volatile :: bar
+  end subroutine foo
+  subroutine volatile
+  end subroutine volatile
+end module
+
+! This was a problem with the resolution of the STAT parameter in 
+! ALLOCATE and DEALLOCATE that was exposed in comment #25.
+!
+module n
+  public :: integer
+  private :: istat
+contains
+  subroutine foo
+    integer, allocatable :: s(:), t(:)
+    allocate(t(5))
+    allocate(s(4), stat=istat)
+  end subroutine foo
+  subroutine integer()
+  end subroutine integer
+end module n
+
+! This is the version of the bug in comment #12 of the PR.
+!
+module gfcbug68a
+  implicit none
+  public :: write
+contains
+  function foo (i)
+    integer, intent(in)  :: i
+    integer foo
+    write (*,*) i
+    foo = i
+  end function foo
+  subroutine write (m)
+    integer, intent(in) :: m
+    print *, m*m*m
+  end subroutine write
+end module gfcbug68a
+
+program testit
+  use gfcbug68a
+  integer :: i = 27
+  integer :: k
+  k = foo(i)
+  print *, "in the main:", k
+  call write(33)
+end program testit
+! { dg-final { cleanup-modules "gfcbug68 gfcbug68a m n" } }