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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f7b1d38d654143b38cc25606f5f7def317cf7483..78305a0f7bd0d5ff20f2ce6347f31ebaf3aa0f7c 100644 (file)
--- 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 67a7f8a99b3ad37bf1744e280ae690e06b79631e..e9ced7e6f718d9ea7a9eebab68a136c6a258b856 100644 (file)
--- 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 a44374f643e6e1cbe4570c6e2d771899277afc65..da590b1a389c353257ee668a4258158ffbd65873 100644 (file)
--- 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 (file)
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