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.
@@ -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);
@@ -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);
@@ -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;
@@ -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);
@@ -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;
@@ -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);
@@ -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:
@@ -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,
new file mode 100644
@@ -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" }
new file mode 100644
@@ -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