match g95_match_select(void) {
g95_expr *e1;
match f;
f = g95_match_label();
if (f == MATCH_ERROR) return f;
f = g95_match(" select case ( %e )%t", &e1);
if (f != MATCH_YES) return f;
new_st.type = EXEC_SELECT;
new_st.expr = e1;
return MATCH_YES;
}
match g95_match_select(void) {
g95_expr *expr;
match m, m1;
m1 = g95_match_label();
if (m1 == MATCH_ERROR)
return m1;
m = g95_match(" select case ( %e )%t", &expr);
if (m != MATCH_YES)
return m;
if (m1 == MATCH_YES && G95_STRICT_F()) {
g95_error("Construct name for SELECT CASE statement at %C not "
"permitted in F");
return MATCH_ERROR;
}
new_st.type = EXEC_SELECT;
new_st.expr = expr;
return MATCH_YES;
}
match g95_match_case(void) {
g95_case *c, *head, *tail;
match m;
head = tail = NULL;
if (g95_current_state() != COMP_SELECT) {
g95_error("Unexpected CASE statement at %C");
return MATCH_ERROR;
}
if (g95_match("% default") == MATCH_YES) {
m = match_case_eos();
if (m == MATCH_NO) goto syntax;
if (m == MATCH_ERROR) goto cleanup;
new_st.type = EXEC_SELECT;
new_st.ext.case_list = g95_get_case();
new_st.ext.case_list->where = g95_current_locus;
return MATCH_YES;
}
if (g95_match_char('(') != MATCH_YES)
goto syntax;
for(;;) {
if (match_case_selector(&c) == MATCH_ERROR)
goto cleanup;
/* Cases that can never be matched are legal to have but mess
* up code generation, so we discard them here. */
if (c->low != NULL && c->high != NULL && c->low != c->high &&
c->low->ts.type != BT_REAL && c->high->ts.type != BT_REAL &&
compare_expr(c->low, c->high) > 0) {
g95_warning(117, "Range specification at %C can never be matched");
free_case(c);
} else {
if (head == NULL)
head = c;
else
tail->next = c;
tail = c;
}
if (g95_match_char(')') == MATCH_YES) break;
if (g95_match_char(',') != MATCH_YES) goto syntax;
}
m = match_case_eos();
if (m == MATCH_NO) goto syntax;
if (m == MATCH_ERROR) goto cleanup;
new_st.type = EXEC_SELECT;
new_st.ext.case_list = head;
return MATCH_YES;
syntax:
g95_error("Syntax error in CASE-specification at %C");
cleanup:
g95_free_case_list(head);
g95_undo_statement();
return MATCH_ERROR;
}
