This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, fortran] PR32760 - [4.3 Regression] Error defining subroutine named PRINT


:ADDPATCH fortran:

The fix for this patch was dominated by something that was a bit
peripheral to the original problem.  The original problem was that
match_variable would attempt to patch up the flavor of host associated
symbols too early.  Whilst this could have been fixed up, it is better
to delay to resolution.

The extra bit was due to the STAT tag of allocate/deallocate being
resolved too early; ie. just after matching.  The fix is in principle
the same as that above; delay until resolution.  The difference is
that fixing this necessitated moving the code, lock stock and barrel,
to resolve.c.

The testcase is that of the reporter and the comments #12, #21 and
#25.  In addition, three of the error messages in alloc_stat.f90
changed slightly.

Bootstrapped and regtested on x86_ia64/FC8 - OK for trunk?

Paul

2008-02-02  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-02  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.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 131984)
--- gcc/fortran/resolve.c	(working copy)
*************** check_symbols:
*** 4864,4869 ****
--- 4864,4944 ----
    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 ************/
  
*************** resolve_code (gfc_code *code, gfc_namesp
*** 6090,6096 ****
    int omp_workshare_save;
    int forall_save;
    code_stack frame;
-   gfc_alloc *a;
    try t;
  
    frame.prev = cs_base;
--- 6165,6170 ----
*************** resolve_code (gfc_code *code, gfc_namesp
*** 6275,6299 ****
  	  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);
  
  	  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);
  
  	  break;
  
--- 6349,6362 ----
  	  break;
  
  	case EXEC_ALLOCATE:
! 	  if (t == SUCCESS)
! 	    resolve_allocate_deallocate (code, "ALLOCATE");
  
  	  break;
  
  	case EXEC_DEALLOCATE:
! 	  if (t == SUCCESS)
! 	    resolve_allocate_deallocate (code, "DEALLOCATE");
  
  	  break;
  
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c	(revision 131984)
--- gcc/fortran/match.c	(working copy)
*************** gfc_match_allocate (void)
*** 2235,2296 ****
      }
  
    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);
!     }
  
    if (gfc_match (" )%t") != MATCH_YES)
      goto syntax;
--- 2235,2241 ----
      }
  
    if (stat != NULL)
!     gfc_check_do_variable(stat->symtree);
  
    if (gfc_match (" )%t") != MATCH_YES)
      goto syntax;
*************** gfc_match_deallocate (void)
*** 2432,2460 ****
      }
  
    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);
!     }
  
    if (gfc_match (" )%t") != MATCH_YES)
      goto syntax;
--- 2377,2383 ----
      }
  
    if (stat != NULL)
!     gfc_check_do_variable(stat->symtree);
  
    if (gfc_match (" )%t") != MATCH_YES)
      goto syntax;
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 131984)
--- gcc/fortran/primary.c	(working copy)
*************** match_variable (gfc_expr **result, int e
*** 2534,2539 ****
--- 2534,2547 ----
  	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;
Index: gcc/testsuite/gfortran.dg/allocate_stat.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocate_stat.f90	(revision 131984)
--- gcc/testsuite/gfortran.dg/allocate_stat.f90	(working copy)
*************** subroutine sub()
*** 51,57 ****
    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
  
--- 51,57 ----
    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" }
    deallocate(gain)
  end subroutine sub
  
*************** contains
*** 68,76 ****
   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
--- 68,76 ----
   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" }
     if(associated(p)) deallocate(p)
!    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
Index: gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/host_assoc_variable_1.f90	(revision 0)
***************
*** 0 ****
--- 1,77 ----
+ ! { 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" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]