aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.1/gcc/fortran/match.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.1/gcc/fortran/match.c')
-rw-r--r--gcc-4.8.1/gcc/fortran/match.c5823
1 files changed, 0 insertions, 5823 deletions
diff --git a/gcc-4.8.1/gcc/fortran/match.c b/gcc-4.8.1/gcc/fortran/match.c
deleted file mode 100644
index e9a701bb6..000000000
--- a/gcc-4.8.1/gcc/fortran/match.c
+++ /dev/null
@@ -1,5823 +0,0 @@
-/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000-2013 Free Software Foundation, Inc.
- Contributed by Andy Vaught
-
-This file is part of GCC.
-
-GCC 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 3, or (at your option) any later
-version.
-
-GCC 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 GCC; see the file COPYING3. If not see
-<http://www.gnu.org/licenses/>. */
-
-#include "config.h"
-#include "system.h"
-#include "coretypes.h"
-#include "flags.h"
-#include "gfortran.h"
-#include "match.h"
-#include "parse.h"
-#include "tree.h"
-
-int gfc_matching_ptr_assignment = 0;
-int gfc_matching_procptr_assignment = 0;
-bool gfc_matching_prefix = false;
-
-/* Stack of SELECT TYPE statements. */
-gfc_select_type_stack *select_type_stack = NULL;
-
-/* For debugging and diagnostic purposes. Return the textual representation
- of the intrinsic operator OP. */
-const char *
-gfc_op2string (gfc_intrinsic_op op)
-{
- switch (op)
- {
- case INTRINSIC_UPLUS:
- case INTRINSIC_PLUS:
- return "+";
-
- case INTRINSIC_UMINUS:
- case INTRINSIC_MINUS:
- return "-";
-
- case INTRINSIC_POWER:
- return "**";
- case INTRINSIC_CONCAT:
- return "//";
- case INTRINSIC_TIMES:
- return "*";
- case INTRINSIC_DIVIDE:
- return "/";
-
- case INTRINSIC_AND:
- return ".and.";
- case INTRINSIC_OR:
- return ".or.";
- case INTRINSIC_EQV:
- return ".eqv.";
- case INTRINSIC_NEQV:
- return ".neqv.";
-
- case INTRINSIC_EQ_OS:
- return ".eq.";
- case INTRINSIC_EQ:
- return "==";
- case INTRINSIC_NE_OS:
- return ".ne.";
- case INTRINSIC_NE:
- return "/=";
- case INTRINSIC_GE_OS:
- return ".ge.";
- case INTRINSIC_GE:
- return ">=";
- case INTRINSIC_LE_OS:
- return ".le.";
- case INTRINSIC_LE:
- return "<=";
- case INTRINSIC_LT_OS:
- return ".lt.";
- case INTRINSIC_LT:
- return "<";
- case INTRINSIC_GT_OS:
- return ".gt.";
- case INTRINSIC_GT:
- return ">";
- case INTRINSIC_NOT:
- return ".not.";
-
- case INTRINSIC_ASSIGN:
- return "=";
-
- case INTRINSIC_PARENTHESES:
- return "parens";
-
- default:
- break;
- }
-
- gfc_internal_error ("gfc_op2string(): Bad code");
- /* Not reached. */
-}
-
-
-/******************** Generic matching subroutines ************************/
-
-/* This function scans the current statement counting the opened and closed
- parenthesis to make sure they are balanced. */
-
-match
-gfc_match_parens (void)
-{
- locus old_loc, where;
- int count;
- gfc_instring instring;
- gfc_char_t c, quote;
-
- old_loc = gfc_current_locus;
- count = 0;
- instring = NONSTRING;
- quote = ' ';
-
- for (;;)
- {
- c = gfc_next_char_literal (instring);
- if (c == '\n')
- break;
- if (quote == ' ' && ((c == '\'') || (c == '"')))
- {
- quote = c;
- instring = INSTRING_WARN;
- continue;
- }
- if (quote != ' ' && c == quote)
- {
- quote = ' ';
- instring = NONSTRING;
- continue;
- }
-
- if (c == '(' && quote == ' ')
- {
- count++;
- where = gfc_current_locus;
- }
- if (c == ')' && quote == ' ')
- {
- count--;
- where = gfc_current_locus;
- }
- }
-
- gfc_current_locus = old_loc;
-
- if (count > 0)
- {
- gfc_error ("Missing ')' in statement at or before %L", &where);
- return MATCH_ERROR;
- }
- if (count < 0)
- {
- gfc_error ("Missing '(' in statement at or before %L", &where);
- return MATCH_ERROR;
- }
-
- return MATCH_YES;
-}
-
-
-/* See if the next character is a special character that has
- escaped by a \ via the -fbackslash option. */
-
-match
-gfc_match_special_char (gfc_char_t *res)
-{
- int len, i;
- gfc_char_t c, n;
- match m;
-
- m = MATCH_YES;
-
- switch ((c = gfc_next_char_literal (INSTRING_WARN)))
- {
- case 'a':
- *res = '\a';
- break;
- case 'b':
- *res = '\b';
- break;
- case 't':
- *res = '\t';
- break;
- case 'f':
- *res = '\f';
- break;
- case 'n':
- *res = '\n';
- break;
- case 'r':
- *res = '\r';
- break;
- case 'v':
- *res = '\v';
- break;
- case '\\':
- *res = '\\';
- break;
- case '0':
- *res = '\0';
- break;
-
- case 'x':
- case 'u':
- case 'U':
- /* Hexadecimal form of wide characters. */
- len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8));
- n = 0;
- for (i = 0; i < len; i++)
- {
- char buf[2] = { '\0', '\0' };
-
- c = gfc_next_char_literal (INSTRING_WARN);
- if (!gfc_wide_fits_in_byte (c)
- || !gfc_check_digit ((unsigned char) c, 16))
- return MATCH_NO;
-
- buf[0] = (unsigned char) c;
- n = n << 4;
- n += strtol (buf, NULL, 16);
- }
- *res = n;
- break;
-
- default:
- /* Unknown backslash codes are simply not expanded. */
- m = MATCH_NO;
- break;
- }
-
- return m;
-}
-
-
-/* In free form, match at least one space. Always matches in fixed
- form. */
-
-match
-gfc_match_space (void)
-{
- locus old_loc;
- char c;
-
- if (gfc_current_form == FORM_FIXED)
- return MATCH_YES;
-
- old_loc = gfc_current_locus;
-
- c = gfc_next_ascii_char ();
- if (!gfc_is_whitespace (c))
- {
- gfc_current_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;
- char c;
-
- flag = 0;
-
- for (;;)
- {
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- c = gfc_next_ascii_char ();
- switch (c)
- {
- case '!':
- do
- {
- c = gfc_next_ascii_char ();
- }
- while (c != '\n');
-
- /* Fall through. */
-
- case '\n':
- return MATCH_YES;
-
- case ';':
- flag = 1;
- continue;
- }
-
- break;
- }
-
- gfc_current_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. If cnt is non-NULL it
- will be set to the number of digits. */
-
-match
-gfc_match_small_literal_int (int *value, int *cnt)
-{
- locus old_loc;
- char c;
- int i, j;
-
- old_loc = gfc_current_locus;
-
- *value = -1;
- gfc_gobble_whitespace ();
- c = gfc_next_ascii_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_ascii_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 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;
-}
-
-
-/* This function is the same as the gfc_match_small_int, except that
- we're keeping the pointer to the expr. This function could just be
- removed and the previously mentioned one modified, though all calls
- to it would have to be modified then (and there were a number of
- them). Return MATCH_ERROR if fail to extract the int; otherwise,
- return the result of gfc_match_expr(). The expr (if any) that was
- matched is returned in the parameter expr. */
-
-match
-gfc_match_small_int_expr (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);
-
- 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)
-{
- 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 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];
- 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;
-}
-
-
-/* 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.
- Note that options.c restricts max_identifier_length to not more
- than GFC_MAX_SYMBOL_LEN. */
-
-match
-gfc_match_name (char *buffer)
-{
- locus old_loc;
- int i;
- char c;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- c = gfc_next_ascii_char ();
- if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
- {
- if (gfc_error_flag_test() == 0 && c != '(')
- gfc_error ("Invalid character in name at %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_ascii_char ();
- }
- while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
-
- if (c == '$' && !gfc_option.flag_dollar_ok)
- {
- gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
- "as an extension");
- return MATCH_ERROR;
- }
-
- buffer[i] = '\0';
- gfc_current_locus = old_loc;
-
- return MATCH_YES;
-}
-
-
-/* Match a valid name for C, which is almost the same as for Fortran,
- except that you can start with an underscore, etc.. It could have
- been done by modifying the gfc_match_name, but this way other
- things C allows can be done, such as no limits on the length.
- Also, by rewriting it, we use the gfc_next_char_C() to prevent the
- input characters from being automatically lower cased, since C is
- case sensitive. The parameter, buffer, is used to return the name
- that is matched. Return MATCH_ERROR if the name is not a valid C
- name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
- we successfully match a C name. */
-
-match
-gfc_match_name_C (const char **buffer)
-{
- locus old_loc;
- size_t i = 0;
- gfc_char_t c;
- char* buf;
- size_t cursz = 16;
-
- old_loc = gfc_current_locus;
- gfc_gobble_whitespace ();
-
- /* Get the next char (first possible char of name) and see if
- it's valid for C (either a letter or an underscore). */
- c = gfc_next_char_literal (INSTRING_WARN);
-
- /* If the user put nothing expect spaces between the quotes, it is valid
- and simply means there is no name= specifier and the name is the Fortran
- symbol name, all lowercase. */
- if (c == '"' || c == '\'')
- {
- gfc_current_locus = old_loc;
- return MATCH_YES;
- }
-
- if (!ISALPHA (c) && c != '_')
- {
- gfc_error ("Invalid C name in NAME= specifier at %C");
- return MATCH_ERROR;
- }
-
- buf = XNEWVEC (char, cursz);
- /* Continue to read valid variable name characters. */
- do
- {
- gcc_assert (gfc_wide_fits_in_byte (c));
-
- buf[i++] = (unsigned char) c;
-
- if (i >= cursz)
- {
- cursz *= 2;
- buf = XRESIZEVEC (char, buf, cursz);
- }
-
- old_loc = gfc_current_locus;
-
- /* Get next char; param means we're in a string. */
- c = gfc_next_char_literal (INSTRING_WARN);
- } while (ISALNUM (c) || c == '_');
-
- /* The binding label will be needed later anyway, so just insert it
- into the symbol table. */
- buf[i] = '\0';
- *buffer = IDENTIFIER_POINTER (get_identifier (buf));
- XDELETEVEC (buf);
- gfc_current_locus = old_loc;
-
- /* See if we stopped because of whitespace. */
- if (c == ' ')
- {
- gfc_gobble_whitespace ();
- c = gfc_peek_ascii_char ();
- if (c != '"' && c != '\'')
- {
- gfc_error ("Embedded space in NAME= specifier at %C");
- return MATCH_ERROR;
- }
- }
-
- /* If we stopped because we had an invalid character for a C name, report
- that to the user by returning MATCH_NO. */
- if (c != '"' && c != '\'')
- {
- gfc_error ("Invalid C name in NAME= specifier at %C");
- return MATCH_ERROR;
- }
-
- 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, false))
- 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 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)
-{
- locus orig_loc = gfc_current_locus;
- char ch;
-
- gfc_gobble_whitespace ();
- ch = gfc_next_ascii_char ();
- switch (ch)
- {
- case '+':
- /* Matched "+". */
- *result = INTRINSIC_PLUS;
- return MATCH_YES;
-
- case '-':
- /* Matched "-". */
- *result = INTRINSIC_MINUS;
- return MATCH_YES;
-
- case '=':
- if (gfc_next_ascii_char () == '=')
- {
- /* Matched "==". */
- *result = INTRINSIC_EQ;
- return MATCH_YES;
- }
- break;
-
- case '<':
- if (gfc_peek_ascii_char () == '=')
- {
- /* Matched "<=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_LE;
- return MATCH_YES;
- }
- /* Matched "<". */
- *result = INTRINSIC_LT;
- return MATCH_YES;
-
- case '>':
- if (gfc_peek_ascii_char () == '=')
- {
- /* Matched ">=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_GE;
- return MATCH_YES;
- }
- /* Matched ">". */
- *result = INTRINSIC_GT;
- return MATCH_YES;
-
- case '*':
- if (gfc_peek_ascii_char () == '*')
- {
- /* Matched "**". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_POWER;
- return MATCH_YES;
- }
- /* Matched "*". */
- *result = INTRINSIC_TIMES;
- return MATCH_YES;
-
- case '/':
- ch = gfc_peek_ascii_char ();
- if (ch == '=')
- {
- /* Matched "/=". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_NE;
- return MATCH_YES;
- }
- else if (ch == '/')
- {
- /* Matched "//". */
- gfc_next_ascii_char ();
- *result = INTRINSIC_CONCAT;
- return MATCH_YES;
- }
- /* Matched "/". */
- *result = INTRINSIC_DIVIDE;
- return MATCH_YES;
-
- case '.':
- ch = gfc_next_ascii_char ();
- switch (ch)
- {
- case 'a':
- if (gfc_next_ascii_char () == 'n'
- && gfc_next_ascii_char () == 'd'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".and.". */
- *result = INTRINSIC_AND;
- return MATCH_YES;
- }
- break;
-
- case 'e':
- if (gfc_next_ascii_char () == 'q')
- {
- ch = gfc_next_ascii_char ();
- if (ch == '.')
- {
- /* Matched ".eq.". */
- *result = INTRINSIC_EQ_OS;
- return MATCH_YES;
- }
- else if (ch == 'v')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".eqv.". */
- *result = INTRINSIC_EQV;
- return MATCH_YES;
- }
- }
- }
- break;
-
- case 'g':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".ge.". */
- *result = INTRINSIC_GE_OS;
- return MATCH_YES;
- }
- }
- else if (ch == 't')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".gt.". */
- *result = INTRINSIC_GT_OS;
- return MATCH_YES;
- }
- }
- break;
-
- case 'l':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".le.". */
- *result = INTRINSIC_LE_OS;
- return MATCH_YES;
- }
- }
- else if (ch == 't')
- {
- if (gfc_next_ascii_char () == '.')
- {
- /* Matched ".lt.". */
- *result = INTRINSIC_LT_OS;
- return MATCH_YES;
- }
- }
- break;
-
- case 'n':
- ch = gfc_next_ascii_char ();
- if (ch == 'e')
- {
- ch = gfc_next_ascii_char ();
- if (ch == '.')
- {
- /* Matched ".ne.". */
- *result = INTRINSIC_NE_OS;
- return MATCH_YES;
- }
- else if (ch == 'q')
- {
- if (gfc_next_ascii_char () == 'v'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".neqv.". */
- *result = INTRINSIC_NEQV;
- return MATCH_YES;
- }
- }
- }
- else if (ch == 'o')
- {
- if (gfc_next_ascii_char () == 't'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".not.". */
- *result = INTRINSIC_NOT;
- return MATCH_YES;
- }
- }
- break;
-
- case 'o':
- if (gfc_next_ascii_char () == 'r'
- && gfc_next_ascii_char () == '.')
- {
- /* Matched ".or.". */
- *result = INTRINSIC_OR;
- return MATCH_YES;
- }
- break;
-
- default:
- break;
- }
- break;
-
- default:
- break;
- }
-
- gfc_current_locus = orig_loc;
- return MATCH_NO;
-}
-
-
-/* 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;
-
- e1 = e2 = e3 = NULL;
-
- /* Match the start of an iterator without affecting the symbol table. */
-
- 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;
-
- /* F2008, C617 & C565. */
- if (var->symtree->n.sym->attr.codimension)
- {
- gfc_error ("Loop variable at %C cannot be a coarray");
- goto cleanup;
- }
-
- if (var->ref != NULL)
- {
- gfc_error ("Loop variable at %C cannot be a sub-component");
- goto cleanup;
- }
-
- gfc_match_char ('=');
-
- var->symtree->n.sym->attr.implied_index = 1;
-
- 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_get_int_expr (gfc_default_integer_kind, NULL, 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_ascii_char () == c)
- return MATCH_YES;
-
- gfc_current_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);
- 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:
-
- /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
- expect an upper case character here! */
- gcc_assert (TOLOWER (c) == c);
-
- if (c == gfc_next_ascii_char ())
- goto loop;
- break;
- }
-
-not_yes:
- va_end (argp);
-
- if (m != MATCH_YES)
- {
- /* Clean up after a failed match. */
- gfc_current_locus = old_loc;
- va_start (argp, target);
-
- p = target;
- for (; matches > 0; matches--)
- {
- while (*p++ != '%');
-
- switch (*p++)
- {
- case '%':
- matches++;
- break; /* Skip. */
-
- /* 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 'v':
- vp = va_arg (argp, void **);
- gfc_free_expr ((struct gfc_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 obligatory symbol. */
-
-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 a simple assignment statement. */
-
-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.expr1 = lvalue;
- new_st.expr2 = rvalue;
-
- gfc_check_do_variable (lvalue->symtree);
-
- return MATCH_YES;
-}
-
-
-/* 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;
- gfc_matching_ptr_assignment = 0;
- gfc_matching_procptr_assignment = 0;
-
- m = gfc_match (" %v =>", &lvalue);
- if (m != MATCH_YES)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- if (lvalue->symtree->n.sym->attr.proc_pointer
- || gfc_is_proc_ptr_comp (lvalue))
- gfc_matching_procptr_assignment = 1;
- else
- gfc_matching_ptr_assignment = 1;
-
- m = gfc_match (" %e%t", &rvalue);
- gfc_matching_ptr_assignment = 0;
- gfc_matching_procptr_assignment = 0;
- if (m != MATCH_YES)
- goto cleanup;
-
- new_st.op = EXEC_POINTER_ASSIGN;
- new_st.expr1 = lvalue;
- new_st.expr2 = rvalue;
-
- return MATCH_YES;
-
-cleanup:
- gfc_current_locus = old_loc;
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return m;
-}
-
-
-/* We try to match an easy arithmetic IF statement. This only happens
- when just after having encountered a simple IF statement. This code
- is really duplicate with parts of the gfc_match_if code, but this is
- *much* easier. */
-
-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, "Arithmetic IF "
- "statement at %C") == FAILURE)
- return MATCH_ERROR;
-
- new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr1 = expr;
- new_st.label1 = l1;
- new_st.label2 = l2;
- new_st.label3 = l3;
-
- return MATCH_YES;
-}
-
-
-/* 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. */
-
-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, old_loc2;
- 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;
-
- old_loc2 = gfc_current_locus;
- gfc_current_locus = old_loc;
-
- if (gfc_match_parens () == MATCH_ERROR)
- return MATCH_ERROR;
-
- gfc_current_locus = old_loc2;
-
- 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, "Arithmetic IF "
- "statement at %C") == FAILURE)
- return MATCH_ERROR;
-
- new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr1 = expr;
- new_st.label1 = 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.expr1 = expr;
- *if_type = ST_IF_BLOCK;
- return MATCH_YES;
- }
-
- if (n == MATCH_YES)
- {
- gfc_error ("Block label is not appropriate for 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_current_locus = old_loc;
-
- /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
- assignment was found. For MATCH_NO, continue to call the various
- matchers. */
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- 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_current_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 ("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 ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
- 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 ("lock", gfc_match_lock, ST_LOCK)
- 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 ("wait", gfc_match_wait, ST_WAIT)
- match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
- match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
- match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
- match ("unlock", gfc_match_unlock, ST_UNLOCK)
- match ("where", match_simple_where, ST_WHERE)
- match ("write", gfc_match_write, ST_WRITE)
-
- /* The gfc_match_assignment() above may have returned a MATCH_NO
- where the assignment was to a named constant. Check that
- special case here. */
- 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;
- }
-
- /* 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->expr1 = 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.expr1 = 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)
- free (iter);
-}
-
-
-/* Match a CRITICAL statement. */
-match
-gfc_match_critical (void)
-{
- gfc_st_label *label = NULL;
-
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" critical") != MATCH_YES)
- return MATCH_NO;
-
- if (gfc_match_st_label (&label) == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_syntax_error (ST_CRITICAL);
- return MATCH_ERROR;
- }
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT "
- "block");
- return MATCH_ERROR;
- }
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("Nested CRITICAL block at %C");
- return MATCH_ERROR;
- }
-
- new_st.op = EXEC_CRITICAL;
-
- if (label != NULL
- && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
- return MATCH_ERROR;
-
- return MATCH_YES;
-}
-
-
-/* Match a BLOCK statement. */
-
-match
-gfc_match_block (void)
-{
- match m;
-
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" block") != MATCH_YES)
- return MATCH_NO;
-
- /* For this to be a correct BLOCK statement, the line must end now. */
- m = gfc_match_eos ();
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- return MATCH_NO;
-
- return MATCH_YES;
-}
-
-
-/* Match an ASSOCIATE statement. */
-
-match
-gfc_match_associate (void)
-{
- if (gfc_match_label () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" associate") != MATCH_YES)
- return MATCH_NO;
-
- /* Match the association list. */
- if (gfc_match_char ('(') != MATCH_YES)
- {
- gfc_error ("Expected association list at %C");
- return MATCH_ERROR;
- }
- new_st.ext.block.assoc = NULL;
- while (true)
- {
- gfc_association_list* newAssoc = gfc_get_association_list ();
- gfc_association_list* a;
-
- /* Match the next association. */
- if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
- != MATCH_YES)
- {
- gfc_error ("Expected association at %C");
- goto assocListError;
- }
- newAssoc->where = gfc_current_locus;
-
- /* Check that the current name is not yet in the list. */
- for (a = new_st.ext.block.assoc; a; a = a->next)
- if (!strcmp (a->name, newAssoc->name))
- {
- gfc_error ("Duplicate name '%s' in association at %C",
- newAssoc->name);
- goto assocListError;
- }
-
- /* The target expression must not be coindexed. */
- if (gfc_is_coindexed (newAssoc->target))
- {
- gfc_error ("Association target at %C must not be coindexed");
- goto assocListError;
- }
-
- /* The `variable' field is left blank for now; because the target is not
- yet resolved, we can't use gfc_has_vector_subscript to determine it
- for now. This is set during resolution. */
-
- /* Put it into the list. */
- newAssoc->next = new_st.ext.block.assoc;
- new_st.ext.block.assoc = newAssoc;
-
- /* Try next one or end if closing parenthesis is found. */
- gfc_gobble_whitespace ();
- if (gfc_peek_char () == ')')
- break;
- if (gfc_match_char (',') != MATCH_YES)
- {
- gfc_error ("Expected ')' or ',' at %C");
- return MATCH_ERROR;
- }
-
- continue;
-
-assocListError:
- free (newAssoc);
- goto error;
- }
- if (gfc_match_char (')') != MATCH_YES)
- {
- /* This should never happen as we peek above. */
- gcc_unreachable ();
- }
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Junk after ASSOCIATE statement at %C");
- goto error;
- }
-
- return MATCH_YES;
-
-error:
- gfc_free_association_list (new_st.ext.block.assoc);
- return MATCH_ERROR;
-}
-
-
-/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
- an accessible derived type. */
-
-static match
-match_derived_type_spec (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
- gfc_symbol *derived;
-
- old_locus = gfc_current_locus;
-
- if (gfc_match ("%n", name) != MATCH_YES)
- {
- gfc_current_locus = old_locus;
- return MATCH_NO;
- }
-
- gfc_find_symbol (name, NULL, 1, &derived);
-
- if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
- derived = gfc_find_dt_in_generic (derived);
-
- if (derived && derived->attr.flavor == FL_DERIVED)
- {
- ts->type = BT_DERIVED;
- ts->u.derived = derived;
- return MATCH_YES;
- }
-
- gfc_current_locus = old_locus;
- return MATCH_NO;
-}
-
-
-/* Match a Fortran 2003 type-spec (F03:R401). This is similar to
- gfc_match_decl_type_spec() from decl.c, with the following exceptions:
- It only includes the intrinsic types from the Fortran 2003 standard
- (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
- the implicit_flag is not needed, so it was removed. Derived types are
- identified by their name alone. */
-
-static match
-match_type_spec (gfc_typespec *ts)
-{
- match m;
- locus old_locus;
-
- gfc_clear_ts (ts);
- gfc_gobble_whitespace ();
- old_locus = gfc_current_locus;
-
- if (match_derived_type_spec (ts) == MATCH_YES)
- {
- /* Enforce F03:C401. */
- if (ts->u.derived->attr.abstract)
- {
- gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
- ts->u.derived->name, &old_locus);
- return MATCH_ERROR;
- }
- return MATCH_YES;
- }
-
- if (gfc_match ("integer") == MATCH_YES)
- {
- ts->type = BT_INTEGER;
- ts->kind = gfc_default_integer_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("real") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_real_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("double precision") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_double_kind;
- return MATCH_YES;
- }
-
- if (gfc_match ("complex") == MATCH_YES)
- {
- ts->type = BT_COMPLEX;
- ts->kind = gfc_default_complex_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("character") == MATCH_YES)
- {
- ts->type = BT_CHARACTER;
-
- m = gfc_match_char_spec (ts);
-
- if (m == MATCH_NO)
- m = MATCH_YES;
-
- return m;
- }
-
- if (gfc_match ("logical") == MATCH_YES)
- {
- ts->type = BT_LOGICAL;
- ts->kind = gfc_default_logical_kind;
- goto kind_selector;
- }
-
- /* If a type is not matched, simply return MATCH_NO. */
- gfc_current_locus = old_locus;
- return MATCH_NO;
-
-kind_selector:
-
- gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () == '*')
- {
- gfc_error ("Invalid type-spec at %C");
- return MATCH_ERROR;
- }
-
- m = gfc_match_kind_spec (ts, false);
-
- if (m == MATCH_NO)
- m = MATCH_YES; /* No kind specifier found. */
-
- return m;
-}
-
-
-/******************** 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);
- free (iter);
- iter = next;
- }
-}
-
-
-/* Match an iterator as part of a FORALL statement. The format is:
-
- <var> = <start>:<end>[:<stride>]
-
- On MATCH_NO, the caller tests for the possibility that there is a
- scalar mask expression. */
-
-static match
-match_forall_iterator (gfc_forall_iterator **result)
-{
- gfc_forall_iterator *iter;
- locus where;
- match m;
-
- where = gfc_current_locus;
- iter = XCNEW (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_get_int_expr (gfc_default_integer_kind, NULL, 1);
- else
- {
- m = gfc_match_expr (&iter->stride);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
- }
-
- /* Mark the iteration variable's symbol as used as a FORALL index. */
- 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;
-}
-
-
-/* Match the header of a FORALL statement. */
-
-static match
-match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
-{
- gfc_forall_iterator *head, *tail, *new_iter;
- 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_iter);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- head = tail = new_iter;
-
- for (;;)
- {
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
- m = match_forall_iterator (&new_iter);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (m == MATCH_YES)
- {
- tail->next = new_iter;
- tail = new_iter;
- continue;
- }
-
- /* Have to have a mask expression. */
-
- 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;
-}
-
-/* Match the rest of a simple FORALL statement that follows an
- IF statement. */
-
-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.expr1 = 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 a FORALL statement. */
-
-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.expr1 = 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.expr1 = 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;
-}
-
-
-/* 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;
-
- m = gfc_match_st_label (&label);
- if (m == MATCH_ERROR)
- goto cleanup;
-
- /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
-
- if (gfc_match_eos () == MATCH_YES)
- {
- iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
- new_st.op = EXEC_DO_WHILE;
- goto done;
- }
-
- /* Match an optional comma, if no comma is found, a space is obligatory. */
- if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
- return MATCH_NO;
-
- /* Check for balanced parens. */
-
- if (gfc_match_parens () == MATCH_ERROR)
- return MATCH_ERROR;
-
- if (gfc_match (" concurrent") == MATCH_YES)
- {
- gfc_forall_iterator *head;
- gfc_expr *mask;
-
- if (gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT "
- "construct at %C") == FAILURE)
- return MATCH_ERROR;
-
-
- mask = NULL;
- head = NULL;
- m = match_forall_header (&head, &mask);
-
- if (m == MATCH_NO)
- return m;
- if (m == MATCH_ERROR)
- goto concurr_cleanup;
-
- if (gfc_match_eos () != MATCH_YES)
- goto concurr_cleanup;
-
- if (label != NULL
- && gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE)
- goto concurr_cleanup;
-
- new_st.label1 = label;
- new_st.op = EXEC_DO_CONCURRENT;
- new_st.expr1 = mask;
- new_st.ext.forall_iterator = head;
-
- return MATCH_YES;
-
-concurr_cleanup:
- gfc_syntax_error (ST_DO);
- gfc_free_expr (mask);
- gfc_free_forall_iterator (head);
- return MATCH_ERROR;
- }
-
- /* 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_current_locus = old_loc;
-
- gfc_match_label (); /* This won't error. */
- gfc_match (" do "); /* This will work. */
-
- gfc_match_st_label (&label); /* 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;
-
- iter.var->symtree->n.sym->attr.implied_index = 0;
- 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_DO_TARGET) == FAILURE)
- goto cleanup;
-
- new_st.label1 = label;
-
- if (new_st.op == EXEC_DO_WHILE)
- new_st.expr1 = 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, *o;
- gfc_symbol *sym;
- match m;
- int cnt;
-
- if (gfc_match_eos () == MATCH_YES)
- sym = NULL;
- else
- {
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symtree* stree;
-
- m = gfc_match ("% %n%t", name);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- {
- gfc_syntax_error (st);
- return MATCH_ERROR;
- }
-
- /* Find the corresponding symbol. If there's a BLOCK statement
- between here and the label, it is not in gfc_current_ns but a parent
- namespace! */
- stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
- if (!stree)
- {
- gfc_error ("Name '%s' in %s statement at %C is unknown",
- name, gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
-
- sym = stree->n.sym;
- if (sym->attr.flavor != FL_LABEL)
- {
- gfc_error ("Name '%s' in %s statement at %C is not a construct name",
- name, gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- }
-
- /* Find the loop specified by the label (or lack of a label). */
- for (o = NULL, p = gfc_state_stack; p; p = p->previous)
- if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
- o = p;
- else if (p->state == COMP_CRITICAL)
- {
- gfc_error("%s statement at %C leaves CRITICAL construct",
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- else if (p->state == COMP_DO_CONCURRENT
- && (op == EXEC_EXIT || (sym && sym != p->sym)))
- {
- /* F2008, C821 & C845. */
- gfc_error("%s statement at %C leaves DO CONCURRENT construct",
- gfc_ascii_statement (st));
- return MATCH_ERROR;
- }
- else if ((sym && sym == p->sym)
- || (!sym && (p->state == COMP_DO
- || p->state == COMP_DO_CONCURRENT)))
- break;
-
- if (p == NULL)
- {
- if (sym == NULL)
- gfc_error ("%s statement at %C is not within a construct",
- gfc_ascii_statement (st));
- else
- gfc_error ("%s statement at %C is not within construct '%s'",
- gfc_ascii_statement (st), sym->name);
-
- return MATCH_ERROR;
- }
-
- /* Special checks for EXIT from non-loop constructs. */
- switch (p->state)
- {
- case COMP_DO:
- case COMP_DO_CONCURRENT:
- break;
-
- case COMP_CRITICAL:
- /* This is already handled above. */
- gcc_unreachable ();
-
- case COMP_ASSOCIATE:
- case COMP_BLOCK:
- case COMP_IF:
- case COMP_SELECT:
- case COMP_SELECT_TYPE:
- gcc_assert (sym);
- if (op == EXEC_CYCLE)
- {
- gfc_error ("CYCLE statement at %C is not applicable to non-loop"
- " construct '%s'", sym->name);
- return MATCH_ERROR;
- }
- gcc_assert (op == EXEC_EXIT);
- if (gfc_notify_std (GFC_STD_F2008, "EXIT statement with no"
- " do-construct-name at %C") == FAILURE)
- return MATCH_ERROR;
- break;
-
- default:
- gfc_error ("%s statement at %C is not applicable to construct '%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;
- }
-
- for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
- o = o->previous;
- if (cnt > 0
- && o != NULL
- && o->state == COMP_OMP_STRUCTURED_BLOCK
- && (o->head->op == EXEC_OMP_DO
- || o->head->op == EXEC_OMP_PARALLEL_DO))
- {
- int collapse = 1;
- gcc_assert (o->head->next != NULL
- && (o->head->next->op == EXEC_DO
- || o->head->next->op == EXEC_DO_WHILE)
- && o->previous != NULL
- && o->previous->tail->op == o->head->op);
- if (o->previous->tail->ext.omp_clauses != NULL
- && o->previous->tail->ext.omp_clauses->collapse > 1)
- collapse = o->previous->tail->ext.omp_clauses->collapse;
- if (st == ST_EXIT && cnt <= collapse)
- {
- gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
- return MATCH_ERROR;
- }
- if (st == ST_CYCLE && cnt < collapse)
- {
- gfc_error ("CYCLE statement at %C to non-innermost collapsed"
- " !$OMP DO loop");
- return MATCH_ERROR;
- }
- }
-
- /* Save the first statement in the construct - needed by the backend. */
- new_st.ext.which_construct = p->construct;
-
- new_st.op = op;
-
- 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 an (ALL) STOP or PAUSE statement. */
-
-static match
-gfc_match_stopcode (gfc_statement st)
-{
- gfc_expr *e;
- match m;
-
- e = NULL;
-
- if (gfc_match_eos () != MATCH_YES)
- {
- m = gfc_match_init_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- 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;
- }
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("Image control statement STOP at %C in CRITICAL block");
- goto cleanup;
- }
- if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("Image control statement STOP at %C in DO CONCURRENT block");
- goto cleanup;
- }
-
- if (e != NULL)
- {
- if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
- {
- gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
- &e->where);
- goto cleanup;
- }
-
- if (e->rank != 0)
- {
- gfc_error ("STOP code at %L must be scalar",
- &e->where);
- goto cleanup;
- }
-
- if (e->ts.type == BT_CHARACTER
- && e->ts.kind != gfc_default_character_kind)
- {
- gfc_error ("STOP code at %L must be default character KIND=%d",
- &e->where, (int) gfc_default_character_kind);
- goto cleanup;
- }
-
- if (e->ts.type == BT_INTEGER
- && e->ts.kind != gfc_default_integer_kind)
- {
- gfc_error ("STOP code at %L must be default integer KIND=%d",
- &e->where, (int) gfc_default_integer_kind);
- goto cleanup;
- }
- }
-
- switch (st)
- {
- case ST_STOP:
- new_st.op = EXEC_STOP;
- break;
- case ST_ERROR_STOP:
- new_st.op = EXEC_ERROR_STOP;
- break;
- case ST_PAUSE:
- new_st.op = EXEC_PAUSE;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = e;
- new_st.ext.stop_code = -1;
-
- 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, "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 the ERROR STOP statement. */
-
-match
-gfc_match_error_stop (void)
-{
- if (gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- return gfc_match_stopcode (ST_ERROR_STOP);
-}
-
-
-/* Match LOCK/UNLOCK statement. Syntax:
- LOCK ( lock-variable [ , lock-stat-list ] )
- UNLOCK ( lock-variable [ , sync-stat-list ] )
- where lock-stat is ACQUIRED_LOCK or sync-stat
- and sync-stat is STAT= or ERRMSG=. */
-
-static match
-lock_unlock_statement (gfc_statement st)
-{
- match m;
- gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg;
- bool saw_acq_lock, saw_stat, saw_errmsg;
-
- tmp = lockvar = acq_lock = stat = errmsg = NULL;
- saw_acq_lock = saw_stat = saw_errmsg = false;
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement %s at %C in PURE procedure",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("Image control statement %s at %C in CRITICAL block",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
- st == ST_LOCK ? "LOCK" : "UNLOCK");
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- if (gfc_match ("%e", &lockvar) != MATCH_YES)
- goto syntax;
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- m = gfc_match_char (')');
- if (m == MATCH_YES)
- goto done;
- goto syntax;
- }
-
- for (;;)
- {
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
- goto cleanup;
- }
- stat = tmp;
- saw_stat = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
- goto cleanup;
- }
- errmsg = tmp;
- saw_errmsg = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" acquired_lock = %v", &tmp);
- if (m == MATCH_ERROR || st == ST_UNLOCK)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_acq_lock)
- {
- gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
- &tmp->where);
- goto cleanup;
- }
- acq_lock = tmp;
- saw_acq_lock = true;
-
- m = gfc_match_char (',');
- if (m == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- break;
- }
-
- if (m == MATCH_ERROR)
- goto syntax;
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
-done:
- switch (st)
- {
- case ST_LOCK:
- new_st.op = EXEC_LOCK;
- break;
- case ST_UNLOCK:
- new_st.op = EXEC_UNLOCK;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = lockvar;
- new_st.expr2 = stat;
- new_st.expr3 = errmsg;
- new_st.expr4 = acq_lock;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
- if (acq_lock != tmp)
- gfc_free_expr (acq_lock);
- if (errmsg != tmp)
- gfc_free_expr (errmsg);
- if (stat != tmp)
- gfc_free_expr (stat);
-
- gfc_free_expr (tmp);
- gfc_free_expr (lockvar);
-
- return MATCH_ERROR;
-}
-
-
-match
-gfc_match_lock (void)
-{
- if (gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- return lock_unlock_statement (ST_LOCK);
-}
-
-
-match
-gfc_match_unlock (void)
-{
- if (gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- return lock_unlock_statement (ST_UNLOCK);
-}
-
-
-/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
- SYNC ALL [(sync-stat-list)]
- SYNC MEMORY [(sync-stat-list)]
- SYNC IMAGES (image-set [, sync-stat-list] )
- with sync-stat is int-expr or *. */
-
-static match
-sync_statement (gfc_statement st)
-{
- match m;
- gfc_expr *tmp, *imageset, *stat, *errmsg;
- bool saw_stat, saw_errmsg;
-
- tmp = imageset = stat = errmsg = NULL;
- saw_stat = saw_errmsg = false;
-
- if (gfc_pure (NULL))
- {
- gfc_error ("Image control statement SYNC at %C in PURE procedure");
- return MATCH_ERROR;
- }
-
- if (gfc_implicit_pure (NULL))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("Image control statement SYNC at %C in CRITICAL block");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
- return MATCH_ERROR;
- }
-
- if (gfc_match_eos () == MATCH_YES)
- {
- if (st == ST_SYNC_IMAGES)
- goto syntax;
- goto done;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- if (st == ST_SYNC_IMAGES)
- {
- /* Denote '*' as imageset == NULL. */
- m = gfc_match_char ('*');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- if (gfc_match ("%e", &imageset) != MATCH_YES)
- goto syntax;
- }
- m = gfc_match_char (',');
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_NO)
- {
- m = gfc_match_char (')');
- if (m == MATCH_YES)
- goto done;
- goto syntax;
- }
- }
-
- for (;;)
- {
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
- goto cleanup;
- }
- stat = tmp;
- saw_stat = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto syntax;
- if (m == MATCH_YES)
- {
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
- goto cleanup;
- }
- errmsg = tmp;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- continue;
-
- tmp = NULL;
- break;
- }
-
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
-done:
- switch (st)
- {
- case ST_SYNC_ALL:
- new_st.op = EXEC_SYNC_ALL;
- break;
- case ST_SYNC_IMAGES:
- new_st.op = EXEC_SYNC_IMAGES;
- break;
- case ST_SYNC_MEMORY:
- new_st.op = EXEC_SYNC_MEMORY;
- break;
- default:
- gcc_unreachable ();
- }
-
- new_st.expr1 = imageset;
- new_st.expr2 = stat;
- new_st.expr3 = errmsg;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (st);
-
-cleanup:
- if (stat != tmp)
- gfc_free_expr (stat);
- if (errmsg != tmp)
- gfc_free_expr (errmsg);
-
- gfc_free_expr (tmp);
- gfc_free_expr (imageset);
-
- return MATCH_ERROR;
-}
-
-
-/* Match SYNC ALL statement. */
-
-match
-gfc_match_sync_all (void)
-{
- return sync_statement (ST_SYNC_ALL);
-}
-
-
-/* Match SYNC IMAGES statement. */
-
-match
-gfc_match_sync_images (void)
-{
- return sync_statement (ST_SYNC_IMAGES);
-}
-
-
-/* Match SYNC MEMORY statement. */
-
-match
-gfc_match_sync_memory (void)
-{
- return sync_statement (ST_SYNC_MEMORY);
-}
-
-
-/* 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, "ASSIGN "
- "statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- expr->symtree->n.sym->attr.assign = 1;
-
- new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label1 = label;
- new_st.expr1 = 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.label1 = 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, "Assigned GOTO "
- "statement at %C")
- == FAILURE)
- return MATCH_ERROR;
-
- new_st.op = EXEC_GOTO;
- new_st.expr1 = 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);
- 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->label1 = 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);
- 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_get_int_expr (gfc_default_integer_kind,
- NULL, i++);
-
- tail->op = EXEC_SELECT;
- tail->ext.block.case_list = cp;
-
- tail->next = gfc_get_code ();
- tail->next->op = EXEC_GOTO;
- tail->next->label1 = 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;
-
- if (gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO "
- "at %C") == FAILURE)
- return MATCH_ERROR;
-
- /* At this point, a computed GOTO has been fully matched and an
- equivalent SELECT statement constructed. */
-
- new_st.op = EXEC_SELECT;
- new_st.expr1 = 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);
- free (p);
- }
-}
-
-
-/* Match an ALLOCATE statement. */
-
-match
-gfc_match_allocate (void)
-{
- gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp, *source, *mold;
- gfc_typespec ts;
- gfc_symbol *sym;
- match m;
- locus old_locus, deferred_locus;
- bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
- bool saw_unlimited = false;
-
- head = tail = NULL;
- stat = errmsg = source = mold = tmp = NULL;
- saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- /* Match an optional type-spec. */
- old_locus = gfc_current_locus;
- m = match_type_spec (&ts);
- if (m == MATCH_ERROR)
- goto cleanup;
- else if (m == MATCH_NO)
- {
- char name[GFC_MAX_SYMBOL_LEN + 3];
-
- if (gfc_match ("%n :: ", name) == MATCH_YES)
- {
- gfc_error ("Error in type-spec at %L", &old_locus);
- goto cleanup;
- }
-
- ts.type = BT_UNKNOWN;
- }
- else
- {
- if (gfc_match (" :: ") == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2003, "typespec in "
- "ALLOCATE at %L", &old_locus) == FAILURE)
- goto cleanup;
-
- if (ts.deferred)
- {
- gfc_error ("Type-spec at %L cannot contain a deferred "
- "type parameter", &old_locus);
- goto cleanup;
- }
-
- if (ts.type == BT_CHARACTER)
- ts.u.cl->length_from_typespec = true;
- }
- else
- {
- ts.type = BT_UNKNOWN;
- gfc_current_locus = old_locus;
- }
- }
-
- 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 at %C for a PURE procedure");
- goto cleanup;
- }
-
- if (gfc_implicit_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (tail->expr->ts.deferred)
- {
- saw_deferred = true;
- deferred_locus = tail->expr->where;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS
- || gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_ref *ref;
- bool coarray = tail->expr->symtree->n.sym->attr.codimension;
- for (ref = tail->expr->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- coarray = ref->u.c.component->attr.codimension;
-
- if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block");
- goto cleanup;
- }
- if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("ALLOCATE of coarray at %C in CRITICAL block");
- goto cleanup;
- }
- }
-
- /* Check for F08:C628. */
- sym = tail->expr->symtree->n.sym;
- b1 = !(tail->expr->ref
- && (tail->expr->ref->type == REF_COMPONENT
- || tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok)
- b2 = !(CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer);
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
- b3 = sym && sym->ns && sym->ns->proc_name
- && (sym->ns->proc_name->attr.allocatable
- || sym->ns->proc_name->attr.pointer
- || sym->ns->proc_name->attr.proc_pointer);
- if (b1 && b2 && !b3)
- {
- gfc_error ("Allocate-object at %L is neither a data pointer "
- "nor an allocatable variable", &tail->expr->where);
- goto cleanup;
- }
-
- /* The ALLOCATE statement had an optional typespec. Check the
- constraints. */
- if (ts.type != BT_UNKNOWN)
- {
- /* Enforce F03:C624. */
- if (!gfc_type_compatible (&tail->expr->ts, &ts))
- {
- gfc_error ("Type of entity at %L is type incompatible with "
- "typespec", &tail->expr->where);
- goto cleanup;
- }
-
- /* Enforce F03:C627. */
- if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr))
- {
- gfc_error ("Kind type parameter for entity at %L differs from "
- "the kind type parameter of the typespec",
- &tail->expr->where);
- goto cleanup;
- }
- }
-
- if (tail->expr->ts.type == BT_DERIVED)
- tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
-
- saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
-
- if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
- {
- gfc_error ("Shape specification for allocatable scalar at %C");
- goto cleanup;
- }
-
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
-alloc_opt_list:
-
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- /* Enforce C630. */
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
- goto cleanup;
- }
-
- stat = tmp;
- tmp = NULL;
- saw_stat = true;
-
- if (gfc_check_do_variable (stat->symtree))
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L",
- &tmp->where) == FAILURE)
- goto cleanup;
-
- /* Enforce C630. */
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
- goto cleanup;
- }
-
- errmsg = tmp;
- tmp = NULL;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" source = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L",
- &tmp->where) == FAILURE)
- goto cleanup;
-
- /* Enforce C630. */
- if (saw_source)
- {
- gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
- goto cleanup;
- }
-
- /* The next 2 conditionals check C631. */
- if (ts.type != BT_UNKNOWN)
- {
- gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
- &tmp->where, &old_locus);
- goto cleanup;
- }
-
- if (head->next
- && gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
- " with more than a single allocate object",
- &tmp->where) == FAILURE)
- goto cleanup;
-
- source = tmp;
- tmp = NULL;
- saw_source = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- m = gfc_match (" mold = %e", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L",
- &tmp->where) == FAILURE)
- goto cleanup;
-
- /* Check F08:C636. */
- if (saw_mold)
- {
- gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
- goto cleanup;
- }
-
- /* Check F08:C637. */
- if (ts.type != BT_UNKNOWN)
- {
- gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
- &tmp->where, &old_locus);
- goto cleanup;
- }
-
- mold = tmp;
- tmp = NULL;
- saw_mold = true;
- mold->mold = 1;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto alloc_opt_list;
- }
-
- gfc_gobble_whitespace ();
-
- if (gfc_peek_char () == ')')
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
- /* Check F08:C637. */
- if (source && mold)
- {
- gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
- &mold->where, &source->where);
- goto cleanup;
- }
-
- /* Check F03:C623, */
- if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold)
- {
- gfc_error ("Allocate-object at %L with a deferred type parameter "
- "requires either a type-spec or SOURCE tag or a MOLD tag",
- &deferred_locus);
- goto cleanup;
- }
-
- /* Check F03:C625, */
- if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold)
- {
- for (tail = head; tail; tail = tail->next)
- {
- if (UNLIMITED_POLY (tail->expr))
- gfc_error ("Unlimited polymorphic allocate-object at %L "
- "requires either a type-spec or SOURCE tag "
- "or a MOLD tag", &tail->expr->where);
- }
- goto cleanup;
- }
-
- new_st.op = EXEC_ALLOCATE;
- new_st.expr1 = stat;
- new_st.expr2 = errmsg;
- if (source)
- new_st.expr3 = source;
- else
- new_st.expr3 = mold;
- new_st.ext.alloc.list = head;
- new_st.ext.alloc.ts = ts;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_ALLOCATE);
-
-cleanup:
- gfc_free_expr (errmsg);
- gfc_free_expr (source);
- gfc_free_expr (stat);
- gfc_free_expr (mold);
- if (tmp && tmp->expr_type) gfc_free_expr (tmp);
- 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_check_do_variable (p->symtree))
- goto cleanup;
-
- /* F2008, C1242. */
- if (gfc_is_coindexed (p))
- {
- gfc_error ("Pointer object at %C shall not be coindexed");
- goto cleanup;
- }
-
- /* build ' => NULL() '. */
- e = gfc_get_null_expr (&gfc_current_locus);
-
- /* Chain to list. */
- if (tail == NULL)
- tail = &new_st;
- else
- {
- tail->next = gfc_get_code ();
- tail = tail->next;
- }
-
- tail->op = EXEC_POINTER_ASSIGN;
- tail->expr1 = 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);
- new_st.next = NULL;
- gfc_free_expr (new_st.expr1);
- new_st.expr1 = NULL;
- gfc_free_expr (new_st.expr2);
- new_st.expr2 = NULL;
- return MATCH_ERROR;
-}
-
-
-/* Match a DEALLOCATE statement. */
-
-match
-gfc_match_deallocate (void)
-{
- gfc_alloc *head, *tail;
- gfc_expr *stat, *errmsg, *tmp;
- gfc_symbol *sym;
- match m;
- bool saw_stat, saw_errmsg, b1, b2;
-
- head = tail = NULL;
- stat = errmsg = tmp = NULL;
- saw_stat = saw_errmsg = false;
-
- 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;
-
- sym = tail->expr->symtree->n.sym;
-
- if (gfc_pure (NULL) && gfc_impure_variable (sym))
- {
- gfc_error ("Illegal allocate-object at %C for a PURE procedure");
- goto cleanup;
- }
-
- if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
- gfc_current_ns->proc_name->attr.implicit_pure = 0;
-
- if (gfc_is_coarray (tail->expr)
- && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block");
- goto cleanup;
- }
-
- if (gfc_is_coarray (tail->expr)
- && gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block");
- goto cleanup;
- }
-
- /* FIXME: disable the checking on derived types. */
- b1 = !(tail->expr->ref
- && (tail->expr->ref->type == REF_COMPONENT
- || tail->expr->ref->type == REF_ARRAY));
- if (sym && sym->ts.type == BT_CLASS)
- b2 = !(CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer);
- else
- b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
- || sym->attr.proc_pointer);
- if (b1 && b2)
- {
- gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
- "nor an allocatable variable");
- goto cleanup;
- }
-
- if (gfc_match_char (',') != MATCH_YES)
- break;
-
-dealloc_opt_list:
-
- m = gfc_match (" stat = %v", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (saw_stat)
- {
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
- gfc_free_expr (tmp);
- goto cleanup;
- }
-
- stat = tmp;
- saw_stat = true;
-
- if (gfc_check_do_variable (stat->symtree))
- goto cleanup;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto dealloc_opt_list;
- }
-
- m = gfc_match (" errmsg = %v", &tmp);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L",
- &tmp->where) == FAILURE)
- goto cleanup;
-
- if (saw_errmsg)
- {
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
- gfc_free_expr (tmp);
- goto cleanup;
- }
-
- errmsg = tmp;
- saw_errmsg = true;
-
- if (gfc_match_char (',') == MATCH_YES)
- goto dealloc_opt_list;
- }
-
- gfc_gobble_whitespace ();
-
- if (gfc_peek_char () == ')')
- break;
- }
-
- if (gfc_match (" )%t") != MATCH_YES)
- goto syntax;
-
- new_st.op = EXEC_DEALLOCATE;
- new_st.expr1 = stat;
- new_st.expr2 = errmsg;
- new_st.ext.alloc.list = head;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DEALLOCATE);
-
-cleanup:
- gfc_free_expr (errmsg);
- 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;
- gfc_compile_state s;
-
- e = NULL;
-
- if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
- {
- gfc_error ("Image control statement RETURN at %C in CRITICAL block");
- return MATCH_ERROR;
- }
-
- if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
- {
- gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
- return MATCH_ERROR;
- }
-
- 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_notify_std (GFC_STD_F95_OBS, "Alternate RETURN "
- "at %C") == FAILURE)
- return MATCH_ERROR;
-
- if (gfc_current_form == FORM_FREE)
- {
- /* The following are valid, so we can't require a blank after the
- RETURN keyword:
- return+1
- return(1) */
- char c = gfc_peek_ascii_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, "RETURN statement in "
- "main program at %C") == FAILURE)
- return MATCH_ERROR;
-
- new_st.op = EXEC_RETURN;
- new_st.expr1 = e;
-
- return MATCH_YES;
-}
-
-
-/* Match the call of a type-bound procedure, if CALL%var has already been
- matched and var found to be a derived-type variable. */
-
-static match
-match_typebound_call (gfc_symtree* varst)
-{
- gfc_expr* base;
- match m;
-
- base = gfc_get_expr ();
- base->expr_type = EXPR_VARIABLE;
- base->symtree = varst;
- base->where = gfc_current_locus;
- gfc_set_sym_referenced (varst->n.sym);
-
- m = gfc_match_varspec (base, 0, true, true);
- if (m == MATCH_NO)
- gfc_error ("Expected component reference at %C");
- if (m != MATCH_YES)
- return MATCH_ERROR;
-
- if (gfc_match_eos () != MATCH_YES)
- {
- gfc_error ("Junk after CALL at %C");
- return MATCH_ERROR;
- }
-
- if (base->expr_type == EXPR_COMPCALL)
- new_st.op = EXEC_COMPCALL;
- else if (base->expr_type == EXPR_PPC)
- new_st.op = EXEC_CALL_PPC;
- else
- {
- gfc_error ("Expected type-bound procedure or procedure pointer component "
- "at %C");
- return MATCH_ERROR;
- }
- new_st.expr1 = base;
-
- 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;
-
- /* If this is a variable of derived-type, it probably starts a type-bound
- procedure call. */
- if ((sym->attr.flavor != FL_PROCEDURE
- || gfc_is_function_return_value (sym, gfc_current_ns))
- && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
- return match_typebound_call (st);
-
- /* If it does not seem to be callable (include functions so that the
- right association is made. They are thrown out in resolution.)
- ... */
- if (!sym->attr.generic
- && !sym->attr.subroutine
- && !sym->attr.function)
- {
- if (!(sym->attr.external && !sym->attr.referenced))
- {
- /* ...create a symbol in this scope... */
- if (sym->ns != gfc_current_ns
- && gfc_get_sym_tree (name, NULL, &st, false) == 1)
- return MATCH_ERROR;
-
- if (sym != st->n.sym)
- sym = st->n.sym;
- }
-
- /* ...and then to try to make the symbol into a subroutine. */
- if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
- }
-
- gfc_set_sym_referenced (sym);
-
- 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->expr1 = gfc_get_expr ();
- c->expr1->expr_type = EXPR_VARIABLE;
- c->expr1->symtree = select_st;
- c->expr1->ts = select_sym->ts;
- c->expr1->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 = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
- new_case->low = new_case->high;
- c->ext.block.case_list = new_case;
-
- c->next = gfc_get_code ();
- c->next->op = EXEC_GOTO;
- c->next->label1 = 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;
-}
-
-
-/* Given a name, return a pointer to the common head structure,
- creating it if it does not exist. If FROM_MODULE is nonzero, we
- mangle the name so that it doesn't interfere with commons defined
- in the using namespace.
- TODO: Add to global symbol tree. */
-
-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)
- {
- /* A use associated common block is only needed to correctly layout
- the variables it contains. */
- 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;
-}
-
-
-/* Match a common block name. */
-
-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 a COMMON statement. */
-
-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;
- }
- 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;
- }
-
- /* Grab the list of symbols. */
- for (;;)
- {
- m = gfc_match_symbol (&sym, 0);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
-
- /* Store a ref to the common block for error checking. */
- sym->common_block = t;
- sym->common_block->refs++;
-
- /* See if we know the current common block is bind(c), and if
- so, then see if we can check if the symbol is (which it'll
- need to be). This can happen if the bind(c) attr stmt was
- applied to the common block, and the variable(s) already
- defined, before declaring the common block. */
- if (t->is_bind_c == 1)
- {
- if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
- {
- /* If we find an error, just print it and continue,
- cause it's just semantic, and we can see if there
- are more errors. */
- gfc_error_now ("Variable '%s' at %L in common block '%s' "
- "at %C must be declared with a C "
- "interoperable kind since common block "
- "'%s' is bind(c)",
- sym->name, &(sym->declared_at), t->name,
- t->name);
- }
-
- if (sym->attr.is_bind_c == 1)
- gfc_error_now ("Variable '%s' in common block "
- "'%s' at %C can not be bind(c) since "
- "it is not global", sym->name, t->name);
- }
-
- if (sym->attr.in_common)
- {
- gfc_error ("Symbol '%s' at %C is already in a COMMON block",
- sym->name);
- goto cleanup;
- }
-
- if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
- || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
- {
- if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
- "can only be COMMON in "
- "BLOCK DATA", sym->name)
- == FAILURE)
- goto cleanup;
- }
-
- if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
- 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, true, true);
- 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;
-
- /* Check to see if the symbol is already in an equivalence group.
- If it is, set the other members as being in common. */
- 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_ascii_char () == '/')
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- gfc_gobble_whitespace ();
- if (gfc_peek_ascii_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 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, sym->name, 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;
- 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
- && 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;
-
- /* Use gfc_error_check here, rather than goto error, so that
- these are the only errors for the next two lines. */
- 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 ();
- }
-
- 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 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,
- gfc_new_block->name, 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_until (gfc_equiv *eq, gfc_equiv *stop)
-{
- if (eq == stop)
- return;
-
- gfc_free_equiv (eq->eq);
- gfc_free_equiv_until (eq->next, stop);
- gfc_free_expr (eq->expr);
- free (eq);
-}
-
-
-void
-gfc_free_equiv (gfc_equiv *eq)
-{
- gfc_free_equiv_until (eq, NULL);
-}
-
-
-/* Match an EQUIVALENCE statement. */
-
-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;
-
- /* count the number of objects. */
- 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 one of the members of an equivalence is in common, then
- mark them all as being in common. Before doing this, check
- that members of the equivalence group are not in different
- common blocks. */
- 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)
- {
- gfc_error ("Expecting a comma in EQUIVALENCE at %C");
- goto cleanup;
- }
- }
-
- 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;
-}
-
-
-/* Check that a statement function is not recursive. This is done by looking
- for the statement function symbol(sym) by looking recursively through its
- expression(e). If a reference to sym is found, true is returned.
- 12.5.4 requires that any variable of function that is implicitly typed
- shall have that type confirmed by any subsequent type declaration. The
- implicit typing is conveniently done here. */
-static bool
-recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
-
-static bool
-check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
-{
-
- if (e == NULL)
- return false;
-
- switch (e->expr_type)
- {
- case EXPR_FUNCTION:
- if (e->symtree == NULL)
- return false;
-
- /* Check the name before testing for nested recursion! */
- if (sym->name == e->symtree->n.sym->name)
- return true;
-
- /* Catch recursion via other statement functions. */
- 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;
-
- default:
- break;
- }
-
- return false;
-}
-
-
-static bool
-recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
-{
- return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
-}
-
-
-/* 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,
- 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;
-
- if (gfc_notify_std (GFC_STD_F95_OBS,
- "Statement function at %C") == FAILURE)
- return MATCH_ERROR;
-
- return MATCH_YES;
-
-undo_error:
- gfc_pop_error (&old_error);
- return MATCH_NO;
-}
-
-
-/***************** 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);
- 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_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 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_init_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 initialization 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;
-
- /* If the case construct doesn't have a case-construct-name, we
- should have matched the EOS. */
- if (!gfc_current_block ())
- return MATCH_NO;
-
- 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 block name '%s' of SELECT construct 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.expr1 = expr;
-
- return MATCH_YES;
-}
-
-
-/* Transfer the selector typespec to the associate name. */
-
-static void
-copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
-{
- gfc_ref *ref;
- gfc_symbol *assoc_sym;
- int i;
-
- assoc_sym = associate->symtree->n.sym;
-
- /* At this stage the expression rank and arrayspec dimensions have
- not been completely sorted out. We must get the expr2->rank
- right here, so that the correct class container is obtained. */
- ref = selector->ref;
- while (ref && ref->next)
- ref = ref->next;
-
- if (selector->ts.type == BT_CLASS
- && CLASS_DATA (selector)->as
- && ref && ref->type == REF_ARRAY)
- {
- /* Ensure that the array reference type is set. We cannot use
- gfc_resolve_expr at this point, so the usable parts of
- resolve.c(resolve_array_ref) are employed to do it. */
- if (ref->u.ar.type == AR_UNKNOWN)
- {
- ref->u.ar.type = AR_ELEMENT;
- for (i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
- if (ref->u.ar.dimen_type[i] == DIMEN_RANGE
- || ref->u.ar.dimen_type[i] == DIMEN_VECTOR
- || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
- && ref->u.ar.start[i] && ref->u.ar.start[i]->rank))
- {
- ref->u.ar.type = AR_SECTION;
- break;
- }
- }
-
- if (ref->u.ar.type == AR_FULL)
- selector->rank = CLASS_DATA (selector)->as->rank;
- else if (ref->u.ar.type == AR_SECTION)
- selector->rank = ref->u.ar.dimen;
- else
- selector->rank = 0;
- }
-
- if (selector->ts.type != BT_CLASS)
- {
- /* The correct class container has to be available. */
- if (selector->rank)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = selector->rank;
- assoc_sym->as->type = AS_DEFERRED;
- }
- else
- assoc_sym->as = NULL;
-
- assoc_sym->ts.type = BT_CLASS;
- assoc_sym->ts.u.derived = selector->ts.u.derived;
- assoc_sym->attr.pointer = 1;
- gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
- &assoc_sym->as, false);
- }
- else
- {
- /* The correct class container has to be available. */
- if (selector->rank)
- {
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = selector->rank;
- assoc_sym->as->type = AS_DEFERRED;
- }
- else
- assoc_sym->as = NULL;
- assoc_sym->ts.type = BT_CLASS;
- assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
- assoc_sym->attr.pointer = 1;
- gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr,
- &assoc_sym->as, false);
- }
-}
-
-
-/* Push the current selector onto the SELECT TYPE stack. */
-
-static void
-select_type_push (gfc_symbol *sel)
-{
- gfc_select_type_stack *top = gfc_get_select_type_stack ();
- top->selector = sel;
- top->tmp = NULL;
- top->prev = select_type_stack;
-
- select_type_stack = top;
-}
-
-
-/* Set the temporary for the current intrinsic SELECT TYPE selector. */
-
-static gfc_symtree *
-select_intrinsic_set_tmp (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN];
- gfc_symtree *tmp;
- int charlen = 0;
-
- if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
- return NULL;
-
- if (select_type_stack->selector->ts.type == BT_CLASS
- && !select_type_stack->selector->attr.class_ok)
- return NULL;
-
- if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
- && ts->u.cl->length->expr_type == EXPR_CONSTANT)
- charlen = mpz_get_si (ts->u.cl->length->value.integer);
-
- if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
- ts->kind);
- else
- sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
- charlen, ts->kind);
-
- gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- gfc_add_type (tmp->n.sym, ts, NULL);
-
- /* Copy across the array spec to the selector. */
- if (select_type_stack->selector->ts.type == BT_CLASS
- && (CLASS_DATA (select_type_stack->selector)->attr.dimension
- || CLASS_DATA (select_type_stack->selector)->attr.codimension))
- {
- tmp->n.sym->attr.pointer = 1;
- tmp->n.sym->attr.dimension
- = CLASS_DATA (select_type_stack->selector)->attr.dimension;
- tmp->n.sym->attr.codimension
- = CLASS_DATA (select_type_stack->selector)->attr.codimension;
- tmp->n.sym->as
- = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
- }
-
- gfc_set_sym_referenced (tmp->n.sym);
- gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
- tmp->n.sym->attr.select_type_temporary = 1;
-
- return tmp;
-}
-
-
-/* Set up a temporary for the current TYPE IS / CLASS IS branch . */
-
-static void
-select_type_set_tmp (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN];
- gfc_symtree *tmp = NULL;
-
- if (!ts)
- {
- select_type_stack->tmp = NULL;
- return;
- }
-
- tmp = select_intrinsic_set_tmp (ts);
-
- if (tmp == NULL)
- {
- if (!ts->u.derived)
- return;
-
- if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
- else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
- gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- gfc_add_type (tmp->n.sym, ts, NULL);
-
- if (select_type_stack->selector->ts.type == BT_CLASS
- && select_type_stack->selector->attr.class_ok)
- {
- tmp->n.sym->attr.pointer
- = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
-
- /* Copy across the array spec to the selector. */
- if (CLASS_DATA (select_type_stack->selector)->attr.dimension
- || CLASS_DATA (select_type_stack->selector)->attr.codimension)
- {
- tmp->n.sym->attr.dimension
- = CLASS_DATA (select_type_stack->selector)->attr.dimension;
- tmp->n.sym->attr.codimension
- = CLASS_DATA (select_type_stack->selector)->attr.codimension;
- tmp->n.sym->as
- = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
- }
- }
-
- gfc_set_sym_referenced (tmp->n.sym);
- gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
- tmp->n.sym->attr.select_type_temporary = 1;
-
- if (ts->type == BT_CLASS)
- gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
- &tmp->n.sym->as, false);
- }
-
- /* Add an association for it, so the rest of the parser knows it is
- an associate-name. The target will be set during resolution. */
- tmp->n.sym->assoc = gfc_get_association_list ();
- tmp->n.sym->assoc->dangling = 1;
- tmp->n.sym->assoc->st = tmp;
-
- select_type_stack->tmp = tmp;
-}
-
-
-/* Match a SELECT TYPE statement. */
-
-match
-gfc_match_select_type (void)
-{
- gfc_expr *expr1, *expr2 = NULL;
- match m;
- char name[GFC_MAX_SYMBOL_LEN];
- bool class_array;
- gfc_symbol *sym;
-
- m = gfc_match_label ();
- if (m == MATCH_ERROR)
- return m;
-
- m = gfc_match (" select type ( ");
- if (m != MATCH_YES)
- return m;
-
- m = gfc_match (" %n => %e", name, &expr2);
- if (m == MATCH_YES)
- {
- expr1 = gfc_get_expr();
- expr1->expr_type = EXPR_VARIABLE;
- if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- sym = expr1->symtree->n.sym;
- if (expr2->ts.type == BT_UNKNOWN)
- sym->attr.untyped = 1;
- else
- copy_ts_from_selector_to_associate (expr1, expr2);
-
- sym->attr.flavor = FL_VARIABLE;
- sym->attr.referenced = 1;
- sym->attr.class_ok = 1;
- }
- else
- {
- m = gfc_match (" %e ", &expr1);
- if (m != MATCH_YES)
- goto cleanup;
- }
-
- m = gfc_match (" )%t");
- if (m != MATCH_YES)
- {
- gfc_error ("parse error in SELECT TYPE statement at %C");
- goto cleanup;
- }
-
- /* This ghastly expression seems to be needed to distinguish a CLASS
- array, which can have a reference, from other expressions that
- have references, such as derived type components, and are not
- allowed by the standard.
- TODO: see if it is sufficient to exclude component and substring
- references. */
- class_array = expr1->expr_type == EXPR_VARIABLE
- && expr1->ts.type == BT_CLASS
- && CLASS_DATA (expr1)
- && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
- && (CLASS_DATA (expr1)->attr.dimension
- || CLASS_DATA (expr1)->attr.codimension)
- && expr1->ref
- && expr1->ref->type == REF_ARRAY
- && expr1->ref->next == NULL;
-
- /* Check for F03:C811. */
- if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
- || (!class_array && expr1->ref != NULL)))
- {
- gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
- "use associate-name=>");
- m = MATCH_ERROR;
- goto cleanup;
- }
-
- new_st.op = EXEC_SELECT_TYPE;
- new_st.expr1 = expr1;
- new_st.expr2 = expr2;
- new_st.ext.block.ns = gfc_current_ns;
-
- select_type_push (expr1->symtree->n.sym);
-
- return MATCH_YES;
-
-cleanup:
- return m;
-}
-
-
-/* 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.block.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.block.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;
-}
-
-
-/* Match a TYPE IS statement. */
-
-match
-gfc_match_type_is (void)
-{
- gfc_case *c = NULL;
- match m;
-
- if (gfc_current_state () != COMP_SELECT_TYPE)
- {
- gfc_error ("Unexpected TYPE IS statement at %C");
- return MATCH_ERROR;
- }
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
-
- if (match_type_spec (&c->ts) == MATCH_ERROR)
- goto cleanup;
-
- 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_TYPE;
- new_st.ext.block.case_list = c;
-
- if (c->ts.type == BT_DERIVED && c->ts.u.derived
- && (c->ts.u.derived->attr.sequence
- || c->ts.u.derived->attr.is_bind_c))
- {
- gfc_error ("The type-spec shall not specify a sequence derived "
- "type or a type with the BIND attribute in SELECT "
- "TYPE at %C [F2003:C815]");
- return MATCH_ERROR;
- }
-
- /* Create temporary variable. */
- select_type_set_tmp (&c->ts);
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in TYPE IS specification at %C");
-
-cleanup:
- if (c != NULL)
- gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-
-/* Match a CLASS IS or CLASS DEFAULT statement. */
-
-match
-gfc_match_class_is (void)
-{
- gfc_case *c = NULL;
- match m;
-
- if (gfc_current_state () != COMP_SELECT_TYPE)
- return MATCH_NO;
-
- 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_TYPE;
- c = gfc_get_case ();
- c->where = gfc_current_locus;
- c->ts.type = BT_UNKNOWN;
- new_st.ext.block.case_list = c;
- select_type_set_tmp (NULL);
- return MATCH_YES;
- }
-
- m = gfc_match ("% is");
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- c = gfc_get_case ();
- c->where = gfc_current_locus;
-
- if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
- goto cleanup;
-
- if (c->ts.type == BT_DERIVED)
- c->ts.type = BT_CLASS;
-
- 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_TYPE;
- new_st.ext.block.case_list = c;
-
- /* Create temporary variable. */
- select_type_set_tmp (&c->ts);
-
- return MATCH_YES;
-
-syntax:
- gfc_error ("Syntax error in CLASS IS specification at %C");
-
-cleanup:
- if (c != NULL)
- gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
- return MATCH_ERROR;
-}
-
-
-/********************* WHERE subroutines ********************/
-
-/* Match the rest of a simple WHERE statement that follows an IF statement.
- */
-
-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->expr1 = 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 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.expr1 = 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->expr1 = 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)
- {
- /* Only makes sense if we have a where-construct-name. */
- if (!gfc_current_block ())
- {
- m = MATCH_ERROR;
- goto cleanup;
- }
- /* 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.expr1 = expr;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_ELSEWHERE);
-
-cleanup:
- gfc_free_expr (expr);
- return MATCH_ERROR;
-}