From bf1b77dd092bb694be6fb0b1fcc369327db6143f Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 9 Apr 2015 19:37:57 +0000 Subject: [PATCH] re PR fortran/56852 (ICE on invalid: "Bad array reference" for an undeclared loop variable) 2013-04-09 Paul Thomas 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 PR fortran/56852 * gfortran.dg/pr56852.f90 : New test From-SVN: r221955 --- gcc/fortran/ChangeLog | 10 ++++- gcc/fortran/primary.c | 54 ++++++++++++++++++--------- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/pr56852.f90 | 11 ++++++ 4 files changed, 60 insertions(+), 20 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pr56852.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f7b1d38d654..78305a0f7bd 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2013-04-09 Paul Thomas + + 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 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 Tobias Burnus diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 67a7f8a99b3..e9ced7e6f71 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 a44374f643e..da590b1a389 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2013-04-09 Paul Thomas + + PR fortran/56852 + * gfortran.dg/pr56852.f90 : New test + 2015-04-09 Marek Polacek Jakub Jelinek diff --git a/gcc/testsuite/gfortran.dg/pr56852.f90 b/gcc/testsuite/gfortran.dg/pr56852.f90 new file mode 100644 index 00000000000..bdf76e1f521 --- /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 +! +program test + implicit none + real :: a(4) + ! integer :: i + read(0) (a(i),i=1,4) ! { dg-error "has no IMPLICIT type" } +end program -- 2.30.2