#include "config.h"
#include "system.h"
#include "flags.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
mstring intrinsic_operators[] = {
minit ("+", INTRINSIC_UPLUS),
minit ("-", INTRINSIC_UMINUS),
minit ("+", INTRINSIC_PLUS),
minit ("-", INTRINSIC_MINUS),
minit ("**", INTRINSIC_POWER),
minit ("//", INTRINSIC_CONCAT),
minit ("*", INTRINSIC_TIMES),
minit ("/", INTRINSIC_DIVIDE),
minit (".and.", INTRINSIC_AND),
minit (".or.", INTRINSIC_OR),
minit (".eqv.", INTRINSIC_EQV),
minit (".neqv.", INTRINSIC_NEQV),
minit (".eq.", INTRINSIC_EQ),
minit ("==", INTRINSIC_EQ),
minit (".ne.", INTRINSIC_NE),
minit ("/=", INTRINSIC_NE),
minit (".ge.", INTRINSIC_GE),
minit (">=", INTRINSIC_GE),
minit (".le.", INTRINSIC_LE),
minit ("<=", INTRINSIC_LE),
minit (".lt.", INTRINSIC_LT),
minit ("<", INTRINSIC_LT),
minit (".gt.", INTRINSIC_GT),
minit (">", INTRINSIC_GT),
minit (".not.", INTRINSIC_NOT),
minit ("parens", INTRINSIC_PARENTHESES),
minit (NULL, INTRINSIC_NONE)
};
match
gfc_match_space (void)
{
locus old_loc;
int c;
if (gfc_current_form == FORM_FIXED)
return MATCH_YES;
old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!gfc_is_whitespace (c))
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
gfc_gobble_whitespace ();
return MATCH_YES;
}
match
gfc_match_eos (void)
{
locus old_loc;
int flag, c;
flag = 0;
for (;;)
{
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
switch (c)
{
case '!':
do
{
c = gfc_next_char ();
}
while (c != '\n');
case '\n':
return MATCH_YES;
case ';':
flag = 1;
continue;
}
break;
}
gfc_current_locus = old_loc;
return (flag) ? MATCH_YES : MATCH_NO;
}
match
gfc_match_small_literal_int (int *value, int *cnt)
{
locus old_loc;
char c;
int i, j;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (cnt)
*cnt = 0;
if (!ISDIGIT (c))
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
i = c - '0';
j = 1;
for (;;)
{
old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!ISDIGIT (c))
break;
i = 10 * i + c - '0';
j++;
if (i > 99999999)
{
gfc_error ("Integer too large at %C");
return MATCH_ERROR;
}
}
gfc_current_locus = old_loc;
*value = i;
if (cnt)
*cnt = j;
return MATCH_YES;
}
match
gfc_match_small_int (int *value)
{
gfc_expr *expr;
const char *p;
match m;
int i;
m = gfc_match_expr (&expr);
if (m != MATCH_YES)
return m;
p = gfc_extract_int (expr, &i);
gfc_free_expr (expr);
if (p != NULL)
{
gfc_error ("%s", p);
m = MATCH_ERROR;
}
*value = i;
return m;
}
match
gfc_match_st_label (gfc_st_label ** label)
{
locus old_loc;
match m;
int i, cnt;
old_loc = gfc_current_locus;
m = gfc_match_small_literal_int (&i, &cnt);
if (m != MATCH_YES)
return m;
if (cnt > 5)
{
gfc_error ("Too many digits in statement label at %C");
goto cleanup;
}
if (i == 0)
{
gfc_error ("Statement label at %C is zero");
goto cleanup;
}
*label = gfc_get_st_label (i);
return MATCH_YES;
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
match
gfc_match_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
gfc_new_block = NULL;
m = gfc_match (" %n :", name);
if (m != MATCH_YES)
return m;
if (gfc_get_symbol (name, NULL, &gfc_new_block))
{
gfc_error ("Label name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (gfc_new_block->attr.flavor == FL_LABEL)
{
gfc_error ("Duplicate construct label '%s' at %C", name);
return MATCH_ERROR;
}
if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
int
gfc_match_strings (mstring * a)
{
mstring *p, *best_match;
int no_match, c, possibles;
locus match_loc;
possibles = 0;
for (p = a; p->string != NULL; p++)
{
p->mp = p->string;
possibles++;
}
no_match = p->tag;
best_match = NULL;
match_loc = gfc_current_locus;
gfc_gobble_whitespace ();
while (possibles > 0)
{
c = gfc_next_char ();
for (p = a; p->string != NULL; p++)
{
if (p->mp == NULL)
continue;
if (*p->mp == ' ')
{
if ((gfc_current_form == FORM_FREE)
&& gfc_is_whitespace (c))
continue;
p->mp++;
}
if (*p->mp != c)
{
p->mp = NULL;
possibles--;
continue;
}
p->mp++;
if (*p->mp == '\0')
{
match_loc = gfc_current_locus;
best_match = p;
possibles--;
p->mp = NULL;
}
}
}
gfc_current_locus = match_loc;
return (best_match == NULL) ? no_match : best_match->tag;
}
match
gfc_match_name (char *buffer)
{
locus old_loc;
int i, c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
if (!ISALPHA (c))
{
gfc_current_locus = old_loc;
return MATCH_NO;
}
i = 0;
do
{
buffer[i++] = c;
if (i > gfc_option.max_identifier_length)
{
gfc_error ("Name at %C is too long");
return MATCH_ERROR;
}
old_loc = gfc_current_locus;
c = gfc_next_char ();
}
while (ISALNUM (c)
|| c == '_'
|| (gfc_option.flag_dollar_ok && c == '$'));
buffer[i] = '\0';
gfc_current_locus = old_loc;
return MATCH_YES;
}
match
gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
m = gfc_match_name (buffer);
if (m != MATCH_YES)
return m;
if (host_assoc)
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
? MATCH_ERROR : MATCH_YES;
if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
return MATCH_ERROR;
return MATCH_YES;
}
match
gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
{
gfc_symtree *st;
match m;
m = gfc_match_sym_tree (&st, host_assoc);
if (m == MATCH_YES)
{
if (st)
*matched_symbol = st->n.sym;
else
*matched_symbol = NULL;
}
else
*matched_symbol = NULL;
return m;
}
match
gfc_match_intrinsic_op (gfc_intrinsic_op * result)
{
gfc_intrinsic_op op;
op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
if (op == INTRINSIC_NONE)
return MATCH_NO;
*result = op;
return MATCH_YES;
}
match
gfc_match_iterator (gfc_iterator * iter, int init_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
start = gfc_current_locus;
m = gfc_match (" %n =", name);
gfc_current_locus = start;
if (m != MATCH_YES)
return MATCH_NO;
m = gfc_match_variable (&var, 0);
if (m != MATCH_YES)
return MATCH_NO;
gfc_match_char ('=');
e1 = e2 = e3 = NULL;
if (var->ref != NULL)
{
gfc_error ("Loop variable at %C cannot be a sub-component");
goto cleanup;
}
if (var->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
var->symtree->n.sym->name);
goto cleanup;
}
m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_char (',') != MATCH_YES)
{
e3 = gfc_int_expr (1);
goto done;
}
m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
{
gfc_error ("Expected a step value in iterator at %C");
goto cleanup;
}
done:
iter->var = var;
iter->start = e1;
iter->end = e2;
iter->step = e3;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in iterator at %C");
cleanup:
gfc_free_expr (e1);
gfc_free_expr (e2);
gfc_free_expr (e3);
return MATCH_ERROR;
}
match
gfc_match_char (char c)
{
locus where;
where = gfc_current_locus;
gfc_gobble_whitespace ();
if (gfc_next_char () == c)
return MATCH_YES;
gfc_current_locus = where;
return MATCH_NO;
}
match
gfc_match (const char *target, ...)
{
gfc_st_label **label;
int matches, *ip;
locus old_loc;
va_list argp;
char c, *np;
match m, n;
void **vp;
const char *p;
old_loc = gfc_current_locus;
va_start (argp, target);
m = MATCH_NO;
matches = 0;
p = target;
loop:
c = *p++;
switch (c)
{
case ' ':
gfc_gobble_whitespace ();
goto loop;
case '\0':
m = MATCH_YES;
break;
case '%':
c = *p++;
switch (c)
{
case 'e':
vp = va_arg (argp, void **);
n = gfc_match_expr ((gfc_expr **) vp);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 'v':
vp = va_arg (argp, void **);
n = gfc_match_variable ((gfc_expr **) vp, 0);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 's':
vp = va_arg (argp, void **);
n = gfc_match_symbol ((gfc_symbol **) vp, 0);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 'n':
np = va_arg (argp, char *);
n = gfc_match_name (np);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 'l':
label = va_arg (argp, gfc_st_label **);
n = gfc_match_st_label (label);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 'o':
ip = va_arg (argp, int *);
n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
matches++;
goto loop;
case 't':
if (gfc_match_eos () != MATCH_YES)
{
m = MATCH_NO;
goto not_yes;
}
goto loop;
case ' ':
if (gfc_match_space () == MATCH_YES)
goto loop;
m = MATCH_NO;
goto not_yes;
case '%':
break;
default:
gfc_internal_error ("gfc_match(): Bad match code %c", c);
}
default:
if (c == gfc_next_char ())
goto loop;
break;
}
not_yes:
va_end (argp);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
va_start (argp, target);
p = target;
for (; matches > 0; matches--)
{
while (*p++ != '%');
switch (*p++)
{
case '%':
matches++;
break;
case 'o':
case 'l':
case 'n':
case 's':
(void)va_arg (argp, void **);
break;
case 'e':
case 'v':
vp = va_arg (argp, void **);
gfc_free_expr (*vp);
*vp = NULL;
break;
}
}
va_end (argp);
}
return m;
}
match
gfc_match_program (void)
{
gfc_symbol *sym;
match m;
m = gfc_match ("% %s%t", &sym);
if (m == MATCH_NO)
{
gfc_error ("Invalid form of PROGRAM statement at %C");
m = MATCH_ERROR;
}
if (m == MATCH_ERROR)
return m;
if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
return MATCH_YES;
}
match
gfc_match_assignment (void)
{
gfc_expr *lvalue, *rvalue;
locus old_loc;
match m;
old_loc = gfc_current_locus;
lvalue = NULL;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
return MATCH_NO;
}
rvalue = NULL;
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
gfc_free_expr (rvalue);
return m;
}
gfc_set_sym_referenced (lvalue->symtree->n.sym);
new_st.op = EXEC_ASSIGN;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
gfc_check_do_variable (lvalue->symtree);
return MATCH_YES;
}
match
gfc_match_pointer_assignment (void)
{
gfc_expr *lvalue, *rvalue;
locus old_loc;
match m;
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
m = gfc_match (" %v =>", &lvalue);
if (m != MATCH_YES)
{
m = MATCH_NO;
goto cleanup;
}
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
goto cleanup;
new_st.op = EXEC_POINTER_ASSIGN;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
return MATCH_YES;
cleanup:
gfc_current_locus = old_loc;
gfc_free_expr (lvalue);
gfc_free_expr (rvalue);
return m;
}
static match
match_arithmetic_if (void)
{
gfc_st_label *l1, *l2, *l3;
gfc_expr *expr;
match m;
m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
if (m != MATCH_YES)
return m;
if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_OBS,
"Obsolescent: arithmetic IF statement at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
new_st.label = l1;
new_st.label2 = l2;
new_st.label3 = l3;
return MATCH_YES;
}
static match match_simple_forall (void);
static match match_simple_where (void);
match
gfc_match_if (gfc_statement * if_type)
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
locus old_loc;
gfc_code *p;
match m, n;
n = gfc_match_label ();
if (n == MATCH_ERROR)
return n;
old_loc = gfc_current_locus;
m = gfc_match (" if ( %e", &expr);
if (m != MATCH_YES)
return m;
if (gfc_match_char (')') != MATCH_YES)
{
gfc_error ("Syntax error in IF-expression at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
if (m == MATCH_YES)
{
if (n == MATCH_YES)
{
gfc_error
("Block label not appropriate for arithmetic IF statement "
"at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
|| gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (gfc_notify_std (GFC_STD_F95_OBS,
"Obsolescent: arithmetic IF statement at %C")
== FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
new_st.label = l1;
new_st.label2 = l2;
new_st.label3 = l3;
*if_type = ST_ARITHMETIC_IF;
return MATCH_YES;
}
if (gfc_match (" then%t") == MATCH_YES)
{
new_st.op = EXEC_IF;
new_st.expr = expr;
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
if (n == MATCH_YES)
{
gfc_error ("Block label is not appropriate IF statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
*if_type = ST_SIMPLE_IF;
m = gfc_match_assignment ();
if (m == MATCH_YES)
goto got_match;
gfc_free_expr (expr);
gfc_undo_symbols ();
gfc_current_locus = old_loc;
if (m == MATCH_ERROR)
return MATCH_ERROR;
gfc_match (" if ( %e ) ", &expr);
m = gfc_match_pointer_assignment ();
if (m == MATCH_YES)
goto got_match;
gfc_free_expr (expr);
gfc_undo_symbols ();
gfc_current_locus = old_loc;
gfc_match (" if ( %e ) ", &expr);
#define match(string, subr, statement) \
if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
gfc_clear_error ();
match ("allocate", gfc_match_allocate, ST_ALLOCATE)
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
match ("backspace", gfc_match_backspace, ST_BACKSPACE)
match ("call", gfc_match_call, ST_CALL)
match ("close", gfc_match_close, ST_CLOSE)
match ("continue", gfc_match_continue, ST_CONTINUE)
match ("cycle", gfc_match_cycle, ST_CYCLE)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
match ("exit", gfc_match_exit, ST_EXIT)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
match ("go to", gfc_match_goto, ST_GOTO)
match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
match ("inquire", gfc_match_inquire, ST_INQUIRE)
match ("nullify", gfc_match_nullify, ST_NULLIFY)
match ("open", gfc_match_open, ST_OPEN)
match ("pause", gfc_match_pause, ST_NONE)
match ("print", gfc_match_print, ST_WRITE)
match ("read", gfc_match_read, ST_READ)
match ("return", gfc_match_return, ST_RETURN)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
m = gfc_match_assignment ();
if (m == MATCH_NO)
{
gfc_error ("Cannot assign to a named constant at %C");
gfc_free_expr (expr);
gfc_undo_symbols ();
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
got_match:
if (m == MATCH_NO)
gfc_error ("Syntax error in IF-clause at %C");
if (m != MATCH_YES)
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
p = gfc_get_code ();
p->next = gfc_get_code ();
*p->next = new_st;
p->next->loc = gfc_current_locus;
p->expr = expr;
p->op = EXEC_IF;
gfc_clear_new_st ();
new_st.op = EXEC_IF;
new_st.block = p;
return MATCH_YES;
}
#undef match
match
gfc_match_else (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_name (name) != MATCH_YES
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after ELSE statement at %C");
return MATCH_ERROR;
}
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
name, gfc_current_block ()->name);
return MATCH_ERROR;
}
return MATCH_YES;
}
match
gfc_match_elseif (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *expr;
match m;
m = gfc_match (" ( %e ) then", &expr);
if (m != MATCH_YES)
return m;
if (gfc_match_eos () == MATCH_YES)
goto done;
if (gfc_match_name (name) != MATCH_YES
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after ELSE IF statement at %C");
goto cleanup;
}
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
name, gfc_current_block ()->name);
goto cleanup;
}
done:
new_st.op = EXEC_IF;
new_st.expr = expr;
return MATCH_YES;
cleanup:
gfc_free_expr (expr);
return MATCH_ERROR;
}
void
gfc_free_iterator (gfc_iterator * iter, int flag)
{
if (iter == NULL)
return;
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->step);
if (flag)
gfc_free (iter);
}
match
gfc_match_do (void)
{
gfc_iterator iter, *ip;
locus old_loc;
gfc_st_label *label;
match m;
old_loc = gfc_current_locus;
label = NULL;
iter.var = iter.start = iter.end = iter.step = NULL;
m = gfc_match_label ();
if (m == MATCH_ERROR)
return m;
if (gfc_match (" do") != MATCH_YES)
return MATCH_NO;
m = gfc_match_st_label (&label);
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_eos () == MATCH_YES)
{
iter.end = gfc_logical_expr (1, NULL);
new_st.op = EXEC_DO_WHILE;
goto done;
}
if (gfc_match_char(',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES)
return MATCH_NO;
if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
{
new_st.op = EXEC_DO_WHILE;
goto done;
}
gfc_undo_symbols ();
gfc_current_locus = old_loc;
gfc_match_label ();
gfc_match (" do ");
gfc_match_st_label (&label);
gfc_match_char (',');
m = gfc_match_iterator (&iter, 0);
if (m == MATCH_NO)
return MATCH_NO;
if (m == MATCH_ERROR)
goto cleanup;
gfc_check_do_variable (iter.var->symtree);
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_DO);
goto cleanup;
}
new_st.op = EXEC_DO;
done:
if (label != NULL
&& gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
goto cleanup;
new_st.label = label;
if (new_st.op == EXEC_DO_WHILE)
new_st.expr = iter.end;
else
{
new_st.ext.iterator = ip = gfc_get_iterator ();
*ip = iter;
}
return MATCH_YES;
cleanup:
gfc_free_iterator (&iter, 0);
return MATCH_ERROR;
}
static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
if (gfc_match_eos () == MATCH_YES)
sym = NULL;
else
{
m = gfc_match ("% %s%t", &sym);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
{
gfc_syntax_error (st);
return MATCH_ERROR;
}
if (sym->attr.flavor != FL_LABEL)
{
gfc_error ("Name '%s' in %s statement at %C is not a loop name",
sym->name, gfc_ascii_statement (st));
return MATCH_ERROR;
}
}
for (o = NULL, p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
break;
else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
if (p == NULL)
{
if (sym == NULL)
gfc_error ("%s statement at %C is not within a loop",
gfc_ascii_statement (st));
else
gfc_error ("%s statement at %C is not within loop '%s'",
gfc_ascii_statement (st), sym->name);
return MATCH_ERROR;
}
if (o != NULL)
{
gfc_error ("%s statement at %C leaving OpenMP structured block",
gfc_ascii_statement (st));
return MATCH_ERROR;
}
else if (st == ST_EXIT
&& p->previous != NULL
&& p->previous->state == COMP_OMP_STRUCTURED_BLOCK
&& (p->previous->head->op == EXEC_OMP_DO
|| p->previous->head->op == EXEC_OMP_PARALLEL_DO))
{
gcc_assert (p->previous->head->next != NULL);
gcc_assert (p->previous->head->next->op == EXEC_DO
|| p->previous->head->next->op == EXEC_DO_WHILE);
gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
return MATCH_ERROR;
}
new_st.ext.whichloop = p->head;
new_st.op = op;
return MATCH_YES;
}
match
gfc_match_exit (void)
{
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
match
gfc_match_cycle (void)
{
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
static match
gfc_match_stopcode (gfc_statement st)
{
int stop_code;
gfc_expr *e;
match m;
int cnt;
stop_code = -1;
e = NULL;
if (gfc_match_eos () != MATCH_YES)
{
m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES && cnt > 5)
{
gfc_error ("Too many digits in STOP code at %C");
goto cleanup;
}
if (m == MATCH_NO)
{
m = gfc_match_expr (&e);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
goto syntax;
}
if (gfc_match_eos () != MATCH_YES)
goto syntax;
}
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
gfc_ascii_statement (st));
goto cleanup;
}
new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
new_st.expr = e;
new_st.ext.stop_code = stop_code;
return MATCH_YES;
syntax:
gfc_syntax_error (st);
cleanup:
gfc_free_expr (e);
return MATCH_ERROR;
}
match
gfc_match_pause (void)
{
match m;
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: PAUSE statement at %C")
== FAILURE)
m = MATCH_ERROR;
}
return m;
}
match
gfc_match_stop (void)
{
return gfc_match_stopcode (ST_STOP);
}
match
gfc_match_continue (void)
{
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
return MATCH_ERROR;
}
new_st.op = EXEC_CONTINUE;
return MATCH_YES;
}
match
gfc_match_assign (void)
{
gfc_expr *expr;
gfc_st_label *label;
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: ASSIGN statement at %C")
== FAILURE)
return MATCH_ERROR;
expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_LABEL_ASSIGN;
new_st.label = label;
new_st.expr = expr;
return MATCH_YES;
}
}
return MATCH_NO;
}
match
gfc_match_goto (void)
{
gfc_code *head, *tail;
gfc_expr *expr;
gfc_case *cp;
gfc_st_label *label;
int i;
match m;
if (gfc_match (" %l%t", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
new_st.label = label;
return MATCH_YES;
}
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F95_DEL,
"Obsolete: Assigned GOTO statement at %C")
== FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
gfc_match_char (',');
if (gfc_match_char ('(') != MATCH_YES)
{
gfc_syntax_error (ST_GOTO);
return MATCH_ERROR;
}
head = tail = NULL;
do
{
m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
goto cleanup;
if (head == NULL)
head = tail = gfc_get_code ();
else
{
tail->block = gfc_get_code ();
tail = tail->block;
}
tail->label = label;
tail->op = EXEC_GOTO;
}
while (gfc_match_char (',') == MATCH_YES);
if (gfc_match (")%t") != MATCH_YES)
goto syntax;
if (head == NULL)
{
gfc_error (
"Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
new_st.block = head;
return MATCH_YES;
}
if (gfc_match_char ('(') != MATCH_YES)
{
gfc_syntax_error (ST_GOTO);
return MATCH_ERROR;
}
head = tail = NULL;
i = 1;
do
{
m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
goto cleanup;
if (head == NULL)
head = tail = gfc_get_code ();
else
{
tail->block = gfc_get_code ();
tail = tail->block;
}
cp = gfc_get_case ();
cp->low = cp->high = gfc_int_expr (i++);
tail->op = EXEC_SELECT;
tail->ext.case_list = cp;
tail->next = gfc_get_code ();
tail->next->op = EXEC_GOTO;
tail->next->label = label;
}
while (gfc_match_char (',') == MATCH_YES);
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
if (head == NULL)
{
gfc_error ("Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
gfc_match_char (',');
if (gfc_match (" %e%t", &expr) != MATCH_YES)
goto syntax;
new_st.op = EXEC_SELECT;
new_st.expr = NULL;
new_st.expr2 = expr;
new_st.block = head;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_GOTO);
cleanup:
gfc_free_statements (head);
return MATCH_ERROR;
}
void
gfc_free_alloc_list (gfc_alloc * p)
{
gfc_alloc *q;
for (; p; p = q)
{
q = p->next;
gfc_free_expr (p->expr);
gfc_free (p);
}
}
match
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
gfc_expr *stat;
match m;
head = tail = NULL;
stat = NULL;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
for (;;)
{
if (head == NULL)
head = tail = gfc_get_alloc ();
else
{
tail->next = gfc_get_alloc ();
tail = tail->next;
}
m = gfc_match_variable (&tail->expr, 0);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
if (gfc_pure (NULL)
&& gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
"PURE procedure");
goto cleanup;
}
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
if (gfc_match_char (',') != MATCH_YES)
break;
m = gfc_match (" stat = %v", &stat);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
break;
}
if (stat != NULL)
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error
("STAT variable '%s' of ALLOCATE statement at %C cannot be "
"INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
gfc_error
("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
"procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
gfc_error("STAT expression at %C must be a variable");
goto cleanup;
}
gfc_check_do_variable(stat->symtree);
}
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_ALLOCATE;
new_st.expr = stat;
new_st.ext.alloc_list = head;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_ALLOCATE);
cleanup:
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
match
gfc_match_nullify (void)
{
gfc_code *tail;
gfc_expr *e, *p;
match m;
tail = NULL;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
for (;;)
{
m = gfc_match_variable (&p, 0);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (gfc_check_do_variable(p->symtree))
goto cleanup;
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
gfc_error
("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
e = gfc_get_expr ();
e->where = gfc_current_locus;
e->expr_type = EXPR_NULL;
e->ts.type = BT_UNKNOWN;
if (tail == NULL)
tail = &new_st;
else
{
tail->next = gfc_get_code ();
tail = tail->next;
}
tail->op = EXEC_POINTER_ASSIGN;
tail->expr = p;
tail->expr2 = e;
if (gfc_match (" )%t") == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_syntax_error (ST_NULLIFY);
cleanup:
gfc_free_statements (new_st.next);
return MATCH_ERROR;
}
match
gfc_match_deallocate (void)
{
gfc_alloc *head, *tail;
gfc_expr *stat;
match m;
head = tail = NULL;
stat = NULL;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
for (;;)
{
if (head == NULL)
head = tail = gfc_get_alloc ();
else
{
tail->next = gfc_get_alloc ();
tail = tail->next;
}
m = gfc_match_variable (&tail->expr, 0);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
if (gfc_pure (NULL)
&& gfc_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error
("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
"procedure");
goto cleanup;
}
if (gfc_match_char (',') != MATCH_YES)
break;
m = gfc_match (" stat = %v", &stat);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
break;
}
if (stat != NULL)
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
"cannot be INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
"for a PURE procedure");
goto cleanup;
}
if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
{
gfc_error("STAT expression at %C must be a variable");
goto cleanup;
}
gfc_check_do_variable(stat->symtree);
}
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_DEALLOCATE;
new_st.expr = stat;
new_st.ext.alloc_list = head;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_DEALLOCATE);
cleanup:
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
match
gfc_match_return (void)
{
gfc_expr *e;
match m;
gfc_compile_state s;
int c;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
goto done;
if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
{
gfc_error ("Alternate RETURN statement at %C is only allowed within "
"a SUBROUTINE");
goto cleanup;
}
if (gfc_current_form == FORM_FREE)
{
c = gfc_peek_char ();
if (ISALPHA (c) || ISDIGIT (c))
return MATCH_NO;
}
m = gfc_match (" %e%t", &e);
if (m == MATCH_YES)
goto done;
if (m == MATCH_ERROR)
goto cleanup;
gfc_syntax_error (ST_RETURN);
cleanup:
gfc_free_expr (e);
return MATCH_ERROR;
done:
gfc_enclosing_unit (&s);
if (s == COMP_PROGRAM
&& gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
"main program at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_RETURN;
new_st.expr = e;
return MATCH_YES;
}
match
gfc_match_call (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_actual_arglist *a, *arglist;
gfc_case *new_case;
gfc_symbol *sym;
gfc_symtree *st;
gfc_code *c;
match m;
int i;
arglist = NULL;
m = gfc_match ("% %n", name);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
return m;
if (gfc_get_ha_sym_tree (name, &st))
return MATCH_ERROR;
sym = st->n.sym;
gfc_set_sym_referenced (sym);
if (!sym->attr.generic
&& !sym->attr.subroutine
&& gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
{
m = gfc_match_actual_arglist (1, &arglist);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
}
i = 0;
for (a = arglist; a; a = a->next)
if (a->expr == NULL)
i = 1;
if (i)
{
gfc_symtree *select_st;
gfc_symbol *select_sym;
char name[GFC_MAX_SYMBOL_LEN + 1];
new_st.next = c = gfc_get_code ();
c->op = EXEC_SELECT;
sprintf (name, "_result_%s",sym->name);
gfc_get_ha_sym_tree (name, &select_st);
select_sym = select_st->n.sym;
select_sym->ts.type = BT_INTEGER;
select_sym->ts.kind = gfc_default_integer_kind;
gfc_set_sym_referenced (select_sym);
c->expr = gfc_get_expr ();
c->expr->expr_type = EXPR_VARIABLE;
c->expr->symtree = select_st;
c->expr->ts = select_sym->ts;
c->expr->where = gfc_current_locus;
i = 0;
for (a = arglist; a; a = a->next)
{
if (a->expr != NULL)
continue;
if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
continue;
i++;
c->block = gfc_get_code ();
c = c->block;
c->op = EXEC_SELECT;
new_case = gfc_get_case ();
new_case->high = new_case->low = gfc_int_expr (i);
c->ext.case_list = new_case;
c->next = gfc_get_code ();
c->next->op = EXEC_GOTO;
c->next->label = a->label;
}
}
new_st.op = EXEC_CALL;
new_st.symtree = st;
new_st.ext.actual = arglist;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_CALL);
cleanup:
gfc_free_actual_arglist (arglist);
return MATCH_ERROR;
}
gfc_common_head *
gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
static int serial = 0;
char mangled_name[GFC_MAX_SYMBOL_LEN+1];
if (from_module)
{
snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
{
st = gfc_find_symtree (gfc_current_ns->common_root, name);
if (st == NULL)
st = gfc_new_symtree (&gfc_current_ns->common_root, name);
}
if (st->n.common == NULL)
{
st->n.common = gfc_get_common_head ();
st->n.common->where = gfc_current_locus;
strcpy (st->n.common->name, name);
}
return st->n.common;
}
static match
match_common_name (char *name)
{
match m;
if (gfc_match_char ('/') == MATCH_NO)
{
name[0] = '\0';
return MATCH_YES;
}
if (gfc_match_char ('/') == MATCH_YES)
{
name[0] = '\0';
return MATCH_YES;
}
m = gfc_match_name (name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
return MATCH_YES;
gfc_error ("Syntax error in common block name at %C");
return MATCH_ERROR;
}
match
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
char name[GFC_MAX_SYMBOL_LEN+1];
gfc_common_head *t;
gfc_array_spec *as;
gfc_equiv * e1, * e2;
match m;
gfc_gsymbol *gsym;
old_blank_common = gfc_current_ns->blank_common.head;
if (old_blank_common)
{
while (old_blank_common->common_next)
old_blank_common = old_blank_common->common_next;
}
as = NULL;
for (;;)
{
m = match_common_name (name);
if (m == MATCH_ERROR)
goto cleanup;
gsym = gfc_get_gsymbol (name);
if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
{
gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
name);
goto cleanup;
}
if (gsym->type == GSYM_UNKNOWN)
{
gsym->type = GSYM_COMMON;
gsym->where = gfc_current_locus;
gsym->defined = 1;
}
gsym->used = 1;
if (name[0] == '\0')
{
t = &gfc_current_ns->blank_common;
if (t->head == NULL)
t->where = gfc_current_locus;
head = &t->head;
}
else
{
t = gfc_get_common (name, 0);
head = &t->head;
}
if (*head == NULL)
tail = NULL;
else
{
tail = *head;
while (tail->common_next)
tail = tail->common_next;
}
for (;;)
{
m = gfc_match_symbol (&sym, 0);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (sym->attr.in_common)
{
gfc_error ("Symbol '%s' at %C is already in a COMMON block",
sym->name);
goto cleanup;
}
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->value != NULL
&& (name[0] == '\0' || !sym->attr.data))
{
if (name[0] == '\0')
gfc_error ("Previously initialized symbol '%s' in "
"blank COMMON block at %C", sym->name);
else
gfc_error ("Previously initialized symbol '%s' in "
"COMMON block '%s' at %C", sym->name, name);
goto cleanup;
}
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
{
gfc_error
("Derived type variable in COMMON at %C does not have the "
"SEQUENCE attribute");
goto cleanup;
}
if (tail != NULL)
tail->common_next = sym;
else
*head = sym;
tail = sym;
m = gfc_match_array_spec (&as);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
{
if (as->type != AS_EXPLICIT)
{
gfc_error
("Array specification for symbol '%s' in COMMON at %C "
"must be explicit", sym->name);
goto cleanup;
}
if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.pointer)
{
gfc_error
("Symbol '%s' in COMMON at %C cannot be a POINTER array",
sym->name);
goto cleanup;
}
sym->as = as;
as = NULL;
}
sym->common_head = t;
if (sym->attr.in_equivalence)
{
for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
{
for (e2 = e1; e2; e2 = e2->eq)
if (e2->expr->symtree->n.sym == sym)
goto equiv_found;
continue;
equiv_found:
for (e2 = e1; e2; e2 = e2->eq)
{
other = e2->expr->symtree->n.sym;
if (other->common_head
&& other->common_head != sym->common_head)
{
gfc_error ("Symbol '%s', in COMMON block '%s' at "
"%C is being indirectly equivalenced to "
"another COMMON block '%s'",
sym->name,
sym->common_head->name,
other->common_head->name);
goto cleanup;
}
other->attr.in_common = 1;
other->common_head = t;
}
}
}
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
goto done;
if (gfc_peek_char () == '/')
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
gfc_gobble_whitespace ();
if (gfc_peek_char () == '/')
break;
}
}
done:
return MATCH_YES;
syntax:
gfc_syntax_error (ST_COMMON);
cleanup:
if (old_blank_common)
old_blank_common->common_next = NULL;
else
gfc_current_ns->blank_common.head = NULL;
gfc_free_array_spec (as);
return MATCH_ERROR;
}
match
gfc_match_block_data (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
match m;
if (gfc_match_eos () == MATCH_YES)
{
gfc_new_block = NULL;
return MATCH_YES;
}
m = gfc_match ("% %n%t", name);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
return MATCH_YES;
}
void
gfc_free_namelist (gfc_namelist * name)
{
gfc_namelist *n;
for (; name; name = n)
{
n = name->next;
gfc_free (name);
}
}
match
gfc_match_namelist (void)
{
gfc_symbol *group_name, *sym;
gfc_namelist *nl;
match m, m2;
m = gfc_match (" / %s /", &group_name);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto error;
for (;;)
{
if (group_name->ts.type != BT_UNKNOWN)
{
gfc_error
("Namelist group name '%s' at %C already has a basic type "
"of %s", group_name->name, gfc_typename (&group_name->ts));
return MATCH_ERROR;
}
if (group_name->attr.flavor == FL_NAMELIST
&& group_name->attr.use_assoc
&& gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
"at %C already is USE associated and can"
"not be respecified.", group_name->name)
== FAILURE)
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
&& gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL) == FAILURE)
return MATCH_ERROR;
for (;;)
{
m = gfc_match_symbol (&sym, 1);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto error;
if (sym->attr.in_namelist == 0
&& gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
goto error;
if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
{
gfc_error ("Assumed size array '%s' in namelist '%s'at "
"%C is not allowed.", sym->name, group_name->name);
gfc_error_check ();
}
if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
{
gfc_error ("Assumed character length '%s' in namelist '%s' at "
"%C is not allowed", sym->name, group_name->name);
gfc_error_check ();
}
if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
&& gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
"namelist '%s' at %C is an extension.",
sym->name, group_name->name) == FAILURE)
gfc_error_check ();
nl = gfc_get_namelist ();
nl->sym = sym;
sym->refs++;
if (group_name->namelist == NULL)
group_name->namelist = group_name->namelist_tail = nl;
else
{
group_name->namelist_tail->next = nl;
group_name->namelist_tail = nl;
}
if (gfc_match_eos () == MATCH_YES)
goto done;
m = gfc_match_char (',');
if (gfc_match_char ('/') == MATCH_YES)
{
m2 = gfc_match (" %s /", &group_name);
if (m2 == MATCH_YES)
break;
if (m2 == MATCH_ERROR)
goto error;
goto syntax;
}
if (m != MATCH_YES)
goto syntax;
}
}
done:
return MATCH_YES;
syntax:
gfc_syntax_error (ST_NAMELIST);
error:
return MATCH_ERROR;
}
match
gfc_match_module (void)
{
match m;
m = gfc_match (" %s%t", &gfc_new_block);
if (m != MATCH_YES)
return m;
if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
}
void
gfc_free_equiv (gfc_equiv * eq)
{
if (eq == NULL)
return;
gfc_free_equiv (eq->eq);
gfc_free_equiv (eq->next);
gfc_free_expr (eq->expr);
gfc_free (eq);
}
match
gfc_match_equivalence (void)
{
gfc_equiv *eq, *set, *tail;
gfc_ref *ref;
gfc_symbol *sym;
match m;
gfc_common_head *common_head = NULL;
bool common_flag;
int cnt;
tail = NULL;
for (;;)
{
eq = gfc_get_equiv ();
if (tail == NULL)
tail = eq;
eq->next = gfc_current_ns->equiv;
gfc_current_ns->equiv = eq;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
set = eq;
common_flag = FALSE;
cnt = 0;
for (;;)
{
m = gfc_match_equiv_variable (&set->expr);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
cnt++;
if (gfc_match_char ('%') == MATCH_YES)
{
gfc_error ("Derived type component %C is not a "
"permitted EQUIVALENCE member");
goto cleanup;
}
for (ref = set->expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
{
gfc_error
("Array reference in EQUIVALENCE at %C cannot be an "
"array section");
goto cleanup;
}
sym = set->expr->symtree->n.sym;
if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL)
== FAILURE)
goto cleanup;
if (sym->attr.in_common)
{
common_flag = TRUE;
common_head = sym->common_head;
}
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
set->eq = gfc_get_equiv ();
set = set->eq;
}
if (cnt < 2)
{
gfc_error ("EQUIVALENCE at %C requires two or more objects");
goto cleanup;
}
if (common_flag)
for (set = eq; set; set = set->eq)
{
sym = set->expr->symtree->n.sym;
if (sym->common_head && sym->common_head != common_head)
{
gfc_error ("Attempt to indirectly overlap COMMON "
"blocks %s and %s by EQUIVALENCE at %C",
sym->common_head->name,
common_head->name);
goto cleanup;
}
sym->attr.in_common = 1;
sym->common_head = common_head;
}
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_syntax_error (ST_EQUIVALENCE);
cleanup:
eq = tail->next;
tail->next = NULL;
gfc_free_equiv (gfc_current_ns->equiv);
gfc_current_ns->equiv = eq;
return MATCH_ERROR;
}
static bool
recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
{
gfc_actual_arglist *arg;
gfc_ref *ref;
int i;
if (e == NULL)
return false;
switch (e->expr_type)
{
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
{
if (sym->name == arg->name
|| recursive_stmt_fcn (arg->expr, sym))
return true;
}
if (e->symtree == NULL)
return false;
if (sym->name == e->symtree->n.sym->name)
return true;
if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
&& e->symtree->n.sym->value
&& recursive_stmt_fcn (e->symtree->n.sym->value, sym))
return true;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
gfc_set_default_type (e->symtree->n.sym, 0, NULL);
break;
case EXPR_VARIABLE:
if (e->symtree && sym->name == e->symtree->n.sym->name)
return true;
if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
gfc_set_default_type (e->symtree->n.sym, 0, NULL);
break;
case EXPR_OP:
if (recursive_stmt_fcn (e->value.op.op1, sym)
|| recursive_stmt_fcn (e->value.op.op2, sym))
return true;
break;
default:
break;
}
if (e->ref)
{
for (ref = e->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
|| recursive_stmt_fcn (ref->u.ar.end[i], sym)
|| recursive_stmt_fcn (ref->u.ar.stride[i], sym))
return true;
}
break;
case REF_SUBSTRING:
if (recursive_stmt_fcn (ref->u.ss.start, sym)
|| recursive_stmt_fcn (ref->u.ss.end, sym))
return true;
break;
default:
break;
}
}
}
return false;
}
match
gfc_match_st_function (void)
{
gfc_error_buf old_error;
gfc_symbol *sym;
gfc_expr *expr;
match m;
m = gfc_match_symbol (&sym, 0);
if (m != MATCH_YES)
return m;
gfc_push_error (&old_error);
if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
sym->name, NULL) == FAILURE)
goto undo_error;
if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
goto undo_error;
m = gfc_match (" = %e%t", &expr);
if (m == MATCH_NO)
goto undo_error;
gfc_free_error (&old_error);
if (m == MATCH_ERROR)
return m;
if (recursive_stmt_fcn (expr, sym))
{
gfc_error ("Statement function at %L is recursive",
&expr->where);
return MATCH_ERROR;
}
sym->value = expr;
return MATCH_YES;
undo_error:
gfc_pop_error (&old_error);
return MATCH_NO;
}
static void
free_case (gfc_case * p)
{
if (p->low == p->high)
p->high = NULL;
gfc_free_expr (p->low);
gfc_free_expr (p->high);
gfc_free (p);
}
void
gfc_free_case_list (gfc_case * p)
{
gfc_case *q;
for (; p; p = q)
{
q = p->next;
free_case (p);
}
}
static match
match_case_selector (gfc_case ** cp)
{
gfc_case *c;
match m;
c = gfc_get_case ();
c->where = gfc_current_locus;
if (gfc_match_char (':') == MATCH_YES)
{
m = gfc_match_init_expr (&c->high);
if (m == MATCH_NO)
goto need_expr;
if (m == MATCH_ERROR)
goto cleanup;
}
else
{
m = gfc_match_init_expr (&c->low);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto need_expr;
if (gfc_match_char (':') != MATCH_YES)
c->high = c->low;
else
{
m = gfc_match_init_expr (&c->high);
if (m == MATCH_ERROR)
goto cleanup;
}
}
*cp = c;
return MATCH_YES;
need_expr:
gfc_error ("Expected initialization expression in CASE at %C");
cleanup:
free_case (c);
return MATCH_ERROR;
}
static match
match_case_eos (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
match m;
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (!gfc_current_block ())
{
gfc_error ("Expected the name of the select case construct at %C");
return MATCH_ERROR;
}
gfc_gobble_whitespace ();
m = gfc_match_name (name);
if (m != MATCH_YES)
return m;
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Expected case name of '%s' at %C",
gfc_current_block ()->name);
return MATCH_ERROR;
}
return gfc_match_eos ();
}
match
gfc_match_select (void)
{
gfc_expr *expr;
match m;
m = gfc_match_label ();
if (m == MATCH_ERROR)
return m;
m = gfc_match (" select case ( %e )%t", &expr);
if (m != MATCH_YES)
return m;
new_st.op = EXEC_SELECT;
new_st.expr = expr;
return MATCH_YES;
}
match
gfc_match_case (void)
{
gfc_case *c, *head, *tail;
match m;
head = tail = NULL;
if (gfc_current_state () != COMP_SELECT)
{
gfc_error ("Unexpected CASE statement at %C");
return MATCH_ERROR;
}
if (gfc_match ("% default") == MATCH_YES)
{
m = match_case_eos ();
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
new_st.op = EXEC_SELECT;
c = gfc_get_case ();
c->where = gfc_current_locus;
new_st.ext.case_list = c;
return MATCH_YES;
}
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
for (;;)
{
if (match_case_selector (&c) == MATCH_ERROR)
goto cleanup;
if (head == NULL)
head = c;
else
tail->next = c;
tail = c;
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
m = match_case_eos ();
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
new_st.op = EXEC_SELECT;
new_st.ext.case_list = head;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in CASE-specification at %C");
cleanup:
gfc_free_case_list (head);
return MATCH_ERROR;
}
static match
match_simple_where (void)
{
gfc_expr *expr;
gfc_code *c;
match m;
m = gfc_match (" ( %e )", &expr);
if (m != MATCH_YES)
return m;
m = gfc_match_assignment ();
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
c = gfc_get_code ();
c->op = EXEC_WHERE;
c->expr = expr;
c->next = gfc_get_code ();
*c->next = new_st;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;
new_st.block = c;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_WHERE);
cleanup:
gfc_free_expr (expr);
return MATCH_ERROR;
}
match
gfc_match_where (gfc_statement * st)
{
gfc_expr *expr;
match m0, m;
gfc_code *c;
m0 = gfc_match_label ();
if (m0 == MATCH_ERROR)
return m0;
m = gfc_match (" where ( %e )", &expr);
if (m != MATCH_YES)
return m;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
}
m = gfc_match_assignment ();
if (m == MATCH_NO)
gfc_syntax_error (ST_WHERE);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
return MATCH_ERROR;
}
*st = ST_WHERE;
c = gfc_get_code ();
c->op = EXEC_WHERE;
c->expr = expr;
c->next = gfc_get_code ();
*c->next = new_st;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;
new_st.block = c;
return MATCH_YES;
}
match
gfc_match_elsewhere (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *expr;
match m;
if (gfc_current_state () != COMP_WHERE)
{
gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
return MATCH_ERROR;
}
expr = NULL;
if (gfc_match_char ('(') == MATCH_YES)
{
m = gfc_match_expr (&expr);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
}
if (gfc_match_eos () != MATCH_YES)
{
m = gfc_match_name (name);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
if (strcmp (name, gfc_current_block ()->name) != 0)
{
gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
name, gfc_current_block ()->name);
goto cleanup;
}
}
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_ELSEWHERE);
cleanup:
gfc_free_expr (expr);
return MATCH_ERROR;
}
void
gfc_free_forall_iterator (gfc_forall_iterator * iter)
{
gfc_forall_iterator *next;
while (iter)
{
next = iter->next;
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->stride);
gfc_free (iter);
iter = next;
}
}
static match
match_forall_iterator (gfc_forall_iterator ** result)
{
gfc_forall_iterator *iter;
locus where;
match m;
where = gfc_current_locus;
iter = gfc_getmem (sizeof (gfc_forall_iterator));
m = gfc_match_expr (&iter->var);
if (m != MATCH_YES)
goto cleanup;
if (gfc_match_char ('=') != MATCH_YES
|| iter->var->expr_type != EXPR_VARIABLE)
{
m = MATCH_NO;
goto cleanup;
}
m = gfc_match_expr (&iter->start);
if (m != MATCH_YES)
goto cleanup;
if (gfc_match_char (':') != MATCH_YES)
goto syntax;
m = gfc_match_expr (&iter->end);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
if (gfc_match_char (':') == MATCH_NO)
iter->stride = gfc_int_expr (1);
else
{
m = gfc_match_expr (&iter->stride);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
}
iter->var->symtree->n.sym->forall_index = true;
*result = iter;
return MATCH_YES;
syntax:
gfc_error ("Syntax error in FORALL iterator at %C");
m = MATCH_ERROR;
cleanup:
gfc_current_locus = where;
gfc_free_forall_iterator (iter);
return m;
}
static match
match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
{
gfc_forall_iterator *head, *tail, *new;
gfc_expr *msk;
match m;
gfc_gobble_whitespace ();
head = tail = NULL;
msk = NULL;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
head = tail = new;
for (;;)
{
if (gfc_match_char (',') != MATCH_YES)
break;
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
{
tail->next = new;
tail = new;
continue;
}
m = gfc_match_expr (&msk);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
break;
}
if (gfc_match_char (')') == MATCH_NO)
goto syntax;
*phead = head;
*mask = msk;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FORALL);
cleanup:
gfc_free_expr (msk);
gfc_free_forall_iterator (head);
return MATCH_ERROR;
}
static match
match_simple_forall (void)
{
gfc_forall_iterator *head;
gfc_expr *mask;
gfc_code *c;
match m;
mask = NULL;
head = NULL;
c = NULL;
m = match_forall_header (&head, &mask);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
goto cleanup;
m = gfc_match_assignment ();
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
{
m = gfc_match_pointer_assignment ();
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
}
c = gfc_get_code ();
*c = new_st;
c->loc = gfc_current_locus;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
new_st.block->op = EXEC_FORALL;
new_st.block->next = c;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FORALL);
cleanup:
gfc_free_forall_iterator (head);
gfc_free_expr (mask);
return MATCH_ERROR;
}
match
gfc_match_forall (gfc_statement * st)
{
gfc_forall_iterator *head;
gfc_expr *mask;
gfc_code *c;
match m0, m;
head = NULL;
mask = NULL;
c = NULL;
m0 = gfc_match_label ();
if (m0 == MATCH_ERROR)
return MATCH_ERROR;
m = gfc_match (" forall");
if (m != MATCH_YES)
return m;
m = match_forall_header (&head, &mask);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_FORALL_BLOCK;
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
return MATCH_YES;
}
m = gfc_match_assignment ();
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
{
m = gfc_match_pointer_assignment ();
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
}
c = gfc_get_code ();
*c = new_st;
c->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
new_st.block->op = EXEC_FORALL;
new_st.block->next = c;
*st = ST_FORALL;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FORALL);
cleanup:
gfc_free_forall_iterator (head);
gfc_free_expr (mask);
gfc_free_statements (c);
return MATCH_NO;
}