static try check_case_expr(g95_expr *g, g95_expr *selector) {
if (g == NULL) return SUCCESS;
if (g->type != EXPR_CONSTANT) {
g95_error("Expression in CASE statement at %L must be a constant",
&g->where);
return FAILURE;
}
if (g->ts.type != selector->ts.type) {
g95_error("Expression in CASE statement at %L must be of type %s",
&g->where, g95_basic_typename(selector->ts.type));
return FAILURE;
}
if (g->ts.kind != selector->ts.kind) {
g95_error("Expression in CASE statement at %L must be kind %d",
&g->where, selector->ts.kind);
return FAILURE;
}
if (g->rank != 0) {
g95_error("Expression in CASE statement at %L must be scalar",
&g->where);
return FAILURE;
}
return SUCCESS;
}
static match match_case_selector(g95_case **cp) {
g95_case *c;
match m;
c = g95_get_case();
c->where = g95_current_locus;
if (g95_match_char(':') == MATCH_YES) {
m = g95_match_init_expr(&c->high);
if (m == MATCH_NO) goto need_expr;
if (m == MATCH_ERROR) goto cleanup;
if (c->high->ts.type == BT_LOGICAL)
goto logical_range;
goto done;
}
m = g95_match_init_expr(&c->low);
if (m == MATCH_ERROR) goto cleanup;
if (m == MATCH_NO) goto need_expr;
if (g95_match_char(':') != MATCH_YES)
c->high = c->low; /* Make a range out of a single target */
else {
m = g95_match_init_expr(&c->high);
if (m == MATCH_ERROR) goto cleanup;
if (m == MATCH_NO) goto done; /* It's OK if nothing is there! */
if (c->high->ts.type == BT_LOGICAL)
goto logical_range;
}
done:
*cp = c;
return MATCH_YES;
logical_range:
g95_error("Logical range in CASE statement at %C not allowed");
goto cleanup;
need_expr:
g95_error("Expected expression in CASE at %C");
cleanup:
free_case(c);
return MATCH_ERROR;
}
static try check_case_expr(g95_expr *e, g95_expr *selector) {
int k, flag;
if (e == NULL)
return SUCCESS;
if (e->type != EXPR_CONSTANT) {
g95_error("Expression in CASE statement at %L must be a constant",
&e->where);
return FAILURE;
}
if (e->ts.type != selector->ts.type) {
g95_error("Expression in CASE statement at %L must be of type %s",
&e->where, g95_basic_typename(selector->ts.type));
return FAILURE;
}
if (selector->ts.type != BT_INTEGER && selector->ts.type != BT_LOGICAL &&
selector->ts.type != BT_CHARACTER) {
g95_error("Selector in SELECT CASE statement cannot be type %s",
g95_typename(&selector->ts));
return FAILURE;
}
if (e->ts.kind != selector->ts.kind && e->ts.type == BT_CHARACTER) {
g95_error("Expression in CASE statement at %L must be kind %d",
&e->where, selector->ts.kind);
return FAILURE;
}
if (e->rank != 0) {
g95_error("Expression in CASE statement at %L must be scalar",
&e->where);
return FAILURE;
}
if (e->ts.type == BT_INTEGER) {
k = e->ts.kind;
e->ts.kind = selector->ts.kind;
flag = g95_range_check(e);
e->ts.kind = k;
if (flag) {
g95_error("Integer overflow in CASE statement at %L", &e->where);
return FAILURE;
}
}
return SUCCESS;
}
static match match_case_eos(void) {
char name[G95_MAX_SYMBOL_LEN+1], *block_name;
match m;
if (g95_match_eos() == MATCH_YES)
return MATCH_YES;
g95_gobble_whitespace();
m = g95_match_name(name);
if (m != MATCH_YES)
return m;
block_name = g95_current_block_name();
if (strcmp(name, block_name) != 0) {
g95_error("Expected case name of '%s' at %L", block_name,
&g95_def_locus);
return MATCH_ERROR;
}
return g95_match_eos();
}
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;
}
static try check_format(void) {
char *error,
*posint_required = "Positive width required",
*period_required = "Period required",
*nonneg_required = "Nonnegative width required",
*unexpected_element = "Unexpected element",
*unexpected_end = "Unexpected end of format string";
format_token l, c;
int m;
try r;
use_last_char = 0;
saved_token = FMT_NONE;
m = 0;
r = SUCCESS;
l = format_lex();
if (l != FMT_LPAREN) {
error = "Missing leading left parenthesis";
goto syntax;
}
/* In this state, the next thing has to be a format item */
format_item:
l = format_lex();
switch(l) {
case FMT_POSINT:
l = format_lex();
if (l == FMT_LPAREN) {
m++;
goto format_item;
}
if (l == FMT_SLASH) goto optional_comma;
goto data_desc;
case FMT_ZERO:
l = format_lex();
if (l != FMT_P) {
error = "Zero repeat count not allowed";
goto syntax;
}
goto p_descriptor;
case FMT_LPAREN:
m++;
goto format_item;
case FMT_RPAREN:
goto rparen;
case FMT_SIGNED_INT: /* Signed integer can only precede a P format */
l = format_lex();
if (l != FMT_P) {
error = "Expected P edit descriptor";
goto syntax;
}
goto data_desc;
case FMT_P: /* P and X require a prior number */
error = "P descriptor requires leading scale factor";
goto syntax;
case FMT_X:
error = "X descriptor requires leading space count";
goto syntax;
case FMT_SIGN:
case FMT_BLANK:
case FMT_CHAR:
goto between_desc;
case FMT_COLON:
case FMT_SLASH:
goto optional_comma;
case FMT_DOLLAR:
l = format_lex();
if (l != FMT_RPAREN || m > 0) {
error = "$ must the last specifier";
goto syntax;
}
goto finished;
case FMT_POS: case FMT_IBOZ: case FMT_F: case FMT_E: case FMT_EXT:
case FMT_G: case FMT_L: case FMT_A: case FMT_D:
goto data_desc;
case FMT_H:
repeat = 1;
goto handle_hollerith;
case FMT_END:
error = unexpected_end;
goto syntax;
default:
error = unexpected_element;
goto syntax;
}
/* In this state, t must currently be a data descriptor. Deal with
* things that can/must follow the descriptor */
data_desc:
switch(l) {
case FMT_SIGN:
case FMT_BLANK:
case FMT_X:
break;
case FMT_P:
p_descriptor:
if (g95_option.fmode != 0) {
l = format_lex();
if (l == FMT_POSINT) {
error = "Repeat count cannot follow P descriptor";
goto syntax;
}
saved_token = l;
}
goto optional_comma;
case FMT_POS:
case FMT_L:
l = format_lex();
if (l == FMT_POSINT) break;
error = posint_required;
goto syntax;
case FMT_A:
l = format_lex();
if (l != FMT_POSINT) saved_token = l;
break;
case FMT_D: case FMT_E:
case FMT_G: case FMT_EXT:
c = format_lex();
if (c != FMT_POSINT) {
error = posint_required;
goto syntax;
}
c = format_lex();
if (c != FMT_PERIOD) {
error = period_required;
goto syntax;
}
c = format_lex();
if (c != FMT_ZERO && c != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
if (l == FMT_D) break;
/* Look for optional exponent */
c = format_lex();
if (c != FMT_E) {
saved_token = c;
} else {
c = format_lex();
if (c != FMT_POSINT) {
error = "Positive exponent width required";
goto syntax;
}
}
break;
case FMT_F:
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
l = format_lex();
if (l != FMT_PERIOD) {
error = period_required;
goto syntax;
}
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
break;
case FMT_H:
handle_hollerith:
if (g95_option.fmode != 0) {
error = "The H format specifier is a deleted language feature";
goto syntax;
}
while(repeat>0) {
if (next_char(0) == '\0') {
error = unexpected_end;
goto syntax;
}
repeat--;
}
break;
case FMT_IBOZ:
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
l = format_lex();
if (l != FMT_PERIOD) {
saved_token = l;
} else {
l = format_lex();
if (l != FMT_ZERO && l != FMT_POSINT) {
error = nonneg_required;
goto syntax;
}
}
break;
default:
error = unexpected_element;
goto syntax;
}
/* Between a descriptor and what comes next */
between_desc:
l = format_lex();
switch(l) {
case FMT_COMMA:
goto format_item;
case FMT_RPAREN:
rparen:
m--;
if (m < 0) goto finished;
goto between_desc;
case FMT_COLON:
case FMT_SLASH:
goto optional_comma;
case FMT_END:
error = unexpected_end;
goto syntax;
default:
error = "Missing comma";
goto syntax;
}
/* Optional comma is a weird between state where we've just finished
* reading a colon, slash or P descriptor. */
optional_comma:
l = format_lex();
switch(l) {
case FMT_COMMA:
break;
case FMT_RPAREN:
m--;
if (m < 0) goto finished;
goto between_desc;
default: /* Assume that we have another format item */
saved_token = l;
break;
}
goto format_item;
/* Something went wrong. If the format we're checking is a string,
* generate a warning, since the program is correct. If the format is
* in a FORMAT statement, this messes up parsing, which is an error. */
syntax:
if (mode != MODE_STRING)
g95_error("%s in format string at %L", error, &where);
else
g95_warning(100, "%s in format string at %L", error, &where);
r = FAILURE;
finished:
return r;
}
/* g95_match_format()-- Match a FORMAT statement. This amounts to
* actually parsing the format descriptors in order to correctly
* locate the end of the format string. */
match g95_match_format(void) {
g95_locus sta;
g95_expr *g;
if (g95_statement_label == NULL) {
g95_error("FORMAT statement at %C does not have a statement label");
return MATCH_ERROR;
}
g95_gobble_whitespace();
mode = MODE_FORMAT;
format_length = 0;
sta = where = new_where = g95_current_locus;
if (check_format() == FAILURE) return MATCH_ERROR;
if (g95_match_eos() != MATCH_YES) {
g95_syntax_error(ST_FORMAT);
return MATCH_ERROR;
}
/* The label doesn't get created until after the statement is done
* being matched, so we have to leave the string for later. */
g95_current_locus = sta; /* Back to the beginning */
g = g95_get_expr();
g->type = EXPR_CONSTANT;
g->ts.type = BT_CHARACTER;
g->ts.kind = g95_default_character_kind();
g->where = sta;
g->value.character.string = format_string = g95_getmem(format_length+1);
g->value.character.length = format_length;
g95_statement_label->format = g;
mode = MODE_COPY;
check_format(); /* Guaranteed to succeed */
g95_match_eos(); /* Guaranteed to succeed */
new_st.type = EXEC_NOP;
return MATCH_YES;
}
static int compare_case(const void *w, const void *y) {
const g95_case *q, *u;
int o, f;
char *m;
q = *((g95_case **) w);
u = *((g95_case **) y);
/* Check for duplicate defaults */
if (q->low == NULL && q->high == NULL &&
u->low == NULL && u->high == NULL) {
m = "Duplicate CASE DEFAULT at %L and %L";
goto error;
}
/* Arrange for the default case to be first of all if present. */
if (q->low == NULL && q->high == NULL) return -1;
if (u->low == NULL && u->high == NULL) return 1;
/* Detect duplicate X: and :X forms. These conflict regardless of X. */
if ((q->high == NULL && u->high == NULL) ||
(q->low == NULL && u->low == NULL)) {
m = "Unbounded CASEs conflict at %L and %L";
goto error;
}
/* Compare X: against :A */
if (q->high == NULL && u->low == NULL) {
if (g95_compare_expr(q->low, u->high) <= 0) goto got_overlap;
return 1;
}
/* Compare :X against B: */
if (q->low == NULL && u->high == NULL) {
if (g95_compare_expr(q->high, u->low) >= 0) goto got_overlap;
return -1;
}
/* Compare :X against A:B */
if (q->low == NULL) {
if (g95_compare_expr(q->high, u->low) >= 0) goto got_overlap;
return -1;
}
/* Compare X: against A:B */
if (q->high == NULL) {
if (g95_compare_expr(q->low, u->high) <= 0) goto got_overlap;
return 1;
}
/* Compare X:Y against :A */
if (u->low == NULL) {
if (g95_compare_expr(q->low, u->high) <= 0) goto got_overlap;
return 1;
}
/* Compare X:Y against A: */
if (u->high == NULL) {
if (g95_compare_expr(q->high, u->low) >= 0) goto got_overlap;
return -1;
}
/* Having dispensed with almost a dozen special cases, we can now
* deal with the general case of X:Y against A:B */
o = g95_compare_expr(q->high, u->low);
if (o < 0) o = -1;
if (o > 0) o = 1;
f = g95_compare_expr(q->low, u->high);
if (f < 0) f = -1;
if (f > 0) f = 1;
if (o == 0 || f == 0 || o != f) goto got_overlap;
return o;
got_overlap:
m = "CASEs at %L and %L overlap";
error:
if (!overlap) {
g95_error(m, &q->where, &u->where);
overlap = 1;
}
/* Because we've generated an error, no code will be generated, and
* the order of the case array no longer matters. Return something
* to keep qsort() happy. */
return 1;
}
static int compare_case(const void *v1, const void *v2) {
const g95_case *c1, *c2;
int p1, p2;
char *msg;
c1 = *((g95_case **) v1);
c2 = *((g95_case **) v2);
/* Check for duplicate defaults */
if (c1->low == NULL && c1->high == NULL &&
c2->low == NULL && c2->high == NULL) {
msg = "Duplicate CASE DEFAULT at %L and %L";
goto error;
}
/* Arrange for the default case to be first of all if present. */
if (c1->low == NULL && c1->high == NULL) return -1;
if (c2->low == NULL && c2->high == NULL) return 1;
/* Detect duplicate X: and :X forms. These conflict regardless of X. */
if ((c1->high == NULL && c2->high == NULL) ||
(c1->low == NULL && c2->low == NULL)) {
msg = "Unbounded CASEs conflict at %L and %L";
goto error;
}
/* Compare X: against :A */
if (c1->high == NULL && c2->low == NULL) {
if (compare_expr(c1->low, c2->high) <= 0)
goto got_overlap;
return 1;
}
/* Compare :X against B: */
if (c1->low == NULL && c2->high == NULL) {
if (compare_expr(c1->high, c2->low) >= 0)
goto got_overlap;
return -1;
}
/* Compare :X against A:B */
if (c1->low == NULL) {
if (compare_expr(c1->high, c2->low) >= 0)
goto got_overlap;
return -1;
}
/* Compare X: against A:B */
if (c1->high == NULL) {
if (compare_expr(c1->low, c2->high) <= 0)
goto got_overlap;
return 1;
}
/* Compare X:Y against :A */
if (c2->low == NULL) {
if (compare_expr(c1->low, c2->high) <= 0)
goto got_overlap;
return 1;
}
/* Compare X:Y against A: */
if (c2->high == NULL) {
if (compare_expr(c1->high, c2->low) >= 0)
goto got_overlap;
return -1;
}
/* Having dispensed with almost a dozen special cases, we can now
* deal with the general case of X:Y against A:B */
p1 = compare_expr(c1->high, c2->low);
if (p1 < 0) p1 = -1;
if (p1 > 0) p1 = 1;
p2 = compare_expr(c1->low, c2->high);
if (p2 < 0) p2 = -1;
if (p2 > 0) p2 = 1;
if (p1 == 0 || p2 == 0 || p1 != p2)
goto got_overlap;
return p1;
got_overlap:
msg = "CASEs at %L and %L overlap";
error:
if (!overlap) {
g95_error(msg, &c1->where, &c2->where);
overlap = 1;
}
/* Because we've generated an error, no code will be generated,
* and the order of the case array no longer matters. Return
* something to keep qsort() happy. */
return 1;
}
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;
}
