/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
- Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010 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 2, or (at your option) any later
+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
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
-
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "match.h"
#include "parse.h"
-/* For matching and debugging purposes. Order matters here! The
- unary operators /must/ precede the binary plus and minus, or
- the expression parser breaks. */
-
-mstring intrinsic_operators[] = {
- minit ("+", INTRINSIC_UPLUS),
- minit ("-", INTRINSIC_UMINUS),
- minit ("+", INTRINSIC_PLUS),
- minit ("-", INTRINSIC_MINUS),
- minit ("**", INTRINSIC_POWER),
- minit ("//", INTRINSIC_CONCAT),
- minit ("*", INTRINSIC_TIMES),
- minit ("/", INTRINSIC_DIVIDE),
- minit (".and.", INTRINSIC_AND),
- minit (".or.", INTRINSIC_OR),
- minit (".eqv.", INTRINSIC_EQV),
- minit (".neqv.", INTRINSIC_NEQV),
- minit (".eq.", INTRINSIC_EQ),
- minit ("==", INTRINSIC_EQ),
- minit (".ne.", INTRINSIC_NE),
- minit ("/=", INTRINSIC_NE),
- minit (".ge.", INTRINSIC_GE),
- minit (">=", INTRINSIC_GE),
- minit (".le.", INTRINSIC_LE),
- minit ("<=", INTRINSIC_LE),
- minit (".lt.", INTRINSIC_LT),
- minit ("<", INTRINSIC_LT),
- minit (".gt.", INTRINSIC_GT),
- minit (">", INTRINSIC_GT),
- minit (".not.", INTRINSIC_NOT),
- minit ("parens", INTRINSIC_PARENTHESES),
- minit (NULL, INTRINSIC_NONE)
-};
+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, instring;
+ gfc_char_t c, quote;
+
+ old_loc = gfc_current_locus;
+ count = 0;
+ instring = 0;
+ quote = ' ';
+
+ for (;;)
+ {
+ c = gfc_next_char_literal (instring);
+ if (c == '\n')
+ break;
+ if (quote == ' ' && ((c == '\'') || (c == '"')))
+ {
+ quote = c;
+ instring = 1;
+ continue;
+ }
+ if (quote != ' ' && c == quote)
+ {
+ quote = ' ';
+ instring = 0;
+ 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 (1)))
+ {
+ 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 (1);
+ 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. */
gfc_match_space (void)
{
locus old_loc;
- int c;
+ char c;
if (gfc_current_form == FORM_FIXED)
return MATCH_YES;
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!gfc_is_whitespace (c))
{
gfc_current_locus = old_loc;
gfc_match_eos (void)
{
locus old_loc;
- int flag, c;
+ int flag;
+ char c;
flag = 0;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
switch (c)
{
case '!':
do
{
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
}
while (c != '\n');
- /* Fall through */
+ /* Fall through. */
case '\n':
return MATCH_YES;
old_loc = gfc_current_locus;
+ *value = -1;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (cnt)
*cnt = 0;
for (;;)
{
old_loc = gfc_current_locus;
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
if (!ISDIGIT (c))
break;
}
+/* 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)
+gfc_match_st_label (gfc_st_label **label)
{
locus old_loc;
match m;
}
-/* Try and match the input against an array of possibilities. If one
- potential matching string is a substring of another, the longest
- match takes precedence. Spaces in the target strings are optional
- spaces that do not necessarily have to be found in the input
- stream. In fixed mode, spaces never appear. If whitespace is
- matched, it matches unlimited whitespace in the input. For this
- reason, the 'mp' member of the mstring structure is used to track
- the progress of each potential match.
-
- If there is no match we return the tag associated with the
- terminating NULL mstring structure and leave the locus pointer
- where it started. If there is a match we return the tag member of
- the matched mstring and leave the locus pointer after the matched
- character.
-
- A '%' character is a mandatory space. */
+/* 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. */
-int
-gfc_match_strings (mstring * a)
+match
+gfc_match_name (char *buffer)
{
- mstring *p, *best_match;
- int no_match, c, possibles;
- locus match_loc;
+ locus old_loc;
+ int i;
+ char c;
- possibles = 0;
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
- for (p = a; p->string != NULL; p++)
+ c = gfc_next_ascii_char ();
+ if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
{
- p->mp = p->string;
- possibles++;
+ if (gfc_error_flag_test() == 0 && c != '(')
+ gfc_error ("Invalid character in name at %C");
+ gfc_current_locus = old_loc;
+ return MATCH_NO;
}
- no_match = p->tag;
-
- best_match = NULL;
- match_loc = gfc_current_locus;
-
- gfc_gobble_whitespace ();
+ i = 0;
- while (possibles > 0)
+ do
{
- c = gfc_next_char ();
+ buffer[i++] = c;
- /* Apply the next character to the current possibilities. */
- for (p = a; p->string != NULL; p++)
+ if (i > gfc_option.max_identifier_length)
{
- if (p->mp == NULL)
- continue;
-
- if (*p->mp == ' ')
- {
- /* Space matches 1+ whitespace(s). */
- if ((gfc_current_form == FORM_FREE)
- && gfc_is_whitespace (c))
- continue;
-
- p->mp++;
- }
+ gfc_error ("Name at %C is too long");
+ return MATCH_ERROR;
+ }
- if (*p->mp != c)
- {
- /* Match failed. */
- p->mp = NULL;
- possibles--;
- continue;
- }
+ old_loc = gfc_current_locus;
+ c = gfc_next_ascii_char ();
+ }
+ while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
- p->mp++;
- if (*p->mp == '\0')
- {
- /* Found a match. */
- match_loc = gfc_current_locus;
- best_match = p;
- possibles--;
- p->mp = NULL;
- }
- }
+ 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;
}
- gfc_current_locus = match_loc;
+ buffer[i] = '\0';
+ gfc_current_locus = old_loc;
- return (best_match == NULL) ? no_match : best_match->tag;
+ 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. */
+/* 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 added, such as no limits on the length.
+ Right now, the length is limited to the same thing as Fortran..
+ 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 too long
+ (though this is a self-imposed limit), 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 (char *buffer)
+gfc_match_name_C (char *buffer)
{
locus old_loc;
- int i, c;
+ int i = 0;
+ gfc_char_t c;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if (!ISALPHA (c))
+ /* 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 (1);
+
+ /* 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 == '\'')
{
+ buffer[0] = '\0';
gfc_current_locus = old_loc;
- return MATCH_NO;
+ return MATCH_YES;
+ }
+
+ if (!ISALPHA (c) && c != '_')
+ {
+ gfc_error ("Invalid C name in NAME= specifier at %C");
+ return MATCH_ERROR;
}
- i = 0;
-
+ /* Continue to read valid variable name characters. */
do
{
- buffer[i++] = c;
+ gcc_assert (gfc_wide_fits_in_byte (c));
+ buffer[i++] = (unsigned char) c;
+
+ /* C does not define a maximum length of variable names, to my
+ knowledge, but the compiler typically places a limit on them.
+ For now, i'll use the same as the fortran limit for simplicity,
+ but this may need to be changed to a dynamic buffer that can
+ be realloc'ed here if necessary, or more likely, a larger
+ upper-bound set. */
if (i > gfc_option.max_identifier_length)
- {
- gfc_error ("Name at %C is too long");
- return MATCH_ERROR;
- }
-
+ {
+ gfc_error ("Name at %C is too long");
+ return MATCH_ERROR;
+ }
+
old_loc = gfc_current_locus;
- c = gfc_next_char ();
- }
- while (ISALNUM (c)
- || c == '_'
- || (gfc_option.flag_dollar_ok && c == '$'));
+
+ /* Get next char; param means we're in a string. */
+ c = gfc_next_char_literal (1);
+ } while (ISALNUM (c) || c == '_');
buffer[i] = '\0';
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;
}
pointer if successful. */
match
-gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
+gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
if (host_assoc)
return (gfc_get_ha_sym_tree (buffer, matched_symbol))
- ? MATCH_ERROR : MATCH_YES;
+ ? MATCH_ERROR : MATCH_YES;
- if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
+ 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_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
{
gfc_symtree *st;
match m;
if (m == MATCH_YES)
{
if (st)
- *matched_symbol = st->n.sym;
+ *matched_symbol = st->n.sym;
else
- *matched_symbol = NULL;
+ *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)
+gfc_match_intrinsic_op (gfc_intrinsic_op *result)
{
- gfc_intrinsic_op op;
+ locus orig_loc = gfc_current_locus;
+ char ch;
- op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
+ gfc_gobble_whitespace ();
+ ch = gfc_next_ascii_char ();
+ switch (ch)
+ {
+ case '+':
+ /* Matched "+". */
+ *result = INTRINSIC_PLUS;
+ return MATCH_YES;
- if (op == INTRINSIC_NONE)
- return MATCH_NO;
+ case '-':
+ /* Matched "-". */
+ *result = INTRINSIC_MINUS;
+ return MATCH_YES;
- *result = op;
- 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;
}
the equals sign is seen. */
match
-gfc_match_iterator (gfc_iterator * iter, int init_flag)
+gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
- /* Match the start of an iterator without affecting the symbol
- table. */
+ /* Match the start of an iterator without affecting the symbol table. */
start = gfc_current_locus;
m = gfc_match (" %n =", name);
goto cleanup;
}
- if (var->symtree->n.sym->attr.pointer)
- {
- gfc_error ("Loop variable at %C cannot have the POINTER attribute");
- goto cleanup;
- }
+ var->symtree->n.sym->attr.implied_index = 1;
m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
if (m == MATCH_NO)
where = gfc_current_locus;
gfc_gobble_whitespace ();
- if (gfc_next_char () == c)
+ if (gfc_next_ascii_char () == c)
return MATCH_YES;
gfc_current_locus = where;
goto not_yes;
case '%':
- break; /* Fall through to character matcher */
+ break; /* Fall through to character matcher. */
default:
gfc_internal_error ("gfc_match(): Bad match code %c", c);
}
default:
- if (c == gfc_next_char ())
+
+ /* 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;
}
{
case '%':
matches++;
- break; /* Skip */
+ break; /* Skip. */
/* Matches that don't have to be undone */
case 'o':
case 'l':
case 'n':
case 's':
- (void)va_arg (argp, void **);
+ (void) va_arg (argp, void **);
break;
case 'e':
case 'v':
vp = va_arg (argp, void **);
- gfc_free_expr (*vp);
+ gfc_free_expr ((struct gfc_expr *)*vp);
*vp = NULL;
break;
}
gfc_set_sym_referenced (lvalue->symtree->n.sym);
new_st.op = EXEC_ASSIGN;
- new_st.expr = lvalue;
+ new_st.expr1 = lvalue;
new_st.expr2 = rvalue;
gfc_check_do_variable (lvalue->symtree);
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
+ gfc_matching_procptr_assignment = 0;
m = gfc_match (" %v =>", &lvalue);
if (m != MATCH_YES)
goto cleanup;
}
+ if (lvalue->symtree->n.sym->attr.proc_pointer
+ || gfc_is_proc_ptr_comp (lvalue, NULL))
+ gfc_matching_procptr_assignment = 1;
+
m = gfc_match (" %e%t", &rvalue);
+ gfc_matching_procptr_assignment = 0;
if (m != MATCH_YES)
goto cleanup;
new_st.op = EXEC_POINTER_ASSIGN;
- new_st.expr = lvalue;
+ new_st.expr1 = lvalue;
new_st.expr2 = rvalue;
return MATCH_YES;
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)
{
return MATCH_ERROR;
}
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: arithmetic IF statement at %C") == FAILURE)
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
+ "statement at %C") == FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr = expr;
- new_st.label = l1;
+ new_st.expr1 = expr;
+ new_st.label1 = l1;
new_st.label2 = l2;
new_st.label3 = l3;
static match match_simple_where (void);
match
-gfc_match_if (gfc_statement * if_type)
+gfc_match_if (gfc_statement *if_type)
{
gfc_expr *expr;
gfc_st_label *l1, *l2, *l3;
- locus old_loc;
+ locus old_loc, old_loc2;
gfc_code *p;
match m, n;
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");
{
if (n == MATCH_YES)
{
- gfc_error
- ("Block label not appropriate for arithmetic IF statement "
- "at %C");
-
+ gfc_error ("Block label not appropriate for arithmetic IF "
+ "statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
|| 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_DEL,
- "Obsolete: arithmetic IF statement at %C")
- == FAILURE)
- return MATCH_ERROR;
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
+ "statement at %C") == FAILURE)
+ return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
- new_st.expr = expr;
- new_st.label = l1;
+ new_st.expr1 = expr;
+ new_st.label1 = l1;
new_st.label2 = l2;
new_st.label3 = l3;
if (gfc_match (" then%t") == MATCH_YES)
{
new_st.op = EXEC_IF;
- new_st.expr = expr;
-
+ new_st.expr1 = expr;
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
if (n == MATCH_YES)
{
- gfc_error ("Block label is not appropriate IF statement at %C");
-
+ gfc_error ("Block label is not appropriate for IF statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
if (m == MATCH_ERROR)
return MATCH_ERROR;
- gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
+ gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
m = gfc_match_pointer_assignment ();
if (m == MATCH_YES)
gfc_undo_symbols ();
gfc_current_locus = old_loc;
- gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match */
+ 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
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 ("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 ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
/* All else has failed, so give up. See if any of the matchers has
stored an error message of some sort. */
- if (gfc_error_check () == 0)
+ if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
*p->next = new_st;
p->next->loc = gfc_current_locus;
- p->expr = expr;
+ p->expr1 = expr;
p->op = EXEC_IF;
gfc_clear_new_st ();
done:
new_st.op = EXEC_IF;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
cleanup:
/* Free a gfc_iterator structure. */
void
-gfc_free_iterator (gfc_iterator * iter, int flag)
+gfc_free_iterator (gfc_iterator *iter, int flag)
{
if (iter == NULL)
}
+/* 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_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_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 a DO statement. */
match
if (m == MATCH_ERROR)
goto cleanup;
-/* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
+ /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
if (gfc_match_eos () == MATCH_YES)
{
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)
+ /* 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;
+
/* See if we have a DO WHILE. */
if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
{
}
/* The abortive DO WHILE may have done something to the symbol
- table, so we start over: */
+ 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_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 */
+ gfc_match_st_label (&label); /* Can't error out. */
+ gfc_match_char (','); /* Optional comma. */
m = gfc_match_iterator (&iter, 0);
if (m == 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_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
goto cleanup;
- new_st.label = label;
+ new_st.label1 = label;
if (new_st.op == EXEC_DO_WHILE)
- new_st.expr = iter.end;
+ new_st.expr1 = iter.end;
else
{
new_st.ext.iterator = ip = gfc_get_iterator ();
}
}
- /* Find the loop mentioned specified by the label (or lack of a
- label). */
+ /* Find the loop mentioned specified by the label (or lack of a label). */
for (o = NULL, p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
break;
else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
+ else if (p->state == COMP_CRITICAL)
+ {
+ gfc_error("%s statement at %C leaves CRITICAL construct",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
if (p == NULL)
{
new_st.ext.whichloop = p->head;
new_st.op = op;
-/* new_st.sym = sym;*/
return MATCH_YES;
}
match
gfc_match_exit (void)
{
-
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
match
gfc_match_cycle (void)
{
-
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
-/* Match a number or character constant after a STOP or PAUSE statement. */
+/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
static match
gfc_match_stopcode (gfc_statement st)
{
m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
- goto cleanup;
+ goto cleanup;
if (m == MATCH_YES && cnt > 5)
{
}
if (m == MATCH_NO)
- {
- /* Try a character constant. */
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
- goto syntax;
- }
+ {
+ /* Try a character constant. */
+ m = gfc_match_expr (&e);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_NO)
+ goto syntax;
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ goto syntax;
+ }
+
+ if (gfc_match_eos () != MATCH_YES)
+ goto syntax;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("%s statement not allowed in PURE procedure at %C",
+ gfc_ascii_statement (st));
+ goto cleanup;
+ }
+
+ if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement STOP at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
+ 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 = stop_code;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+}
+
+
+/* Match the (deprecated) PAUSE statement. */
+
+match
+gfc_match_pause (void)
+{
+ match m;
+
+ m = gfc_match_stopcode (ST_PAUSE);
+ if (m == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: 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, "Fortran 2008: ERROR STOP statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ return gfc_match_stopcode (ST_ERROR_STOP);
+}
+
+
+/* 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_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_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_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;
+ }
+
+ 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;
+ }
+
+ gfc_gobble_whitespace ();
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
+ if (gfc_peek_char () == ')')
+ break;
+
+ goto syntax;
}
- if (gfc_pure (NULL))
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
{
- gfc_error ("%s statement not allowed in PURE procedure at %C",
- gfc_ascii_statement (st));
- goto cleanup;
+ 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.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
- new_st.expr = e;
- new_st.ext.stop_code = stop_code;
+ new_st.expr1 = imageset;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
return MATCH_YES;
gfc_syntax_error (st);
cleanup:
+ gfc_free_expr (tmp);
+ gfc_free_expr (imageset);
+ gfc_free_expr (stat);
+ gfc_free_expr (errmsg);
- gfc_free_expr (e);
return MATCH_ERROR;
}
-/* Match the (deprecated) PAUSE statement. */
+
+/* Match SYNC ALL statement. */
match
-gfc_match_pause (void)
+gfc_match_sync_all (void)
{
- match m;
+ return sync_statement (ST_SYNC_ALL);
+}
- m = gfc_match_stopcode (ST_PAUSE);
- if (m == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: PAUSE statement at %C")
- == FAILURE)
- m = MATCH_ERROR;
- }
- return m;
+
+/* Match SYNC IMAGES statement. */
+
+match
+gfc_match_sync_images (void)
+{
+ return sync_statement (ST_SYNC_IMAGES);
}
-/* Match the STOP statement. */
+/* Match SYNC MEMORY statement. */
match
-gfc_match_stop (void)
+gfc_match_sync_memory (void)
{
- return gfc_match_stopcode (ST_STOP);
+ return sync_statement (ST_SYNC_MEMORY);
}
match
gfc_match_continue (void)
{
-
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
if (gfc_match (" %l", &label) == MATCH_YES)
{
if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
- return MATCH_ERROR;
+ return MATCH_ERROR;
if (gfc_match (" to %v%t", &expr) == MATCH_YES)
- {
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: ASSIGN statement at %C")
+ {
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
+ expr->symtree->n.sym->attr.assign = 1;
- new_st.op = EXEC_LABEL_ASSIGN;
- new_st.label = label;
- new_st.expr = expr;
- return MATCH_YES;
- }
+ new_st.op = EXEC_LABEL_ASSIGN;
+ new_st.label1 = label;
+ new_st.expr1 = expr;
+ return MATCH_YES;
+ }
}
return MATCH_NO;
}
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
- new_st.label = label;
+ new_st.label1 = label;
return MATCH_YES;
}
if (gfc_match_variable (&expr, 0) == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: Assigned GOTO statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
+ "statement at %C")
== FAILURE)
return MATCH_ERROR;
new_st.op = EXEC_GOTO;
- new_st.expr = expr;
+ new_st.expr1 = expr;
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
tail = tail->block;
}
- tail->label = label;
+ tail->label1 = label;
tail->op = EXEC_GOTO;
}
while (gfc_match_char (',') == MATCH_YES);
if (head == NULL)
{
- gfc_error (
- "Statement label list in GOTO at %C cannot be empty");
+ gfc_error ("Statement label list in GOTO at %C cannot be empty");
goto syntax;
}
new_st.block = head;
tail->next = gfc_get_code ();
tail->next->op = EXEC_GOTO;
- tail->next->label = label;
+ tail->next->label1 = label;
}
while (gfc_match_char (',') == MATCH_YES);
if (gfc_match (" %e%t", &expr) != MATCH_YES)
goto syntax;
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: 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.expr = NULL;
+ 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
/* Frees a list of gfc_alloc structures. */
void
-gfc_free_alloc_list (gfc_alloc * p)
+gfc_free_alloc_list (gfc_alloc *p)
{
gfc_alloc *q;
}
+/* 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)
+{
+ locus old_locus;
+ gfc_symbol *derived;
+
+ old_locus = gfc_current_locus;
+
+ if (gfc_match_symbol (&derived, 1) == MATCH_YES)
+ {
+ if (derived->attr.flavor == FL_DERIVED)
+ {
+ ts->type = BT_DERIVED;
+ ts->u.derived = derived;
+ return MATCH_YES;
+ }
+ else
+ {
+ /* Enforce F03:C476. */
+ gfc_error ("'%s' at %L is not an accessible derived type",
+ derived->name, &gfc_current_locus);
+ return MATCH_ERROR;
+ }
+ }
+
+ 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);
+ old_locus = gfc_current_locus;
+
+ 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;
+ goto char_selector;
+ }
+
+ if (gfc_match ("logical") == MATCH_YES)
+ {
+ ts->type = BT_LOGICAL;
+ ts->kind = gfc_default_logical_kind;
+ goto kind_selector;
+ }
+
+ m = match_derived_type_spec (ts);
+ if (m == MATCH_YES)
+ {
+ old_locus = gfc_current_locus;
+ if (gfc_match (" :: ") != MATCH_YES)
+ return MATCH_ERROR;
+ gfc_current_locus = old_locus;
+ /* Enfore 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;
+ }
+ else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
+ return MATCH_ERROR;
+
+ /* 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;
+
+char_selector:
+
+ m = gfc_match_char_spec (ts);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES; /* No kind specifier found. */
+
+ return m;
+}
+
+
/* Match an ALLOCATE statement. */
match
gfc_match_allocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp, *source;
+ gfc_typespec ts;
+ gfc_symbol *sym;
match m;
+ locus old_locus;
+ bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = source = tmp = NULL;
+ saw_stat = saw_errmsg = saw_source = 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)
+ ts.type = BT_UNKNOWN;
+ else
+ {
+ if (gfc_match (" :: ") == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
+ "ALLOCATE at %L", &old_locus) == FAILURE)
+ goto cleanup;
+ }
+ else
+ {
+ ts.type = BT_UNKNOWN;
+ gfc_current_locus = old_locus;
+ }
+ }
+
for (;;)
{
if (head == NULL)
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
- "PURE procedure");
+ gfc_error ("Bad allocate-object at %C for a PURE procedure");
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)
+ {
+ 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.derived = gfc_use_derived (tail->expr->ts.derived);
+ tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+
+ /* FIXME: disable the checking on derived types and arrays. */
+ 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)
+ b2 = !(sym->ts.u.derived->components->attr.allocatable
+ || sym->ts.u.derived->components->attr.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 %C is not a nonprocedure pointer "
+ "or an allocatable variable");
+ goto cleanup;
+ }
+
+ 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;
- m = gfc_match (" stat = %v", &stat);
+alloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
- }
-
- if (stat != NULL)
- {
- if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
- gfc_error
- ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
- "INTENT(IN)", stat->symtree->n.sym->name);
- goto cleanup;
+ /* Enforce C630. */
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
}
- if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
{
- gfc_error
- ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
- "procedure");
- goto cleanup;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: 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;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
}
- if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
+ m = gfc_match (" source = %e", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
{
- gfc_error("STAT expression at %C must be a variable");
- goto cleanup;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: 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_error ("SOURCE tag at %L requires only a single entity in "
+ "the allocation-list", &tmp->where);
+ goto cleanup;
+ }
+
+ source = tmp;
+ saw_source = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto alloc_opt_list;
}
- gfc_check_do_variable(stat->symtree);
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
}
+
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_ALLOCATE;
- new_st.expr = stat;
- new_st.ext.alloc_list = head;
+ new_st.expr1 = stat;
+ new_st.expr2 = errmsg;
+ new_st.expr3 = source;
+ new_st.ext.alloc.list = head;
+ new_st.ext.alloc.ts = ts;
return MATCH_YES;
gfc_syntax_error (ST_ALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
+ gfc_free_expr (source);
gfc_free_expr (stat);
+ gfc_free_expr (tmp);
gfc_free_alloc_list (head);
return MATCH_ERROR;
}
if (m == MATCH_NO)
goto syntax;
- if (gfc_check_do_variable(p->symtree))
+ if (gfc_check_do_variable (p->symtree))
goto cleanup;
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
- gfc_error
- ("Illegal variable in NULLIFY at %C for a PURE procedure");
+ gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
- /* build ' => NULL() ' */
+ /* build ' => NULL() '. */
e = gfc_get_expr ();
e->where = gfc_current_locus;
e->expr_type = EXPR_NULL;
e->ts.type = BT_UNKNOWN;
- /* Chain to list */
+ /* Chain to list. */
if (tail == NULL)
tail = &new_st;
else
}
tail->op = EXEC_POINTER_ASSIGN;
- tail->expr = p;
+ tail->expr1 = p;
tail->expr2 = e;
if (gfc_match (" )%t") == MATCH_YES)
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;
}
gfc_match_deallocate (void)
{
gfc_alloc *head, *tail;
- gfc_expr *stat;
+ gfc_expr *stat, *errmsg, *tmp;
+ gfc_symbol *sym;
match m;
+ bool saw_stat, saw_errmsg, b1, b2;
head = tail = NULL;
- stat = NULL;
+ stat = errmsg = tmp = NULL;
+ saw_stat = saw_errmsg = false;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
- if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ 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;
+ }
+
+ /* 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 = !(sym->ts.u.derived->components->attr.allocatable
+ || sym->ts.u.derived->components->attr.pointer);
+ else
+ b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
+ || sym->attr.proc_pointer);
+ if (b1 && b2)
{
- gfc_error
- ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
- "procedure");
+ gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
+ "or an allocatable variable");
goto cleanup;
}
if (gfc_match_char (',') != MATCH_YES)
break;
- m = gfc_match (" stat = %v", &stat);
+dealloc_opt_list:
+
+ m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
- break;
- }
-
- if (stat != NULL)
- {
- if (stat->symtree->n.sym->attr.intent == INTENT_IN)
{
- gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
- "cannot be INTENT(IN)", stat->symtree->n.sym->name);
- goto cleanup;
- }
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_free_expr (tmp);
+ goto cleanup;
+ }
- if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
- {
- gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
- "for a PURE procedure");
- goto cleanup;
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_check_do_variable (stat->symtree))
+ goto cleanup;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ goto dealloc_opt_list;
}
- if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ if (m == MATCH_YES)
{
- gfc_error("STAT expression at %C must be a variable");
- goto cleanup;
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: 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_check_do_variable(stat->symtree);
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
}
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
new_st.op = EXEC_DEALLOCATE;
- new_st.expr = stat;
- new_st.ext.alloc_list = head;
+ new_st.expr1 = stat;
+ new_st.expr2 = errmsg;
+ new_st.ext.alloc.list = head;
return MATCH_YES;
gfc_syntax_error (ST_DEALLOCATE);
cleanup:
+ gfc_free_expr (errmsg);
gfc_free_expr (stat);
gfc_free_alloc_list (head);
return MATCH_ERROR;
gfc_expr *e;
match m;
gfc_compile_state s;
- int c;
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_match_eos () == MATCH_YES)
goto done;
goto cleanup;
}
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: 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) */
- c = gfc_peek_char ();
+ RETURN keyword:
+ return+1
+ return(1) */
+ char c = gfc_peek_ascii_char ();
if (ISALPHA (c) || ISDIGIT (c))
- return MATCH_NO;
+ return MATCH_NO;
}
m = gfc_match (" %e%t", &e);
if (m == MATCH_ERROR)
goto cleanup;
- gfc_syntax_error (ST_RETURN);
+ gfc_syntax_error (ST_RETURN);
+
+cleanup:
+ gfc_free_expr (e);
+ return MATCH_ERROR;
+
+done:
+ gfc_enclosing_unit (&s);
+ if (s == COMP_PROGRAM
+ && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
+ "main program at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_RETURN;
+ new_st.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;
-cleanup:
- gfc_free_expr (e);
- return MATCH_ERROR;
+ 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;
-done:
- gfc_enclosing_unit (&s);
- if (s == COMP_PROGRAM
- && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
- "main program at %C") == FAILURE)
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after CALL at %C");
return MATCH_ERROR;
+ }
- new_st.op = EXEC_RETURN;
- new_st.expr = e;
+ 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;
}
return MATCH_ERROR;
sym = st->n.sym;
- gfc_set_sym_referenced (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
- && gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
- return MATCH_ERROR;
+ && !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)
{
i = 0;
for (a = arglist; a; a = a->next)
if (a->expr == NULL)
- i = 1;
+ i = 1;
if (i)
{
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 */
+ sprintf (name, "_result_%s", sym->name);
+ gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */
select_sym = select_st->n.sym;
select_sym->ts.type = BT_INTEGER;
select_sym->ts.kind = gfc_default_integer_kind;
gfc_set_sym_referenced (select_sym);
- c->expr = gfc_get_expr ();
- c->expr->expr_type = EXPR_VARIABLE;
- c->expr->symtree = select_st;
- c->expr->ts = select_sym->ts;
- c->expr->where = gfc_current_locus;
+ 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)
c->next = gfc_get_code ();
c->next->op = EXEC_GOTO;
- c->next->label = a->label;
+ c->next->label1 = a->label;
}
}
{
gfc_symtree *st;
static int serial = 0;
- char mangled_name[GFC_MAX_SYMBOL_LEN+1];
+ 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);
+ snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else
/* Match a common block name. */
-static match
-match_common_name (char *name)
+match match_common_name (char *name)
{
match m;
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
- char name[GFC_MAX_SYMBOL_LEN+1];
+ char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *t;
gfc_array_spec *as;
- gfc_equiv * e1, * e2;
+ gfc_equiv *e1, *e2;
match m;
gfc_gsymbol *gsym;
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);
+ gfc_error ("Symbol '%s' at %C is already an external symbol that "
+ "is not COMMON", name);
goto cleanup;
}
if (name[0] == '\0')
{
- if (gfc_current_ns->is_block_data)
- {
- gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C");
- }
t = &gfc_current_ns->blank_common;
if (t->head == NULL)
t->where = gfc_current_locus;
if (m == MATCH_NO)
goto syntax;
+ /* Store a ref to the common block for error checking. */
+ sym->common_block = t;
+
+ /* 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",
goto cleanup;
}
- if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
- goto cleanup;
-
- if (sym->value != NULL
- && (name[0] == '\0' || !sym->attr.data))
+ if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
+ || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
- if (name[0] == '\0')
- gfc_error ("Previously initialized symbol '%s' in "
- "blank COMMON block at %C", sym->name);
- else
- gfc_error ("Previously initialized symbol '%s' in "
- "COMMON block '%s' at %C", sym->name, name);
- goto cleanup;
+ if (gfc_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;
- /* Derived type names must have the SEQUENCE attribute. */
- if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
- {
- gfc_error
- ("Derived type variable in COMMON at %C does not have the "
- "SEQUENCE attribute");
- goto cleanup;
- }
-
if (tail != NULL)
tail->common_next = sym;
else
tail = sym;
/* Deal with an optional array specification after the
- symbol name. */
- m = gfc_match_array_spec (&as);
+ symbol name. */
+ m = gfc_match_array_spec (&as, true, true);
if (m == MATCH_ERROR)
goto cleanup;
{
if (as->type != AS_EXPLICIT)
{
- gfc_error
- ("Array specification for symbol '%s' in COMMON at %C "
- "must be explicit", sym->name);
+ gfc_error ("Array specification for symbol '%s' in COMMON "
+ "at %C must be explicit", sym->name);
goto cleanup;
}
if (sym->attr.pointer)
{
- gfc_error
- ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
- sym->name);
+ gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
+ "POINTER array", sym->name);
goto cleanup;
}
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)
+ {
+ for (e2 = e1; e2; e2 = e2->eq)
+ if (e2->expr->symtree->n.sym == sym)
goto equiv_found;
continue;
{
other = e2->expr->symtree->n.sym;
if (other->common_head
- && other->common_head != sym->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,
+ sym->name, sym->common_head->name,
other->common_head->name);
goto cleanup;
}
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
goto done;
- if (gfc_peek_char () == '/')
+ if (gfc_peek_ascii_char () == '/')
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
gfc_gobble_whitespace ();
- if (gfc_peek_char () == '/')
+ if (gfc_peek_ascii_char () == '/')
break;
}
}
/* Free a namelist structure. */
void
-gfc_free_namelist (gfc_namelist * name)
+gfc_free_namelist (gfc_namelist *name)
{
gfc_namelist *n;
{
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));
+ 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)
+ && 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_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
goto error;
- /* Use gfc_error_check here, rather than goto error, so that this
+ /* 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 ("Assumed size array '%s' in namelist '%s' at "
+ "%C is not allowed", sym->name, group_name->name);
gfc_error_check ();
}
- if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
- && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
- "namelist '%s' at %C is an extension.",
- sym->name, group_name->name) == FAILURE)
- gfc_error_check ();
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
+ {
+ gfc_error ("Assumed character length '%s' in namelist '%s' at "
+ "%C is not allowed", sym->name, group_name->name);
+ gfc_error_check ();
+ }
nl = gfc_get_namelist ();
nl->sym = sym;
do this. */
void
-gfc_free_equiv (gfc_equiv * eq)
+gfc_free_equiv (gfc_equiv *eq)
{
-
if (eq == NULL)
return;
gfc_free_equiv (eq->eq);
gfc_free_equiv (eq->next);
-
gfc_free_expr (eq->expr);
gfc_free (eq);
}
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");
+ 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)
+ if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.in_common)
/* 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. */
+ common blocks. */
if (common_flag)
for (set = eq; set; set = set->eq)
{
{
gfc_error ("Attempt to indirectly overlap COMMON "
"blocks %s and %s by EQUIVALENCE at %C",
- sym->common_head->name,
- common_head->name);
+ sym->common_head->name, common_head->name);
goto cleanup;
}
sym->attr.in_common = 1;
if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
+ {
+ gfc_error ("Expecting a comma in EQUIVALENCE at %C");
+ goto cleanup;
+ }
}
return MATCH_YES;
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
-recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- gfc_actual_arglist *arg;
- gfc_ref *ref;
- int i;
if (e == NULL)
return false;
switch (e->expr_type)
{
case EXPR_FUNCTION:
- for (arg = e->value.function.actual; arg; arg = arg->next)
- {
- if (sym->name == arg->name
- || recursive_stmt_fcn (arg->expr, sym))
- return true;
- }
-
if (e->symtree == NULL)
return false;
/* 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))
+ && 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_OP:
- if (recursive_stmt_fcn (e->value.op.op1, sym)
- || recursive_stmt_fcn (e->value.op.op2, sym))
- return true;
- break;
-
default:
break;
}
- /* Component references do not need to be checked. */
- if (e->ref)
- {
- for (ref = e->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- for (i = 0; i < ref->u.ar.dimen; i++)
- {
- if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
- || recursive_stmt_fcn (ref->u.ar.end[i], sym)
- || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
- return true;
- }
- break;
-
- case REF_SUBSTRING:
- if (recursive_stmt_fcn (ref->u.ss.start, sym)
- || recursive_stmt_fcn (ref->u.ss.end, sym))
- return true;
+ return false;
+}
- 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);
}
if (recursive_stmt_fcn (expr, sym))
{
- gfc_error ("Statement function at %L is recursive",
- &expr->where);
+ gfc_error ("Statement function at %L is recursive", &expr->where);
return MATCH_ERROR;
}
sym->value = expr;
+ if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
+ "Statement function at %C") == FAILURE)
+ return MATCH_ERROR;
+
return MATCH_YES;
undo_error:
/* Free a single case structure. */
static void
-free_case (gfc_case * p)
+free_case (gfc_case *p)
{
if (p->low == p->high)
p->high = NULL;
/* Free a list of case structures. */
void
-gfc_free_case_list (gfc_case * p)
+gfc_free_case_list (gfc_case *p)
{
gfc_case *q;
/* Match a single case selector. */
static match
-match_case_selector (gfc_case ** cp)
+match_case_selector (gfc_case **cp)
{
gfc_case *c;
match m;
if (m == MATCH_ERROR)
goto cleanup;
}
-
else
{
m = gfc_match_init_expr (&c->low);
/* If the case construct doesn't have a case-construct-name, we
should have matched the EOS. */
if (!gfc_current_block ())
- {
- gfc_error ("Expected the name of the select case construct at %C");
- return MATCH_ERROR;
- }
+ return MATCH_NO;
gfc_gobble_whitespace ();
if (strcmp (name, gfc_current_block ()->name) != 0)
{
- gfc_error ("Expected case name of '%s' at %C",
+ gfc_error ("Expected block name '%s' of SELECT construct at %C",
gfc_current_block ()->name);
return MATCH_ERROR;
}
return m;
new_st.op = EXEC_SELECT;
- new_st.expr = expr;
+ new_st.expr1 = expr;
+
+ return MATCH_YES;
+}
+
+
+/* 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 SELECT TYPE selector. */
+
+static void
+select_type_set_tmp (gfc_typespec *ts)
+{
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+
+ if (!gfc_type_is_extensible (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);
+ gfc_set_sym_referenced (tmp->n.sym);
+ gfc_add_pointer (&tmp->n.sym->attr, NULL);
+ gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+ if (ts->type == BT_CLASS)
+ {
+ gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
+ &tmp->n.sym->as);
+ tmp->n.sym->attr.class_ok = 1;
+ }
+
+ 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];
+
+ m = gfc_match_label ();
+ if (m == MATCH_ERROR)
+ return m;
+
+ m = gfc_match (" select type ( ");
+ if (m != MATCH_YES)
+ return m;
+
+ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
+
+ 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))
+ return MATCH_ERROR;
+ expr1->symtree->n.sym->ts = expr2->ts;
+ expr1->symtree->n.sym->attr.referenced = 1;
+ expr1->symtree->n.sym->attr.class_ok = 1;
+ }
+ else
+ {
+ m = gfc_match (" %e ", &expr1);
+ if (m != MATCH_YES)
+ return m;
+ }
+
+ m = gfc_match (" )%t");
+ if (m != MATCH_YES)
+ return m;
+
+ /* Check for F03:C811. */
+ if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
+ {
+ gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
+ "use associate-name=>");
+ return MATCH_ERROR;
+ }
+
+ /* Check for F03:C813. */
+ if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
+ {
+ gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_SELECT_TYPE;
+ new_st.expr1 = expr1;
+ new_st.expr2 = expr2;
+ new_st.ext.ns = gfc_current_ns;
+
+ select_type_push (expr1->symtree->n.sym);
return MATCH_YES;
}
return MATCH_YES;
syntax:
- gfc_error ("Syntax error in CASE-specification at %C");
+ 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;
+
+ /* TODO: Once unlimited polymorphism is implemented, we will need to call
+ match_type_spec here. */
+ if (match_derived_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.case_list = c;
+
+ /* 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.case_list = c;
+ 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.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.
c = gfc_get_code ();
c->op = EXEC_WHERE;
- c->expr = expr;
+ c->expr1 = expr;
c->next = gfc_get_code ();
*c->next = new_st;
return MATCH_ERROR;
}
+
/* Match a WHERE statement. */
match
-gfc_match_where (gfc_statement * st)
+gfc_match_where (gfc_statement *st)
{
gfc_expr *expr;
match m0, m;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
-
new_st.op = EXEC_WHERE;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
}
c = gfc_get_code ();
c->op = EXEC_WHERE;
- c->expr = expr;
+ c->expr1 = expr;
c->next = gfc_get_code ();
*c->next = new_st;
}
if (gfc_match_eos () != MATCH_YES)
- { /* Better be a name at this point */
+ {
+ /* 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;
}
new_st.op = EXEC_WHERE;
- new_st.expr = expr;
+ new_st.expr1 = expr;
return MATCH_YES;
syntax:
/* Free a list of FORALL iterators. */
void
-gfc_free_forall_iterator (gfc_forall_iterator * iter)
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
{
gfc_forall_iterator *next;
while (iter)
{
next = iter->next;
-
gfc_free_expr (iter->var);
gfc_free_expr (iter->start);
gfc_free_expr (iter->end);
gfc_free_expr (iter->stride);
-
gfc_free (iter);
iter = next;
}
/* Match an iterator as part of a FORALL statement. The format is:
- <var> = <start>:<end>[:<stride>][, <scalar mask>] */
+ <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)
+match_forall_iterator (gfc_forall_iterator **result)
{
gfc_forall_iterator *iter;
locus where;
match m;
where = gfc_current_locus;
- iter = gfc_getmem (sizeof (gfc_forall_iterator));
+ iter = XCNEW (gfc_forall_iterator);
- m = gfc_match_variable (&iter->var, 0);
+ m = gfc_match_expr (&iter->var);
if (m != MATCH_YES)
goto cleanup;
- if (gfc_match_char ('=') != MATCH_YES)
+ if (gfc_match_char ('=') != MATCH_YES
+ || iter->var->expr_type != EXPR_VARIABLE)
{
m = MATCH_NO;
goto cleanup;
m = MATCH_ERROR;
cleanup:
- /* Make sure that potential internal function references in the
- mask do not get messed up. */
- if (iter->var
- && iter->var->expr_type == EXPR_VARIABLE
- && iter->var->symtree->n.sym->refs == 1)
- iter->var->symtree->n.sym->attr.flavor = FL_UNKNOWN;
gfc_current_locus = where;
gfc_free_forall_iterator (iter);
/* Match the header of a FORALL statement. */
static match
-match_forall_header (gfc_forall_iterator ** phead, gfc_expr ** mask)
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
- gfc_forall_iterator *head, *tail, *new;
+ gfc_forall_iterator *head, *tail, *new_iter;
gfc_expr *msk;
match m;
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
- head = tail = new;
+ head = tail = new_iter;
for (;;)
{
if (gfc_match_char (',') != MATCH_YES)
break;
- m = match_forall_iterator (&new);
+ m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_YES)
{
- tail->next = new;
- tail = new;
+ tail->next = new_iter;
+ tail = new_iter;
continue;
}
- /* Have to have a mask expression */
+ /* Have to have a mask expression. */
m = gfc_match_expr (&msk);
if (m == MATCH_NO)
return MATCH_ERROR;
}
-/* Match the rest of a simple FORALL statement that follows an IF statement.
- */
+/* Match the rest of a simple FORALL statement that follows an
+ IF statement. */
static match
match_simple_forall (void)
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
/* Match a FORALL statement. */
match
-gfc_match_forall (gfc_statement * st)
+gfc_match_forall (gfc_statement *st)
{
gfc_forall_iterator *head;
gfc_expr *mask;
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_FORALL_BLOCK;
-
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ new_st.expr1 = mask;
new_st.ext.forall_iterator = head;
-
return MATCH_YES;
}
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
- new_st.expr = mask;
+ 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;
OSDN Git Service
