re PR fortran/28866 (Simple if statements are not so simple)

2006-08-29  Steven G. Kargl  <kargls@comcast.net>

	PR fortran/28866
	* match.c: Wrap copyright.
	(gfc_match_assignment):  Return MATCH_NO for failed lvalue.  Remove
	gotos.  Move error handling of FL_PARAMETER to ...
 	* gfc_match_if: Deal with MATCH_NO from above.
	* primary.c: Wrap copyright.
	(match_variable): ... here.  Improve error messages.


2006-08-29  Steven G. Kargl  <kargls@comcast.net>

	PR fortran/28866
	* gfortran.dg/simpleif_2.f90: New test.
	* gfortran.dg/pr19936_1.f90: Adjust dg-error message.
	* gfortran.dg/enum_5.f90: Ditto.

From-SVN: r116570

gcc/fortran/ChangeLog

+2006-08-29  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/28866
+	* match.c: Wrap copyright.
+	(gfc_match_assignment):  Return MATCH_NO for failed lvalue.  Remove
+	gotos.  Move error handling of FL_PARAMETER to ...
+ 	* gfc_match_if: Deal with MATCH_NO from above.
+	* primary.c: Wrap copyright.
+	(match_variable): ... here.  Improve error messages.
+
 2006-08-29  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/28788

gcc/fortran/match.c

 /* Matching subroutines in all sizes, shapes and colors.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
-   Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
+   Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -843,21 +843,24 @@ gfc_match_assignment (void)
 
   old_loc = gfc_current_locus;
 
-  lvalue = rvalue = NULL;
+  lvalue = NULL;
   m = gfc_match (" %v =", &lvalue);
   if (m != MATCH_YES)
-    goto cleanup;
-
-  if (lvalue->symtree->n.sym->attr.flavor == FL_PARAMETER)
     {
-      gfc_error ("Cannot assign to a PARAMETER variable at %C");
-      m = MATCH_ERROR;
-      goto cleanup;
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+      return MATCH_NO;
     }
 
+  rvalue = NULL;
   m = gfc_match (" %e%t", &rvalue);
   if (m != MATCH_YES)
-    goto cleanup;
+    {
+      gfc_current_locus = old_loc;
+      gfc_free_expr (lvalue);
+      gfc_free_expr (rvalue);
+      return m;
+    }
 
   gfc_set_sym_referenced (lvalue->symtree->n.sym);
 
@@ -868,12 +871,6 @@ gfc_match_assignment (void)
   gfc_check_do_variable (lvalue->symtree);
 
   return MATCH_YES;
-
-cleanup:
-  gfc_current_locus = old_loc;
-  gfc_free_expr (lvalue);
-  gfc_free_expr (rvalue);
-  return m;
 }
 
 
@@ -1061,9 +1058,9 @@ gfc_match_if (gfc_statement * if_type)
   gfc_undo_symbols ();
   gfc_current_locus = old_loc;
 
-  /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_NO, continue to
-     call the various matchers.  For MATCH_ERROR, a mangled assignment
-     was found.  */
+  /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
+     assignment was found.  For MATCH_NO, continue to call the various
+     matchers.  */
   if (m == MATCH_ERROR)
     return MATCH_ERROR;
 
@@ -1114,6 +1111,19 @@ gfc_match_if (gfc_statement * if_type)
   match ("where", match_simple_where, ST_WHERE)
   match ("write", gfc_match_write, ST_WRITE)
 
+  /* The gfc_match_assignment() above may have returned a MATCH_NO
+     where the assignement was to a named constant.  Check that 
+     special case here.  */
+  m = gfc_match_assignment ();
+  if (m == MATCH_NO)
+   {
+      gfc_error ("Cannot assign to a named constant at %C");
+      gfc_free_expr (expr);
+      gfc_undo_symbols ();
+      gfc_current_locus = old_loc;
+      return MATCH_ERROR;
+   }
+
   /* All else has failed, so give up.  See if any of the matchers has
      stored an error message of some sort.  */
     if (gfc_error_check () == 0)

gcc/fortran/primary.c

 /* Primary expression subroutines
-   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006 Free Software
-   Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006
+   Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -2295,16 +2295,20 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
     case FL_VARIABLE:
       break;
 
-    case FL_PROGRAM:
-      return MATCH_NO;
-      break;
-
     case FL_UNKNOWN:
       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
 			  sym->name, NULL) == FAILURE)
 	return MATCH_ERROR;
       break;
 
+    case FL_PARAMETER:
+      if (equiv_flag)
+	gfc_error ("Named constant at %C in an EQUIVALENCE");
+      else
+	gfc_error ("Cannot assign to a named constant at %C");
+      return MATCH_ERROR;
+      break;
+
     case FL_PROCEDURE:
       /* Check for a nonrecursive function result */
       if (sym->attr.function && (sym->result == sym || sym->attr.entry))

gcc/testsuite/ChangeLog

+2006-08-29  Steven G. Kargl  <kargls@comcast.net>
+
+	PR fortran/28866
+	* gfortran.dg/simpleif_2.f90: New test.
+	* gfortran.dg/pr19936_1.f90: Adjust dg-error message.
+	* gfortran.dg/enum_5.f90: Ditto.
+
 2006-08-29  Volker Reichelt  <reichelt@igpm.rwth-aachen.de>
 	    Kazu Hirata  <kazu@codesourcery.com>
 

gcc/testsuite/gfortran.dg/enum_5.f90

@@ -10,6 +10,6 @@ program main
     enumerator :: blue = 1  
   end enum junk  ! { dg-error "Syntax error" }
 
-  blue = 10  ! { dg-error "Expected VARIABLE" }
+  blue = 10  ! { dg-error " assign to a named constant" }
 
 end program main  ! { dg-excess-errors "" }

gcc/testsuite/gfortran.dg/pr19936_1.f90

 ! { dg-do compile }
 program pr19936_1
   integer, parameter :: i=4
-  print *,(/(i,i=1,4)/) ! { dg-error "Expected VARIABLE" }
+  print *,(/(i,i=1,4)/) ! { dg-error "assign to a named constant" }
 end program pr19936_1

gcc/testsuite/gfortran.dg/simpleif_2.f90

 ! { dg-do compile }
-! PR 27981
-program a
-   real x
-   real, pointer :: y
-   if (.true.) x = 12345678901 ! { dg-error "Integer too big" }
-end program a
+! Test fix for regression caused by 
+! 2006-06-23  Steven G. Kargl  <kargls@comcast.net>
+!    PR fortran/27981
+!    * match.c (gfc_match_if):  Handle errors in assignment in simple if.
+!
+module read
+  integer i, j, k
+  contains
+    subroutine a
+      integer, parameter :: n = 2
+      if (i .eq. 0) read(j,*) k
+      if (i .eq. 0) n = j    ! { dg-error "assign to a named constant" "" }
+    end subroutine a
+end module read