From 29a63d67791eb9a7bea3c64425ff3b3494968812 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Thu, 13 Jan 2011 17:32:33 +0100 Subject: [PATCH] re PR fortran/45848 ([OOP] ICE on invalid code in fortran/symbol.c:2410) 2011-01-13 Tobias Burnus Mikael Morin PR fortran/45848 PR fortran/47204 * gfortran.h (gfc_code): Move union ext's case_list into the struct block. * dump-parse-tree.c (show_code_node): Adapt by prefixing * case_list by "block.". * frontend-passes.c (gfc_code_walker): Ditto. * match.c (gfc_match_goto, gfc_match_call, gfc_match_case, gfc_match_type_is, gfc_match_class_is): Ditto. * resolve.c (resolve_select, resolve_select_type): Ditto. * st.c (gfc_free_statement): Ditto. * trans-stmt.c (gfc_trans_integer_select, * gfc_trans_logical_select, gfc_trans_character_select): Ditto. * parse.c (resolve_all_program_units): For error recovery, avoid segfault is proc_name is NULL. 2011-01-13 Tobias Burnus Mikael Morin PR fortran/45848 PR fortran/47204 * gfortran.dg/select_type_20.f90: New. * gfortran.dg/select_type_21.f90: New. Co-Authored-By: Mikael Morin From-SVN: r168753 --- gcc/fortran/ChangeLog | 19 +++++++++ gcc/fortran/dump-parse-tree.c | 2 +- gcc/fortran/frontend-passes.c | 2 +- gcc/fortran/gfortran.h | 2 +- gcc/fortran/match.c | 14 +++--- gcc/fortran/parse.c | 3 +- gcc/fortran/resolve.c | 45 ++++++++++---------- gcc/fortran/st.c | 4 +- gcc/fortran/trans-stmt.c | 10 ++--- gcc/testsuite/ChangeLog | 8 ++++ gcc/testsuite/gfortran.dg/select_type_20.f90 | 35 +++++++++++++++ gcc/testsuite/gfortran.dg/select_type_21.f90 | 7 +++ 12 files changed, 111 insertions(+), 40 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_20.f90 create mode 100644 gcc/testsuite/gfortran.dg/select_type_21.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c61ed9287ee..fa84641adb8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,22 @@ +2011-01-13 Tobias Burnus + Mikael Morin + + PR fortran/45848 + PR fortran/47204 + * gfortran.h (gfc_code): Move union ext's case_list into + the struct block. + * dump-parse-tree.c (show_code_node): Adapt by prefixing case_list + by "block.". + * frontend-passes.c (gfc_code_walker): Ditto. + * match.c (gfc_match_goto, gfc_match_call, gfc_match_case, + gfc_match_type_is, gfc_match_class_is): Ditto. + * resolve.c (resolve_select, resolve_select_type): Ditto. + * st.c (gfc_free_statement): Ditto. + * trans-stmt.c (gfc_trans_integer_select, gfc_trans_logical_select, + gfc_trans_character_select): Ditto. + * parse.c (resolve_all_program_units): For error recovery, avoid + segfault is proc_name is NULL. + 2011-01-11 Paul Thomas PR fortran/47051 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index d4b1cb5c522..24e9ea5d1d5 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1467,7 +1467,7 @@ show_code_node (int level, gfc_code *c) code_indent (level, 0); fputs ("CASE ", dumpfile); - for (cp = d->ext.case_list; cp; cp = cp->next) + for (cp = d->ext.block.case_list; cp; cp = cp->next) { fputc ('(', dumpfile); show_expr (cp->low); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 0777dba6869..7c557679822 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -659,7 +659,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, for (b = (*c)->block; b; b = b->block) { gfc_case *cp; - for (cp = b->ext.case_list; cp; cp = cp->next) + for (cp = b->ext.block.case_list; cp; cp = cp->next) { WALK_SUBEXPR (cp->low); WALK_SUBEXPR (cp->high); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d0377f97457..2622f22fd85 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2079,7 +2079,6 @@ typedef struct gfc_code union { gfc_actual_arglist *actual; - gfc_case *case_list; gfc_iterator *iterator; struct @@ -2093,6 +2092,7 @@ typedef struct gfc_code { gfc_namespace *ns; gfc_association_list *assoc; + gfc_case *case_list; } block; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 926fea7ee53..70f58625463 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2651,7 +2651,7 @@ gfc_match_goto (void) NULL, i++); tail->op = EXEC_SELECT; - tail->ext.case_list = cp; + tail->ext.block.case_list = cp; tail->next = gfc_get_code (); tail->next->op = EXEC_GOTO; @@ -3607,7 +3607,7 @@ gfc_match_call (void) new_case = gfc_get_case (); new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); new_case->low = new_case->high; - c->ext.case_list = new_case; + c->ext.block.case_list = new_case; c->next = gfc_get_code (); c->next->op = EXEC_GOTO; @@ -4658,7 +4658,7 @@ gfc_match_case (void) new_st.op = EXEC_SELECT; c = gfc_get_case (); c->where = gfc_current_locus; - new_st.ext.case_list = c; + new_st.ext.block.case_list = c; return MATCH_YES; } @@ -4690,7 +4690,7 @@ gfc_match_case (void) goto cleanup; new_st.op = EXEC_SELECT; - new_st.ext.case_list = head; + new_st.ext.block.case_list = head; return MATCH_YES; @@ -4738,7 +4738,7 @@ gfc_match_type_is (void) goto cleanup; new_st.op = EXEC_SELECT_TYPE; - new_st.ext.case_list = c; + new_st.ext.block.case_list = c; /* Create temporary variable. */ select_type_set_tmp (&c->ts); @@ -4778,7 +4778,7 @@ gfc_match_class_is (void) c = gfc_get_case (); c->where = gfc_current_locus; c->ts.type = BT_UNKNOWN; - new_st.ext.case_list = c; + new_st.ext.block.case_list = c; select_type_set_tmp (NULL); return MATCH_YES; } @@ -4811,7 +4811,7 @@ gfc_match_class_is (void) goto cleanup; new_st.op = EXEC_SELECT_TYPE; - new_st.ext.case_list = c; + new_st.ext.block.case_list = c; /* Create temporary variable. */ select_type_set_tmp (&c->ts); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index e7898cc5621..b51e12bee46 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -4190,7 +4190,8 @@ resolve_all_program_units (gfc_namespace *gfc_global_ns_list) gfc_current_ns = gfc_global_ns_list; for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) { - gfc_current_locus = gfc_current_ns->proc_name->declared_at; + if (gfc_current_ns->proc_name) + gfc_current_locus = gfc_current_ns->proc_name->declared_at; gfc_resolve (gfc_current_ns); gfc_current_ns->derived_types = gfc_derived_types; gfc_derived_types = NULL; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 88acb55bc31..a1c991794b0 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7361,7 +7361,7 @@ resolve_select (gfc_code *code) if (type == BT_INTEGER) for (body = code->block; body; body = body->block) - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { if (cp->low && gfc_check_integer_range (cp->low->value.integer, @@ -7389,7 +7389,7 @@ resolve_select (gfc_code *code) for (body = code->block; body; body = body->block) { /* Walk the case label list. */ - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Intercept the DEFAULT case. It does not have a kind. */ if (cp->low == NULL && cp->high == NULL) @@ -7426,7 +7426,7 @@ resolve_select (gfc_code *code) /* Walk the case label list, making sure that all case labels are legal. */ - for (cp = body->ext.case_list; cp; cp = cp->next) + for (cp = body->ext.block.case_list; cp; cp = cp->next) { /* Count the number of cases in the whole construct. */ ncases++; @@ -7527,19 +7527,19 @@ resolve_select (gfc_code *code) if (seen_unreachable) { /* Advance until the first case in the list is reachable. */ - while (body->ext.case_list != NULL - && body->ext.case_list->unreachable) + while (body->ext.block.case_list != NULL + && body->ext.block.case_list->unreachable) { - gfc_case *n = body->ext.case_list; - body->ext.case_list = body->ext.case_list->next; + gfc_case *n = body->ext.block.case_list; + body->ext.block.case_list = body->ext.block.case_list->next; n->next = NULL; gfc_free_case_list (n); } /* Strip all other unreachable cases. */ - if (body->ext.case_list) + if (body->ext.block.case_list) { - for (cp = body->ext.case_list; cp->next; cp = cp->next) + for (cp = body->ext.block.case_list; cp->next; cp = cp->next) { if (cp->next->unreachable) { @@ -7575,7 +7575,7 @@ resolve_select (gfc_code *code) unreachable case labels for a block. */ for (body = code; body && body->block; body = body->block) { - if (body->block->ext.case_list == NULL) + if (body->block->ext.block.case_list == NULL) { /* Cut the unreachable block from the code chain. */ gfc_code *c = body->block; @@ -7714,7 +7714,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { - c = body->ext.case_list; + c = body->ext.block.case_list; /* Check F03:C815. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) @@ -7744,7 +7744,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { gfc_error ("The DEFAULT CASE at %L cannot be followed " "by a second DEFAULT CASE at %L", - &default_case->ext.case_list->where, &c->where); + &default_case->ext.block.case_list->where, &c->where); error++; continue; } @@ -7799,7 +7799,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) /* Loop over TYPE IS / CLASS IS cases. */ for (body = code->block; body; body = body->block) { - c = body->ext.case_list; + c = body->ext.block.case_list; if (c->ts.type == BT_DERIVED) c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, @@ -7845,7 +7845,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) body = code; while (body && body->block) { - if (body->block->ext.case_list->ts.type == BT_CLASS) + if (body->block->ext.block.case_list->ts.type == BT_CLASS) { /* Add to class_is list. */ if (class_is == NULL) @@ -7878,8 +7878,8 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) tail->block = gfc_get_code (); tail = tail->block; tail->op = EXEC_SELECT_TYPE; - tail->ext.case_list = gfc_get_case (); - tail->ext.case_list->ts.type = BT_UNKNOWN; + tail->ext.block.case_list = gfc_get_case (); + tail->ext.block.case_list->ts.type = BT_UNKNOWN; tail->next = NULL; default_case = tail; } @@ -7897,15 +7897,16 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) { c2 = (*c1)->block; /* F03:C817 (check for doubles). */ - if ((*c1)->ext.case_list->ts.u.derived->hash_value - == c2->ext.case_list->ts.u.derived->hash_value) + if ((*c1)->ext.block.case_list->ts.u.derived->hash_value + == c2->ext.block.case_list->ts.u.derived->hash_value) { gfc_error ("Double CLASS IS block in SELECT TYPE " - "statement at %L", &c2->ext.case_list->where); + "statement at %L", + &c2->ext.block.case_list->where); return; } - if ((*c1)->ext.case_list->ts.u.derived->attr.extension - < c2->ext.case_list->ts.u.derived->attr.extension) + if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension + < c2->ext.block.case_list->ts.u.derived->attr.extension) { /* Swap. */ (*c1)->block = c2->block; @@ -7940,7 +7941,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); new_st->expr1->value.function.actual->expr->where = code->loc; gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); - vtab = gfc_find_derived_vtab (body->ext.case_list->ts.u.derived); + vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index f9ad5d82793..28d69b92983 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -129,8 +129,8 @@ gfc_free_statement (gfc_code *p) case EXEC_SELECT: case EXEC_SELECT_TYPE: - if (p->ext.case_list) - gfc_free_case_list (p->ext.case_list); + if (p->ext.block.case_list) + gfc_free_case_list (p->ext.block.case_list); break; case EXEC_DO: diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 5f6b1d07e74..8781d0e723c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1560,7 +1560,7 @@ gfc_trans_integer_select (gfc_code * code) for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { tree low, high; tree label; @@ -1672,7 +1672,7 @@ gfc_trans_logical_select (gfc_code * code) always executed, and we don't generate code a COND_EXPR. */ for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { if (cp->low) { @@ -1771,7 +1771,7 @@ gfc_trans_character_select (gfc_code *code) static tree ss_string2[2], ss_string2_len[2]; static tree ss_target[2]; - cp = code->block->ext.case_list; + cp = code->block->ext.block.case_list; while (cp->left != NULL) cp = cp->left; @@ -1840,7 +1840,7 @@ gfc_trans_character_select (gfc_code *code) for (c = code->block; c; c = c->block) { - for (cp = c->ext.case_list; cp; cp = cp->next) + for (cp = c->ext.block.case_list; cp; cp = cp->next) { tree low, high; tree label; @@ -1969,7 +1969,7 @@ gfc_trans_character_select (gfc_code *code) for (c = code->block; c; c = c->block) { - for (d = c->ext.case_list; d; d = d->next) + for (d = c->ext.block.case_list; d; d = d->next) { label = gfc_build_label_decl (NULL_TREE); tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c171c3d0028..5bbc5d895e4 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2011-01-13 Tobias Burnus + Mikael Morin + + PR fortran/45848 + PR fortran/47204 + * gfortran.dg/select_type_20.f90: New. + * gfortran.dg/select_type_21.f90: New. + 2011-01-13 Michael Meissner PR target/47251 diff --git a/gcc/testsuite/gfortran.dg/select_type_20.f90 b/gcc/testsuite/gfortran.dg/select_type_20.f90 new file mode 100644 index 00000000000..a247f7b0cfb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_20.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! PR fortran/45848 +! PR fortran/47204 +! +! Contributed by Harald Anlauf and Zdenek Sojka +! +module gfcbug111 + implicit none + + type, abstract :: inner_product_class + end type inner_product_class + + type, extends(inner_product_class) :: trivial_inner_product_type + end type trivial_inner_product_type + +contains + + function my_dot_v_v (this,a,b) ! { dg-error "has no IMPLICIT type" } + class(trivial_inner_product_type), intent(in) :: this + class(vector_class), intent(in) :: a,b ! { dg-error "Derived type" } + real :: my_dot_v_v + + select type (a) + class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" } + select type (b) ! { dg-error "Expected TYPE IS" } + class is (trivial_vector_type) ! { dg-error "Syntax error in CLASS IS" } + class default + end select + class default ! { dg-error "Unclassifiable statement" } + end select ! { dg-error "Expecting END FUNCTION" } + end function my_dot_v_v +end module gfcbug111 + +select type (a) +! { dg-excess-errors "Unexpected end of file" } diff --git a/gcc/testsuite/gfortran.dg/select_type_21.f90 b/gcc/testsuite/gfortran.dg/select_type_21.f90 new file mode 100644 index 00000000000..48d6968135c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_type_21.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/45848 +! PR fortran/47204 +! +select type (a) ! { dg-error "Selector shall be polymorphic" } +end select +end