re PR fortran/56852 (ICE on invalid: "Bad array reference" for an undeclared loop variable)

2013-04-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/56852
	* primary.c (gfc_variable_attr): Avoid ICE on AR_UNKNOWN if any
	of the index variables are untyped and errors are present.

2013-04-09  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/56852
	* gfortran.dg/pr56852.f90 : New test

From-SVN: r221955

4 files changed, 60 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f7b1d38..78305a0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-04-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/56852
+	* primary.c (gfc_variable_attr): Avoid ICE on AR_UNKNOWN if any
+	of the index variables are untyped and errors are present.
+
 2015-04-07  Andre Vehreschild  <vehre@gmx.de>
 
 	PR fortran/65548
@@ -63,7 +69,7 @@
 	then, which calls ->vptr->copy () with four arguments adding
 	the length information ->vptr->copy(from, to, from_len, to_cap).
 	(gfc_conv_procedure_call): Switch to new function name for
-	getting a class' vtab's field. 
+	getting a class' vtab's field.
 	(alloc_scalar_allocatable_for_assignment): Use the string_length
 	as computed by gfc_conv_expr and not the statically backend_decl
 	which may be incorrect when ref-ing.
@@ -88,7 +94,7 @@
 	Added gfc_find_and_cut_at_last_class_ref () and
 	gfc_reset_len () routine prototype.  Added flag to
 	gfc_copy_class_to_class () prototype to signal an unlimited
-	polymorphic entity to copy.    
+	polymorphic entity to copy.
 
 2015-03-24  Iain Sandoe  <iain@codesourcery.com>
 	    Tobias Burnus  <burnus@net-b.de>
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 67a7f8a..e9ced7e 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -143,8 +143,8 @@ gfc_check_digit (char c, int radix)
 
 
 /* Match the digit string part of an integer if signflag is not set,
-   the signed digit string part if signflag is set.  If the buffer 
-   is NULL, we just count characters for the resolution pass.  Returns 
+   the signed digit string part if signflag is set.  If the buffer
+   is NULL, we just count characters for the resolution pass.  Returns
    the number of characters matched, -1 for no match.  */
 
 static int
@@ -192,7 +192,7 @@ match_digits (int signflag, int radix, char *buffer)
 }
 
 
-/* Match an integer (digit string and optional kind).  
+/* Match an integer (digit string and optional kind).
    A sign will be accepted if signflag is set.  */
 
 static match
@@ -259,7 +259,7 @@ match_hollerith_constant (gfc_expr **result)
   gfc_expr *e = NULL;
   const char *msg;
   int num, pad;
-  int i;  
+  int i;
 
   old_loc = gfc_current_locus;
   gfc_gobble_whitespace ();
@@ -518,7 +518,7 @@ match_real_constant (gfc_expr **result, int signflag)
 	  if (seen_dp)
 	    goto done;
 
-	  /* Check to see if "." goes with a following operator like 
+	  /* Check to see if "." goes with a following operator like
 	     ".eq.".  */
 	  temp_loc = gfc_current_locus;
 	  c = gfc_next_ascii_char ();
