procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/45848 ([OOP] ICE on invalid code in fortran/symbol.c:2410)

Browse source 
2011-01-13  Tobias Burnus  <burnus@net-b.de>
            Mikael Morin  <mikael@gcc.gnu.org>

        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  <burnus@net-b.de>
            Mikael Morin  <mikael@gcc.gnu.org>

        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 <mikael@gcc.gnu.org>

From-SVN: r168753
This commit is contained in:
Tobias Burnus 2011-01-13 17:32:33 +01:00 • committed by Tobias Burnus
parent b41f0b3440
commit 29a63d6779
12 changed files with 111 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
gcc/fortran/ChangeLog
View file

@ -1,3 +1,22 @@
2011-01-13 Tobias Burnus <burnus@net-b.de>
Mikael Morin <mikael@gcc.gnu.org>
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 <pault@gcc.gnu.org>
PR fortran/47051

2
gcc/fortran/dump-parse-tree.c
View file

@ -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);

2
gcc/fortran/frontend-passes.c
View file

@ -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);

2
gcc/fortran/gfortran.h
View file

@ -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;

14
gcc/fortran/match.c
View file

@ -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);

3
gcc/fortran/parse.c
View file

@ -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;

45
gcc/fortran/resolve.c
View file

@ -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);

4
gcc/fortran/st.c
View file

@ -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:

10
gcc/fortran/trans-stmt.c
View file

@ -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,

8
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,11 @@
2011-01-13 Tobias Burnus <burnus@net-b.de>
Mikael Morin <mikael@gcc.gnu.org>
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 <meissner@linux.vnet.ibm.com>
PR target/47251

35
gcc/testsuite/gfortran.dg/select_type_20.f90 Normal file
View file

@ -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" }

7
gcc/testsuite/gfortran.dg/select_type_21.f90 Normal file
View file

@ -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