diff options
Diffstat (limited to 'gcc/fortran/match.c')
| -rw-r--r-- | gcc/fortran/match.c | 3558 |
1 files changed, 3558 insertions, 0 deletions
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c new file mode 100644 index 00000000000..3c7504159a9 --- /dev/null +++ b/gcc/fortran/match.c @@ -0,0 +1,3558 @@ +/* Matching subroutines in all sizes, shapes and colors. + Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GNU G95. + +GNU G95 is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU G95 is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU G95; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include "config.h" +#include "system.h" +#include "flags.h" + +#include <stdarg.h> +#include <string.h> + +#include "gfortran.h" +#include "match.h" +#include "parse.h" + +/* For matching and debugging purposes. Order matters here! The + unary operators /must/ precede the binary plus and minus, or + the expression parser breaks. */ + +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 (NULL, INTRINSIC_NONE) +}; + + +/******************** Generic matching subroutines ************************/ + +/* In free form, match at least one space. Always matches in fixed + form. */ + +match +gfc_match_space (void) +{ + locus old_loc; + int c; + + if (gfc_current_file->form == FORM_FIXED) + return MATCH_YES; + + old_loc = *gfc_current_locus (); + + c = gfc_next_char (); + if (!gfc_is_whitespace (c)) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + gfc_gobble_whitespace (); + + return MATCH_YES; +} + + +/* Match an end of statement. End of statement is optional + whitespace, followed by a ';' or '\n' or comment '!'. If a + semicolon is found, we continue to eat whitespace and semicolons. */ + +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'); + + /* Fall through */ + + case '\n': + return MATCH_YES; + + case ';': + flag = 1; + continue; + } + + break; + } + + gfc_set_locus (&old_loc); + return (flag) ? MATCH_YES : MATCH_NO; +} + + +/* Match a literal integer on the input, setting the value on + MATCH_YES. Literal ints occur in kind-parameters as well as + old-style character length specifications. */ + +match +gfc_match_small_literal_int (int *value) +{ + locus old_loc; + char c; + int i; + + old_loc = *gfc_current_locus (); + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + if (!ISDIGIT (c)) + { + gfc_set_locus (&old_loc); + return MATCH_NO; + } + + i = c - '0'; + + for (;;) + { + old_loc = *gfc_current_locus (); + c = gfc_next_char (); + + if (!ISDIGIT (c)) + break; + + i = 10 * i + c - '0'; + + if (i > 99999999) + { + gfc_error ("Integer too large at %C"); + return MATCH_ERROR; + } + } + + gfc_set_locus (&old_loc); + + *value = i; + return MATCH_YES; +} + + +/* Match a small, constant integer expression, like in a kind + statement. On MATCH_YES, 'value' is set. */ + +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 (p); + m = MATCH_ERROR; + } + + *value = i; + return m; +} + + +/* Matches a statement label. Uses gfc_match_small_literal_int() to + do most of the work. */ + +match +gfc_match_st_label (gfc_st_label ** label, int allow_zero) +{ + locus old_loc; + match m; + int i; + + old_loc = *gfc_current_locus (); + + m = gfc_match_small_literal_int (&i); + if (m != MATCH_YES) + return m; + + if (((i == 0) && allow_zero) || i <= 99999) + { + *label = gfc_get_st_label (i); + return MATCH_YES; + } + + gfc_error ("Statement label at %C is out of range"); + gfc_set_locus (&old_loc); + return MATCH_ERROR; +} + + +/* Match and validate a label associated with a named IF, DO or SELECT + statement. If the symbol does not have the label attribute, we add + it. We also make sure the symbol does not refer to another + (active) block. A matched label is pointed to by gfc_new_block. */ + +match +gfc_match_label (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_state_data *p; + 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_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE) + return MATCH_ERROR; + + for (p = gfc_state_stack; p; p = p->previous) + if (p->sym == gfc_new_block) + { + gfc_error ("Label %s at %C already in use by a parent block", + gfc_new_block->name); + return MATCH_ERROR; + } + + return MATCH_YES; +} + + +/* Try and match the input against an array of possibilities. If one + potential matching string is a substring of another, the longest + match takes precedence. Spaces in the target strings are optional + spaces that do not necessarily have to be found in the input + stream. In fixed mode, spaces never appear. If whitespace is + matched, it matches unlimited whitespace in the input. For this + reason, the 'mp' member of the mstring structure is used to track + the progress of each potential match. + + If there is no match we return the tag associated with the + terminating NULL mstring structure and leave the locus pointer + where it started. If there is a match we return the tag member of + the matched mstring and leave the locus pointer after the matched + character. + + A '%' character is a mandatory space. */ + +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 (); + + /* Apply the next character to the current possibilities. */ + for (p = a; p->string != NULL; p++) + { + if (p->mp == NULL) + continue; + + if (*p->mp == ' ') + { + /* Space matches 1+ whitespace(s). */ + if ((gfc_current_file->form == FORM_FREE) + && gfc_is_whitespace (c)) + continue; + + p->mp++; + } + + if (*p->mp != c) + { + /* Match failed. */ + p->mp = NULL; + possibles--; + continue; + } + + p->mp++; + if (*p->mp == '\0') + { + /* Found a match. */ + match_loc = *gfc_current_locus (); + best_match = p; + possibles--; + p->mp = NULL; + } + } + } + + gfc_set_locus (&match_loc); + + return (best_match == NULL) ? no_match : best_match->tag; +} + + +/* See if the current input looks like a name of some sort. Modifies + the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */ + +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_set_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_set_locus (&old_loc); + + return MATCH_YES; +} + + +/* Match a symbol on the input. Modifies the pointer to the symbol + pointer if successful. */ + +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; + } + return m; +} + +/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, + we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this + in matchexp.c. */ + +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 a loop control phrase: + + <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ] + + If the final integer expression is not present, a constant unity + expression is returned. We don't return MATCH_ERROR until after + the equals sign is seen. */ + +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; + + /* Match the start of an iterator without affecting the symbol + table. */ + + start = *gfc_current_locus (); + m = gfc_match (" %n =", name); + gfc_set_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; + } + + if (var->symtree->n.sym->attr.pointer) + { + gfc_error ("Loop variable at %C cannot have the POINTER attribute"); + 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; +} + + +/* Tries to match the next non-whitespace character on the input. + This subroutine does not 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_set_locus (&where); + return MATCH_NO; +} + + +/* General purpose matching subroutine. The target string is a + scanf-like format string in which spaces correspond to arbitrary + whitespace (including no whitespace), characters correspond to + themselves. The %-codes are: + + %% Literal percent sign + %e Expression, pointer to a pointer is set + %s Symbol, pointer to the symbol is set + %n Name, character buffer is set to name + %t Matches end of statement. + %o Matches an intrinsic operator, returned as an INTRINSIC enum. + %l Matches a statement label + %v Matches a variable expression (an lvalue) + % Matches a required space (in free form) and optional spaces. */ + +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, 0); + 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; /* Fall through to character matcher */ + + 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) + { + /* Clean up after a failed match. */ + gfc_set_locus (&old_loc); + va_start (argp, target); + + p = target; + for (; matches > 0; matches--) + { + while (*p++ != '%'); + + switch (*p++) + { + case '%': + matches++; + break; /* Skip */ + + case 'I': + case 'L': + case 'C': + if (*p++ == 'e') + goto undo_expr; + break; + + /* Matches that don't have to be undone */ + case 'o': + case 'l': + case 'n': + case 's': + (void)va_arg (argp, void **); + break; + + case 'e': + case 'E': + case 'v': + undo_expr: + vp = va_arg (argp, void **); + gfc_free_expr (*vp); + *vp = NULL; + break; + } + } + + va_end (argp); + } + + return m; +} + + +/*********************** Statement level matching **********************/ + +/* Matches the start of a program unit, which is the program keyword + followed by an optional symbol. */ + +match +gfc_match_program (void) +{ + gfc_symbol *sym; + match m; + + m = gfc_match_eos (); + if (m == MATCH_YES) + return 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, NULL) == FAILURE) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Match a simple assignment statement. */ + +match +gfc_match_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) + goto cleanup; + + m = gfc_match (" %e%t", &rvalue); + if (m != MATCH_YES) + goto cleanup; + + gfc_set_sym_referenced (lvalue->symtree->n.sym); + + new_st.op = EXEC_ASSIGN; + new_st.expr = lvalue; + new_st.expr2 = rvalue; + + return MATCH_YES; + +cleanup: + gfc_set_locus (&old_loc); + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; +} + + +/* Match a pointer assignment statement. */ + +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_set_locus (&old_loc); + gfc_free_expr (lvalue); + gfc_free_expr (rvalue); + return m; +} + + +/* The IF statement is a bit of a pain. First of all, there are three + forms of it, the simple IF, the IF that starts a block and the + arithmetic IF. + + There is a problem with the simple IF and that is the fact that we + only have a single level of undo information on symbols. What this + means is for a simple IF, we must re-match the whole IF statement + multiple times in order to guarantee that the symbol table ends up + in the proper state. */ + +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; + } + + 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; + } + + /* At this point the only thing left is a simple IF statement. At + this point, n has to be MATCH_NO, so we don't have to worry about + re-matching a block label. From what we've got so far, try + matching an assignment. */ + + *if_type = ST_SIMPLE_IF; + + m = gfc_match_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ + + m = gfc_match_pointer_assignment (); + if (m == MATCH_YES) + goto got_match; + + gfc_free_expr (expr); + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */ + + /* Look at the next keyword to see which matcher to call. Matching + the keyword doesn't affect the symbol table, so we don't have to + restore between tries. */ + +#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 ("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 ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) + match ("go to", gfc_match_goto, ST_GOTO) + 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 ("pause", gfc_match_stop, ST_PAUSE) + match ("stop", gfc_match_stop, ST_STOP) + match ("write", gfc_match_write, ST_WRITE) + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + 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; + } + + /* At this point, we've matched the single IF and the action clause + is in new_st. Rearrange things so that the IF statement appears + in new_st. */ + + 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 an ELSE statement. */ + +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 an ELSE IF statement. */ + +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; +} + + +/* Free a gfc_iterator structure. */ + +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 a DO statement. */ + +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; + +/* Match an infinite DO, make it like a DO WHILE(.TRUE.) */ + + if (gfc_match_eos () == MATCH_YES) + { + iter.end = gfc_logical_expr (1, NULL); + new_st.op = EXEC_DO_WHILE; + goto done; + } + + m = gfc_match_st_label (&label, 0); + if (m == MATCH_ERROR) + goto cleanup; + + gfc_match_char (','); + + if (gfc_match ("% ") != MATCH_YES) + return MATCH_NO; + + /* See if we have a DO WHILE. */ + if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) + { + new_st.op = EXEC_DO_WHILE; + goto done; + } + + /* The abortive DO WHILE may have done something to the symbol + table, so we start over: */ + gfc_undo_symbols (); + gfc_set_locus (&old_loc); + + gfc_match_label (); /* This won't error */ + gfc_match (" do "); /* This will work */ + + gfc_match_st_label (&label, 0); /* Can't error out */ + gfc_match_char (','); /* Optional comma */ + + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_NO) + return MATCH_NO; + if (m == MATCH_ERROR) + goto cleanup; + + 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; +} + + +/* Match an EXIT or CYCLE statement. */ + +static match +match_exit_cycle (gfc_statement st, gfc_exec_op op) +{ + gfc_state_data *p; + 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; + } + } + + /* Find the loop mentioned specified by the label (or lack of a + label). */ + for (p = gfc_state_stack; p; p = p->previous) + if (p->state == COMP_DO && (sym == NULL || sym == p->sym)) + break; + + 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; + } + + /* Save the first statement in the loop - needed by the backend. */ + new_st.ext.whichloop = p->head; + + new_st.op = op; +/* new_st.sym = sym;*/ + + return MATCH_YES; +} + + +/* Match the EXIT statement. */ + +match +gfc_match_exit (void) +{ + + return match_exit_cycle (ST_EXIT, EXEC_EXIT); +} + + +/* Match the CYCLE statement. */ + +match +gfc_match_cycle (void) +{ + + return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); +} + + +/* Match a number or character constant after a STOP or PAUSE statement. */ + +static match +gfc_match_stopcode (gfc_statement st) +{ + int stop_code; + gfc_expr *e; + match m; + + stop_code = 0; + e = NULL; + + if (gfc_match_eos () != MATCH_YES) + { + m = gfc_match_small_literal_int (&stop_code); + if (m == MATCH_ERROR) + goto cleanup; + + if (m == MATCH_YES && stop_code > 99999) + { + gfc_error ("STOP code out of range at %C"); + goto cleanup; + } + + if (m == MATCH_NO) + { + /* Try a character constant. */ + 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 the (deprecated) PAUSE statement. */ + +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 the STOP statement. */ + +match +gfc_match_stop (void) +{ + return gfc_match_stopcode (ST_STOP); +} + + +/* Match a CONTINUE statement. */ + +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 the (deprecated) ASSIGN statement. */ + +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 the GO TO statement. As a computed GOTO statement is + matched, it is transformed into an equivalent SELECT block. No + tree is necessary, and the resulting jumps-to-jumps are + specifically optimized away by the back end. */ + +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; + } + + /* The assigned GO TO statement. */ + + 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; + + expr->symtree->n.sym->attr.assign = 1; + new_st.op = EXEC_GOTO; + new_st.expr = expr; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + /* Match label list. */ + 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, 0); + 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; + } + + /* Last chance is a computed GO TO statement. */ + 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, 0); + 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; + } + + /* Get the rest of the statement. */ + gfc_match_char (','); + + if (gfc_match (" %e%t", &expr) != MATCH_YES) + goto syntax; + + /* At this point, a computed GOTO has been fully matched and an + equivalent SELECT statement constructed. */ + + new_st.op = EXEC_SELECT; + new_st.expr = NULL; + + /* Hack: For a "real" SELECT, the expression is in expr. We put + it in expr2 so we can distinguish then and produce the correct + diagnostics. */ + 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; +} + + +/* Frees a list of gfc_alloc structures. */ + +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 an ALLOCATE statement. */ + +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_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 (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 (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 a NULLIFY statement. A NULLIFY statement is transformed into + a set of pointer assignments to intrinsic NULL(). */ + +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_pure (NULL) && gfc_impure_variable (p->symtree->n.sym)) + { + gfc_error + ("Illegal variable in NULLIFY at %C for a PURE procedure"); + goto cleanup; + } + + /* build ' => NULL() ' */ + e = gfc_get_expr (); + e->where = *gfc_current_locus (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; + + /* Chain to list */ + 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_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NULLIFY); + +cleanup: + gfc_free_statements (tail); + return MATCH_ERROR; +} + + +/* Match a DEALLOCATE statement. */ + +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_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 && 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_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 a RETURN statement. */ + +match +gfc_match_return (void) +{ + gfc_expr *e; + match m; + + 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; + } + + 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: + new_st.op = EXEC_RETURN; + new_st.expr = e; + + return MATCH_YES; +} + + +/* Match a CALL statement. The tricky part here are possible + alternate return specifiers. We handle these by having all + "subroutines" actually return an integer via a register that gives + the return number. If the call specifies alternate returns, we + generate code for a SELECT statement whose case clauses contain + GOTOs to the various labels. */ + +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, 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; + } + + /* If any alternate return labels were found, construct a SELECT + statement that will jump to the right place. */ + + 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); /* Can't fail */ + + 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; +} + + +/* Match an IMPLICIT NONE statement. Actually, this statement is + already matched in parse.c, or we would not end up here in the + first place. So the only thing we need to check, is if there is + trailing garbage. If not, the match is successful. */ + +match +gfc_match_implicit_none (void) +{ + + return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO; +} + + +/* Match the letter range(s) of an IMPLICIT statement. */ + +static match +match_implicit_range (gfc_typespec * ts) +{ + int c, c1, c2, inner; + locus cur_loc; + + cur_loc = *gfc_current_locus (); + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if (c != '(') + { + gfc_error ("Missing character range in IMPLICIT at %C"); + goto bad; + } + + inner = 1; + while (inner) + { + gfc_gobble_whitespace (); + c1 = gfc_next_char (); + if (!ISALPHA (c1)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + switch (c) + { + case ')': + inner = 0; /* Fall through */ + + case ',': + c2 = c1; + break; + + case '-': + gfc_gobble_whitespace (); + c2 = gfc_next_char (); + if (!ISALPHA (c2)) + goto bad; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + + if ((c != ',') && (c != ')')) + goto bad; + if (c == ')') + inner = 0; + + break; + + default: + goto bad; + } + + if (c1 > c2) + { + gfc_error ("Letters must be in alphabetic order in " + "IMPLICIT statement at %C"); + goto bad; + } + + /* See if we can add the newly matched range to the pending + implicits from this IMPLICIT statement. We do not check for + conflicts with whatever earlier IMPLICIT statements may have + set. This is done when we've successfully finished matching + the current one. */ + if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS) + goto bad; + } + + return MATCH_YES; + +bad: + gfc_syntax_error (ST_IMPLICIT); + + gfc_set_locus (&cur_loc); + return MATCH_ERROR; +} + + +/* Match an IMPLICIT statement, storing the types for + gfc_set_implicit() if the statement is accepted by the parser. + There is a strange looking, but legal syntactic construction + possible. It looks like: + + IMPLICIT INTEGER (a-b) (c-d) + + This is legal if "a-b" is a constant expression that happens to + equal one of the legal kinds for integers. The real problem + happens with an implicit specification that looks like: + + IMPLICIT INTEGER (a-b) + + In this case, a typespec matcher that is "greedy" (as most of the + matchers are) gobbles the character range as a kindspec, leaving + nothing left. We therefore have to go a bit more slowly in the + matching process by inhibiting the kindspec checking during + typespec matching and checking for a kind later. */ + +match +gfc_match_implicit (void) +{ + gfc_typespec ts; + locus cur_loc; + int c; + match m; + + /* We don't allow empty implicit statements. */ + if (gfc_match_eos () == MATCH_YES) + { + gfc_error ("Empty IMPLICIT statement at %C"); + return MATCH_ERROR; + } + + /* First cleanup. */ + gfc_clear_new_implicit (); + + do + { + /* A basic type is mandatory here. */ + m = gfc_match_type_spec (&ts, 0); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + cur_loc = *gfc_current_locus (); + m = match_implicit_range (&ts); + + if (m == MATCH_YES) + { + /* Looks like we have the <TYPE> (<RANGE>). */ + gfc_gobble_whitespace (); + c = gfc_next_char (); + if ((c == '\n') || (c == ',')) + continue; + + gfc_set_locus (&cur_loc); + } + + /* Last chance -- check <TYPE> (<KIND>) (<RANGE>). */ + m = gfc_match_kind_spec (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + { + m = gfc_match_old_kind_spec (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + } + + m = match_implicit_range (&ts); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_NO) + goto syntax; + + gfc_gobble_whitespace (); + c = gfc_next_char (); + if ((c != '\n') && (c != ',')) + goto syntax; + + } + while (c == ','); + + /* All we need to now is try to merge the new implicit types back + into the existing types. This will fail if another implicit + type is already defined for a letter. */ + return (gfc_merge_new_implicit () == SUCCESS) ? + MATCH_YES : MATCH_ERROR; + +syntax: + gfc_syntax_error (ST_IMPLICIT); + +error: + return MATCH_ERROR; +} + + +/* Match a common block name. */ + +static match +match_common_name (gfc_symbol ** sym) +{ + match m; + + if (gfc_match_char ('/') == MATCH_NO) + return MATCH_NO; + + if (gfc_match_char ('/') == MATCH_YES) + { + *sym = NULL; + return MATCH_YES; + } + + m = gfc_match_symbol (sym, 0); + + 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 a COMMON statement. */ + +match +gfc_match_common (void) +{ + gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common; + gfc_array_spec *as; + match m; + + old_blank_common = gfc_current_ns->blank_common; + if (old_blank_common) + { + while (old_blank_common->common_next) + old_blank_common = old_blank_common->common_next; + } + + common_name = NULL; + as = NULL; + + if (gfc_match_eos () == MATCH_YES) + goto syntax; + + for (;;) + { + m = match_common_name (&common_name); + if (m == MATCH_ERROR) + goto cleanup; + + if (common_name == NULL) + head = &gfc_current_ns->blank_common; + else + { + head = &common_name->common_head; + + if (!common_name->attr.common + && gfc_add_common (&common_name->attr, NULL) == FAILURE) + goto cleanup; + } + + if (*head == NULL) + tail = NULL; + else + { + tail = *head; + while (tail->common_next) + tail = tail->common_next; + } + + /* Grab the list of symbols. */ + 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, NULL) == FAILURE) + goto cleanup; + + /* Derived type names must have the SEQUENCE attribute. */ + 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; + + /* Deal with an optional array specification after the + symbol name. */ + 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, 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; + } + + if (gfc_match_eos () == MATCH_YES) + goto done; + if (gfc_peek_char () == '/') + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + 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 = NULL; + gfc_free_array_spec (as); + return MATCH_ERROR; +} + + +/* Match a BLOCK DATA program unit. */ + +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, NULL) == FAILURE) + return MATCH_ERROR; + + gfc_new_block = sym; + + return MATCH_YES; +} + + +/* Free a namelist structure. */ + +void +gfc_free_namelist (gfc_namelist * name) +{ + gfc_namelist *n; + + for (; name; name = n) + { + n = name->next; + gfc_free (name); + } +} + + +/* Match a NAMELIST statement. */ + +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 + && gfc_add_flavor (&group_name->attr, FL_NAMELIST, 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, NULL) == FAILURE) + goto error; + + /* TODO: worry about PRIVATE members of a PUBLIC namelist + group. */ + + nl = gfc_get_namelist (); + nl->sym = sym; + + 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 a MODULE statement. */ + +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, NULL) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + +/* Free equivalence sets and lists. Recursively is the easiest way to + do this. */ + +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 an EQUIVALENCE statement. */ + +match +gfc_match_equivalence (void) +{ + gfc_equiv *eq, *set, *tail; + gfc_ref *ref; + match m; + + 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; + + for (;;) + { + m = gfc_match_variable (&set->expr, 1); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + 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; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + set->eq = gfc_get_equiv (); + set = set->eq; + } + + 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; +} + + +/* Match a statement function declaration. It is so easy to match + non-statement function statements with a MATCH_ERROR as opposed to + MATCH_NO that we suppress error message in most cases. */ + +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, 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; + if (m == MATCH_ERROR) + return m; + + sym->value = expr; + + return MATCH_YES; + +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; +} + + +/********************* DATA statement subroutines *********************/ + +/* Free a gfc_data_variable structure and everything beneath it. */ + +static void +free_variable (gfc_data_variable * p) +{ + gfc_data_variable *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free_iterator (&p->iter, 0); + free_variable (p->list); + + gfc_free (p); + } +} + + +/* Free a gfc_data_value structure and everything beneath it. */ + +static void +free_value (gfc_data_value * p) +{ + gfc_data_value *q; + + for (; p; p = q) + { + q = p->next; + gfc_free_expr (p->expr); + gfc_free (p); + } +} + + +/* Free a list of gfc_data structures. */ + +void +gfc_free_data (gfc_data * p) +{ + gfc_data *q; + + for (; p; p = q) + { + q = p->next; + + free_variable (p->var); + free_value (p->value); + + gfc_free (p); + } +} + + +static match var_element (gfc_data_variable *); + +/* Match a list of variables terminated by an iterator and a right + parenthesis. */ + +static match +var_list (gfc_data_variable * parent) +{ + gfc_data_variable *tail, var; + match m; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail = gfc_get_data_variable (); + *tail = var; + + parent->list = tail; + + for (;;) + { + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + m = gfc_match_iterator (&parent->iter, 1); + if (m == MATCH_YES) + break; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = var_element (&var); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + goto syntax; + + tail->next = gfc_get_data_variable (); + tail = tail->next; + + *tail = var; + } + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a single element in a data variable list, which can be a + variable-iterator list. */ + +static match +var_element (gfc_data_variable * new) +{ + match m; + + memset (new, '\0', sizeof (gfc_data_variable)); + + if (gfc_match_char ('(') == MATCH_YES) + return var_list (new); + + m = gfc_match_variable (&new->expr, 0); + if (m != MATCH_YES) + return m; + + if (new->expr->symtree->n.sym->value != NULL) + { + gfc_error ("Variable '%s' at %C already has an initialization", + new->expr->symtree->n.sym->name); + return MATCH_ERROR; + } + + new->expr->symtree->n.sym->attr.data = 1; + return MATCH_YES; +} + + +/* Match the top-level list of data variables. */ + +static match +top_var_list (gfc_data * d) +{ + gfc_data_variable var, *tail, *new; + match m; + + tail = NULL; + + for (;;) + { + m = var_element (&var); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_variable (); + *new = var; + + if (tail == NULL) + d->var = new; + else + tail->next = new; + + tail = new; + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +static match +match_data_constant (gfc_expr ** result) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symbol *sym; + gfc_expr *expr; + match m; + + m = gfc_match_literal_constant (&expr, 1); + if (m == MATCH_YES) + { + *result = expr; + return MATCH_YES; + } + + if (m == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match_null (result); + if (m != MATCH_NO) + return m; + + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; + + if (gfc_find_symbol (name, NULL, 1, &sym)) + return MATCH_ERROR; + + if (sym == NULL || sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C", + name); + return MATCH_ERROR; + } + + *result = gfc_copy_expr (sym->value); + return MATCH_YES; +} + + +/* Match a list of values in a DATA statement. The leading '/' has + already been seen at this point. */ + +static match +top_val_list (gfc_data * data) +{ + gfc_data_value *new, *tail; + gfc_expr *expr; + const char *msg; + match m; + + tail = NULL; + + for (;;) + { + m = match_data_constant (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + new = gfc_get_data_value (); + + if (tail == NULL) + data->value = new; + else + tail->next = new; + + tail = new; + + if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) + { + tail->expr = expr; + tail->repeat = 1; + } + else + { + msg = gfc_extract_int (expr, &tail->repeat); + gfc_free_expr (expr); + if (msg != NULL) + { + gfc_error (msg); + return MATCH_ERROR; + } + + m = match_data_constant (&tail->expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + } + + if (gfc_match_char ('/') == MATCH_YES) + break; + if (gfc_match_char (',') == MATCH_NO) + goto syntax; + } + + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_DATA); + return MATCH_ERROR; +} + + +/* Match a DATA statement. */ + +match +gfc_match_data (void) +{ + gfc_data *new; + match m; + + for (;;) + { + new = gfc_get_data (); + new->where = *gfc_current_locus (); + + m = top_var_list (new); + if (m != MATCH_YES) + goto cleanup; + + m = top_val_list (new); + if (m != MATCH_YES) + goto cleanup; + + new->next = gfc_current_ns->data; + gfc_current_ns->data = new; + + if (gfc_match_eos () == MATCH_YES) + break; + + gfc_match_char (','); /* Optional comma */ + } + + if (gfc_pure (NULL)) + { + gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); + return MATCH_ERROR; + } + + return MATCH_YES; + +cleanup: + gfc_free_data (new); + return MATCH_ERROR; +} + + +/***************** SELECT CASE subroutines ******************/ + +/* Free a single case structure. */ + +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); +} + + +/* Free a list of case structures. */ + +void +gfc_free_case_list (gfc_case * p) +{ + gfc_case *q; + + for (; p; p = q) + { + q = p->next; + free_case (p); + } +} + + +/* Match a single case selector. */ + +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_expr (&c->high); + if (m == MATCH_NO) + goto need_expr; + if (m == MATCH_ERROR) + goto cleanup; + } + + else + { + m = gfc_match_expr (&c->low); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto need_expr; + + /* If we're not looking at a ':' now, make a range out of a single + target. Else get the upper bound for the case range. */ + if (gfc_match_char (':') != MATCH_YES) + c->high = c->low; + else + { + m = gfc_match_expr (&c->high); + if (m == MATCH_ERROR) + goto cleanup; + /* MATCH_NO is fine. It's OK if nothing is there! */ + } + } + + *cp = c; + return MATCH_YES; + +need_expr: + gfc_error ("Expected expression in CASE at %C"); + +cleanup: + free_case (c); + return MATCH_ERROR; +} + + +/* Match the end of a case statement. */ + +static match +match_case_eos (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + + 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 a SELECT statement. */ + +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 a CASE statement. */ + +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); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + +/********************* WHERE subroutines ********************/ + +/* Match a WHERE statement. */ + +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; + } + + /* We've got a simple WHERE statement. */ + *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 an ELSEWHERE statement. We leave behind a WHERE node in + new_st if successful. */ + +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) + { /* Better be a name at this point */ + 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; +} + + +/******************** FORALL subroutines ********************/ + +/* Free a list of FORALL iterators. */ + +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; + } +} + + +/* Match an iterator as part of a FORALL statement. The format is: + + <var> = <start>:<end>[:<stride>][, <scalar mask>] */ + +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_variable (&iter->var, 0); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char ('=') != MATCH_YES) + { + m = MATCH_NO; + goto cleanup; + } + + m = gfc_match_expr (&iter->start); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + 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; + } + + *result = iter; + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in FORALL iterator at %C"); + m = MATCH_ERROR; + +cleanup: + gfc_set_locus (&where); + gfc_free_forall_iterator (iter); + return m; +} + + +/* Match a FORALL statement. */ + +match +gfc_match_forall (gfc_statement * st) +{ + gfc_forall_iterator *head, *tail, *new; + gfc_expr *mask; + gfc_code *c; + match m0, m; + + head = tail = 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_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; + } + + /* Have to have a mask expression. */ + m = gfc_match_expr (&mask); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + break; + } + + if (gfc_match_char (')') == 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; + + 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; + + *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; +} |