@@ -1504,7 +1504,7 @@ match_actual_arg (gfc_expr **result)
 
 	  if (sym->attr.in_common && !sym->attr.proc_pointer)
 	    {
-	      if (!gfc_add_flavor (&sym->attr, FL_VARIABLE, 
+	      if (!gfc_add_flavor (&sym->attr, FL_VARIABLE,
 				   sym->name, &sym->declared_at))
 		return MATCH_ERROR;
 	      break;
@@ -2138,7 +2138,7 @@ check_substring:
 symbol_attribute
 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 {
-  int dimension, codimension, pointer, allocatable, target;
+  int dimension, codimension, pointer, allocatable, target, n;
   symbol_attribute attr;
   gfc_ref *ref;
   gfc_symbol *sym;
@@ -2195,7 +2195,25 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
 	    break;
 
 	  case AR_UNKNOWN:
-	    gfc_internal_error ("gfc_variable_attr(): Bad array reference");
+	    /* If any of start, end or stride is not integer, there will
+	       already have been an error issued.  */
+	    for (n = 0; n < ref->u.ar.as->rank; n++)
+	      {
+		int errors;
+		gfc_get_errors (NULL, &errors);
+		if (((ref->u.ar.start[n]
+		      && ref->u.ar.start[n]->ts.type == BT_UNKNOWN)
+		     ||
+		     (ref->u.ar.end[n]
+		      && ref->u.ar.end[n]->ts.type == BT_UNKNOWN)
+		     ||
+		     (ref->u.ar.stride[n]
+		      && ref->u.ar.stride[n]->ts.type == BT_UNKNOWN))
+		    && errors > 0)
+		  break;
+	      }
+	    if (n == ref->u.ar.as->rank)
+	      gfc_internal_error ("gfc_variable_attr(): Bad array reference");
 	  }
 
 	break;
@@ -2347,8 +2365,8 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
 						      &gfc_current_locus);
 	  value->ts = comp->ts;
 
-	  if (!build_actual_constructor (comp_head, 
-					 &value->value.constructor, 
+	  if (!build_actual_constructor (comp_head,
+					 &value->value.constructor,
 					 comp->ts.u.derived))
 	    {
 	      gfc_free_expr (value);
@@ -2500,7 +2518,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
       actual->expr = NULL;
 
       /* Check if this component is already given a value.  */
-      for (comp_iter = comp_head; comp_iter != comp_tail; 
+      for (comp_iter = comp_head; comp_iter != comp_tail;
 	   comp_iter = comp_iter->next)
 	{
 	  gcc_assert (comp_iter);
@@ -2597,13 +2615,13 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
       expr->expr_type = EXPR_STRUCTURE;
     }
 
-  gfc_current_locus = old_locus; 
+  gfc_current_locus = old_locus;
   if (parent)
     *arglist = actual;
   return true;
 
   cleanup:
-  gfc_current_locus = old_locus; 
+  gfc_current_locus = old_locus;
 
   for (comp_iter = comp_head; comp_iter; )
     {
@@ -2770,7 +2788,7 @@ gfc_match_rvalue (gfc_expr **result)
 	      || sym->ns == gfc_current_ns->parent))
 	{
 	  gfc_entry_list *el = NULL;
-	  
+
 	  for (el = sym->ns->entries; el; el = el->next)
 	    if (sym == el->sym)
 	      goto variable;
@@ -2800,7 +2818,7 @@ gfc_match_rvalue (gfc_expr **result)
 
     case FL_PARAMETER:
       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
-	 end up here.  Unfortunately, sym->value->expr_type is set to 
+	 end up here.  Unfortunately, sym->value->expr_type is set to
 	 EXPR_CONSTANT, and so the if () branch would be followed without
 	 the !sym->as check.  */
       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
@@ -3058,7 +3076,7 @@ gfc_match_rvalue (gfc_expr **result)
       if (m2 != MATCH_YES)
 	{
 	  /* Try to figure out whether we're dealing with a character type.
-	     We're peeking ahead here, because we don't want to call 
+	     We're peeking ahead here, because we don't want to call
 	     match_substring if we're dealing with an implicitly typed
 	     non-character variable.  */
 	  implicit_char = false;
@@ -3079,7 +3097,7 @@ gfc_match_rvalue (gfc_expr **result)
 	      e->expr_type = EXPR_VARIABLE;
 
 	      if (sym->attr.flavor != FL_VARIABLE
-		  && !gfc_add_flavor (&sym->attr, FL_VARIABLE, 
+		  && !gfc_add_flavor (&sym->attr, FL_VARIABLE,
 				      sym->name, NULL))
 		{
 		  m = MATCH_ERROR;
@@ -3300,7 +3318,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	implicit_ns = gfc_current_ns;
       else
 	implicit_ns = sym->ns;
-	
+
       if (gfc_peek_ascii_char () == '%'
 	  && sym->ts.type == BT_UNKNOWN
 	  && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a44374f..da590b1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-04-09  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/56852
+	* gfortran.dg/pr56852.f90 : New test
+
 2015-04-09  Marek Polacek  <polacek@redhat.com>
 	    Jakub Jelinek  <jakub@redhat.com>
 
diff --git a/gcc/testsuite/gfortran.dg/pr56852.f90 b/gcc/testsuite/gfortran.dg/pr56852.f90
new file mode 100644
index 0000000..bdf76e1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr56852.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Test the fix for pr56852, where an ICE would occur after the error.
+!
+! Contributed by Lorenz Huedepohl  <bugs@stellardeath.org>
+!
+program test
+  implicit none
+  real :: a(4)
+  ! integer :: i
+  read(0) (a(i),i=1,4) ! { dg-error "has no IMPLICIT type" }
+end program