/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ 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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
-
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include <stdarg.h>
-#include <string.h>
-
#include "gfortran.h"
#include "match.h"
#include "parse.h"
-/* For matching and debugging purposes. Order matters here! The
- unary operators /must/ precede the binary plus and minus, or
- the expression parser breaks. */
-
-mstring intrinsic_operators[] = {
- minit ("+", INTRINSIC_UPLUS),
- minit ("-", INTRINSIC_UMINUS),
- minit ("+", INTRINSIC_PLUS),
- minit ("-", INTRINSIC_MINUS),
- minit ("**", INTRINSIC_POWER),
- minit ("//", INTRINSIC_CONCAT),
- minit ("*", INTRINSIC_TIMES),
- minit ("/", INTRINSIC_DIVIDE),
- minit (".and.", INTRINSIC_AND),
- minit (".or.", INTRINSIC_OR),
- minit (".eqv.", INTRINSIC_EQV),
- minit (".neqv.", INTRINSIC_NEQV),
- minit (".eq.", INTRINSIC_EQ),
- minit ("==", INTRINSIC_EQ),
- minit (".ne.", INTRINSIC_NE),
- minit ("/=", INTRINSIC_NE),
- minit (".ge.", INTRINSIC_GE),
- minit (">=", INTRINSIC_GE),
- minit (".le.", INTRINSIC_LE),
- minit ("<=", INTRINSIC_LE),
- minit (".lt.", INTRINSIC_LT),
- minit ("<", INTRINSIC_LT),
- minit (".gt.", INTRINSIC_GT),
- minit (">", INTRINSIC_GT),
- minit (".not.", INTRINSIC_NOT),
- minit (NULL, INTRINSIC_NONE)
-};
+
+/* 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 c, count, instring;
+ char 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 = (char) 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 before %L", &where);
+ return MATCH_ERROR;
+ }
+ if (count < 0)
+ {
+ gfc_error ("Missing '(' in statement 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 (int *c)
+{
+
+ match m;
+
+ m = MATCH_YES;
+
+ switch (gfc_next_char_literal (1))
+ {
+ case 'a':
+ *c = '\a';
+ break;
+ case 'b':
+ *c = '\b';
+ break;
+ case 't':
+ *c = '\t';
+ break;
+ case 'f':
+ *c = '\f';
+ break;
+ case 'n':
+ *c = '\n';
+ break;
+ case 'r':
+ *c = '\r';
+ break;
+ case 'v':
+ *c = '\v';
+ break;
+ case '\\':
+ *c = '\\';
+ break;
+ case '0':
+ *c = '\0';
+ 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. */
if (gfc_current_form == FORM_FIXED)
return MATCH_YES;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!gfc_is_whitespace (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
}
while (c != '\n');
- /* Fall through */
+ /* Fall through. */
case '\n':
return MATCH_YES;
break;
}
- gfc_set_locus (&old_loc);
+ 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. */
+ 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)
+gfc_match_small_literal_int (int *value, int *cnt)
{
locus old_loc;
char c;
- int i;
+ int i, j;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
+ if (cnt)
+ *cnt = 0;
if (!ISDIGIT (c))
{
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
return MATCH_NO;
}
i = c - '0';
+ j = 1;
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
c = gfc_next_char ();
if (!ISDIGIT (c))
break;
i = 10 * i + c - '0';
+ j++;
if (i > 99999999)
{
}
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
*value = i;
+ if (cnt)
+ *cnt = j;
return MATCH_YES;
}
}
+/* 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, int allow_zero)
+gfc_match_st_label (gfc_st_label **label)
{
locus old_loc;
match m;
- int i;
+ int i, cnt;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
- m = gfc_match_small_literal_int (&i);
+ m = gfc_match_small_literal_int (&i, &cnt);
if (m != MATCH_YES)
return m;
- if (((i == 0) && allow_zero) || i <= 99999)
+ if (cnt > 5)
{
- *label = gfc_get_st_label (i);
- return MATCH_YES;
+ 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;
}
- gfc_error ("Statement label at %C is out of range");
- gfc_set_locus (&old_loc);
+ *label = gfc_get_st_label (i);
+ return MATCH_YES;
+
+cleanup:
+
+ gfc_current_locus = old_loc;
return MATCH_ERROR;
}
gfc_match_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_state_data *p;
match m;
gfc_new_block = NULL;
return MATCH_ERROR;
}
- if (gfc_new_block->attr.flavor != FL_LABEL
- && gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE)
- return MATCH_ERROR;
+ if (gfc_new_block->attr.flavor == FL_LABEL)
+ {
+ gfc_error ("Duplicate construct label '%s' at %C", name);
+ return MATCH_ERROR;
+ }
- for (p = gfc_state_stack; p; p = p->previous)
- if (p->sym == gfc_new_block)
- {
- gfc_error ("Label %s at %C already in use by a parent block",
- gfc_new_block->name);
- return MATCH_ERROR;
- }
+ if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
+ gfc_new_block->name, NULL) == FAILURE)
+ return MATCH_ERROR;
return MATCH_YES;
}
-/* Try and match the input against an array of possibilities. If one
- potential matching string is a substring of another, the longest
- match takes precedence. Spaces in the target strings are optional
- spaces that do not necessarily have to be found in the input
- stream. In fixed mode, spaces never appear. If whitespace is
- matched, it matches unlimited whitespace in the input. For this
- reason, the 'mp' member of the mstring structure is used to track
- the progress of each potential match.
-
- If there is no match we return the tag associated with the
- terminating NULL mstring structure and leave the locus pointer
- where it started. If there is a match we return the tag member of
- the matched mstring and leave the locus pointer after the matched
- character.
-
- A '%' character is a mandatory space. */
+/* 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, c;
- possibles = 0;
+ old_loc = gfc_current_locus;
+ gfc_gobble_whitespace ();
- for (p = a; p->string != NULL; p++)
+ c = gfc_next_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++;
- }
-
- if (*p->mp != c)
- {
- /* Match failed. */
- p->mp = NULL;
- possibles--;
- continue;
- }
-
- p->mp++;
- if (*p->mp == '\0')
- {
- /* Found a match. */
- match_loc = *gfc_current_locus ();
- best_match = p;
- possibles--;
- p->mp = NULL;
- }
+ gfc_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 == '$'));
- gfc_set_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;
+ int c;
- old_loc = *gfc_current_locus ();
+ 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 == '\'')
{
- gfc_set_locus (&old_loc);
- return MATCH_NO;
+ buffer[0] = '\0';
+ 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;
}
- i = 0;
-
+ /* Continue to read valid variable name characters. */
do
{
buffer[i++] = 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;
- }
-
- old_loc = *gfc_current_locus ();
- c = gfc_next_char ();
- }
- while (ISALNUM (c)
- || c == '_'
- || (gfc_option.flag_dollar_ok && c == '$'));
+ {
+ gfc_error ("Name at %C is too long");
+ return MATCH_ERROR;
+ }
+
+ old_loc = gfc_current_locus;
+
+ /* Get next char; param means we're in a string. */
+ c = gfc_next_char_literal (1);
+ } while (ISALNUM (c) || c == '_');
buffer[i] = '\0';
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
+
+ /* See if we stopped because of whitespace. */
+ if (c == ' ')
+ {
+ gfc_gobble_whitespace ();
+ c = gfc_peek_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))
return MATCH_ERROR;
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;
+ int ch;
- op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
+ gfc_gobble_whitespace ();
+ ch = gfc_next_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_char () == '=')
+ {
+ /* Matched "==". */
+ *result = INTRINSIC_EQ;
+ return MATCH_YES;
+ }
+ break;
+ case '<':
+ if (gfc_peek_char () == '=')
+ {
+ /* Matched "<=". */
+ gfc_next_char ();
+ *result = INTRINSIC_LE;
+ return MATCH_YES;
+ }
+ /* Matched "<". */
+ *result = INTRINSIC_LT;
+ return MATCH_YES;
-/* Match a loop control phrase:
+ case '>':
+ if (gfc_peek_char () == '=')
+ {
+ /* Matched ">=". */
+ gfc_next_char ();
+ *result = INTRINSIC_GE;
+ return MATCH_YES;
+ }
+ /* Matched ">". */
+ *result = INTRINSIC_GT;
+ return MATCH_YES;
- <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
+ case '*':
+ if (gfc_peek_char () == '*')
+ {
+ /* Matched "**". */
+ gfc_next_char ();
+ *result = INTRINSIC_POWER;
+ return MATCH_YES;
+ }
+ /* Matched "*". */
+ *result = INTRINSIC_TIMES;
+ return MATCH_YES;
- 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. */
+ case '/':
+ ch = gfc_peek_char ();
+ if (ch == '=')
+ {
+ /* Matched "/=". */
+ gfc_next_char ();
+ *result = INTRINSIC_NE;
+ return MATCH_YES;
+ }
+ else if (ch == '/')
+ {
+ /* Matched "//". */
+ gfc_next_char ();
+ *result = INTRINSIC_CONCAT;
+ return MATCH_YES;
+ }
+ /* Matched "/". */
+ *result = INTRINSIC_DIVIDE;
+ return MATCH_YES;
-match
-gfc_match_iterator (gfc_iterator * iter, int init_flag)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_expr *var, *e1, *e2, *e3;
- locus start;
- match m;
+ case '.':
+ ch = gfc_next_char ();
+ switch (ch)
+ {
+ case 'a':
+ if (gfc_next_char () == 'n'
+ && gfc_next_char () == 'd'
+ && gfc_next_char () == '.')
+ {
+ /* Matched ".and.". */
+ *result = INTRINSIC_AND;
+ return MATCH_YES;
+ }
+ break;
- /* Match the start of an iterator without affecting the symbol
- table. */
+ case 'e':
+ if (gfc_next_char () == 'q')
+ {
+ ch = gfc_next_char ();
+ if (ch == '.')
+ {
+ /* Matched ".eq.". */
+ *result = INTRINSIC_EQ_OS;
+ return MATCH_YES;
+ }
+ else if (ch == 'v')
+ {
+ if (gfc_next_char () == '.')
+ {
+ /* Matched ".eqv.". */
+ *result = INTRINSIC_EQV;
+ return MATCH_YES;
+ }
+ }
+ }
+ break;
- start = *gfc_current_locus ();
- m = gfc_match (" %n =", name);
- gfc_set_locus (&start);
+ case 'g':
+ ch = gfc_next_char ();
+ if (ch == 'e')
+ {
+ if (gfc_next_char () == '.')
+ {
+ /* Matched ".ge.". */
+ *result = INTRINSIC_GE_OS;
+ return MATCH_YES;
+ }
+ }
+ else if (ch == 't')
+ {
+ if (gfc_next_char () == '.')
+ {
+ /* Matched ".gt.". */
+ *result = INTRINSIC_GT_OS;
+ return MATCH_YES;
+ }
+ }
+ break;
- if (m != MATCH_YES)
- return MATCH_NO;
+ case 'l':
+ ch = gfc_next_char ();
+ if (ch == 'e')
+ {
+ if (gfc_next_char () == '.')
+ {
+ /* Matched ".le.". */
+ *result = INTRINSIC_LE_OS;
+ return MATCH_YES;
+ }
+ }
+ else if (ch == 't')
+ {
+ if (gfc_next_char () == '.')
+ {
+ /* Matched ".lt.". */
+ *result = INTRINSIC_LT_OS;
+ return MATCH_YES;
+ }
+ }
+ break;
- m = gfc_match_variable (&var, 0);
- if (m != MATCH_YES)
- return MATCH_NO;
+ case 'n':
+ ch = gfc_next_char ();
+ if (ch == 'e')
+ {
+ ch = gfc_next_char ();
+ if (ch == '.')
+ {
+ /* Matched ".ne.". */
+ *result = INTRINSIC_NE_OS;
+ return MATCH_YES;
+ }
+ else if (ch == 'q')
+ {
+ if (gfc_next_char () == 'v'
+ && gfc_next_char () == '.')
+ {
+ /* Matched ".neqv.". */
+ *result = INTRINSIC_NEQV;
+ return MATCH_YES;
+ }
+ }
+ }
+ else if (ch == 'o')
+ {
+ if (gfc_next_char () == 't'
+ && gfc_next_char () == '.')
+ {
+ /* Matched ".not.". */
+ *result = INTRINSIC_NOT;
+ return MATCH_YES;
+ }
+ }
+ break;
+
+ case 'o':
+ if (gfc_next_char () == 'r'
+ && gfc_next_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;
+
+ /* 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;
gfc_match_char ('=');
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)
{
locus where;
- where = *gfc_current_locus ();
+ where = gfc_current_locus;
gfc_gobble_whitespace ();
if (gfc_next_char () == c)
return MATCH_YES;
- gfc_set_locus (&where);
+ gfc_current_locus = where;
return MATCH_NO;
}
void **vp;
const char *p;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
va_start (argp, target);
m = MATCH_NO;
matches = 0;
case 'l':
label = va_arg (argp, gfc_st_label **);
- n = gfc_match_st_label (label, 0);
+ n = gfc_match_st_label (label);
if (n != MATCH_YES)
{
m = n;
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);
if (m != MATCH_YES)
{
/* Clean up after a failed match. */
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
va_start (argp, target);
p = target;
{
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':
/*********************** Statement level matching **********************/
/* Matches the start of a program unit, which is the program keyword
- followed by an optional symbol. */
+ followed by an obligatory symbol. */
match
gfc_match_program (void)
gfc_symbol *sym;
match m;
- m = gfc_match_eos ();
- if (m == MATCH_YES)
- return m;
-
m = gfc_match ("% %s%t", &sym);
if (m == MATCH_NO)
if (m == MATCH_ERROR)
return m;
- if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE)
+ if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
- lvalue = rvalue = NULL;
+ lvalue = NULL;
m = gfc_match (" %v =", &lvalue);
if (m != MATCH_YES)
- goto cleanup;
+ {
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ return MATCH_NO;
+ }
+
+ if (lvalue->symtree->n.sym->attr.protected
+ && lvalue->symtree->n.sym->attr.use_assoc)
+ {
+ gfc_current_locus = old_loc;
+ gfc_free_expr (lvalue);
+ gfc_error ("Setting value of PROTECTED variable at %C");
+ return MATCH_ERROR;
+ }
+ rvalue = NULL;
m = gfc_match (" %e%t", &rvalue);
if (m != MATCH_YES)
- goto cleanup;
+ {
+ 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.expr = lvalue;
new_st.expr2 = rvalue;
- return MATCH_YES;
+ gfc_check_do_variable (lvalue->symtree);
-cleanup:
- gfc_set_locus (&old_loc);
- gfc_free_expr (lvalue);
- gfc_free_expr (rvalue);
- return m;
+ return MATCH_YES;
}
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
if (m != MATCH_YES)
goto cleanup;
+ if (lvalue->symtree->n.sym->attr.protected
+ && lvalue->symtree->n.sym->attr.use_assoc)
+ {
+ gfc_error ("Assigning to a PROTECTED pointer at %C");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
new_st.op = EXEC_POINTER_ASSIGN;
new_st.expr = lvalue;
new_st.expr2 = rvalue;
return MATCH_YES;
cleanup:
- gfc_set_locus (&old_loc);
+ gfc_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, "Obsolescent: arithmetic IF statement "
+ "at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ new_st.op = EXEC_ARITHMETIC_IF;
+ new_st.expr = expr;
+ new_st.label = l1;
+ new_st.label2 = l2;
+ new_st.label3 = l3;
+
+ return MATCH_YES;
+}
+
+
/* 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.
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_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 (n == MATCH_ERROR)
return n;
- old_loc = *gfc_current_locus ();
+ 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");
{
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_OBS, "Obsolescent: arithmetic IF "
+ "statement at %C") == FAILURE)
+ return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
new_st.expr = expr;
return MATCH_YES;
}
- if (gfc_match (" then %t") == MATCH_YES)
+ if (gfc_match (" then%t") == MATCH_YES)
{
new_st.op = EXEC_IF;
new_st.expr = expr;
-
*if_type = ST_IF_BLOCK;
return MATCH_YES;
}
if (n == MATCH_YES)
{
- gfc_error ("Block label is not appropriate IF statement at %C");
-
+ gfc_error ("Block label is not appropriate for IF statement at %C");
gfc_free_expr (expr);
return MATCH_ERROR;
}
gfc_free_expr (expr);
gfc_undo_symbols ();
- gfc_set_locus (&old_loc);
+ 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 */
+ gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */
m = gfc_match_pointer_assignment ();
if (m == MATCH_YES)
gfc_free_expr (expr);
gfc_undo_symbols ();
- gfc_set_locus (&old_loc);
+ 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
gfc_clear_error ();
match ("allocate", gfc_match_allocate, ST_ALLOCATE)
- match ("backspace", gfc_match_backspace, ST_BACKSPACE)
- match ("call", gfc_match_call, ST_CALL)
- match ("close", gfc_match_close, ST_CLOSE)
- match ("continue", gfc_match_continue, ST_CONTINUE)
- match ("cycle", gfc_match_cycle, ST_CYCLE)
- match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
- match ("end file", gfc_match_endfile, ST_END_FILE)
- match ("exit", gfc_match_exit, ST_EXIT)
- match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
- match ("go to", gfc_match_goto, ST_GOTO)
- match ("inquire", gfc_match_inquire, ST_INQUIRE)
- match ("nullify", gfc_match_nullify, ST_NULLIFY)
- match ("open", gfc_match_open, ST_OPEN)
- match ("pause", gfc_match_pause, ST_NONE)
- match ("print", gfc_match_print, ST_WRITE)
- match ("read", gfc_match_read, ST_READ)
- match ("return", gfc_match_return, ST_RETURN)
- match ("rewind", gfc_match_rewind, ST_REWIND)
- match ("pause", gfc_match_stop, ST_PAUSE)
- match ("stop", gfc_match_stop, ST_STOP)
- match ("write", gfc_match_write, ST_WRITE)
+ match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
+ match ("backspace", gfc_match_backspace, ST_BACKSPACE)
+ match ("call", gfc_match_call, ST_CALL)
+ match ("close", gfc_match_close, ST_CLOSE)
+ match ("continue", gfc_match_continue, ST_CONTINUE)
+ match ("cycle", gfc_match_cycle, ST_CYCLE)
+ match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
+ match ("end file", gfc_match_endfile, ST_END_FILE)
+ match ("exit", gfc_match_exit, ST_EXIT)
+ match ("flush", gfc_match_flush, ST_FLUSH)
+ match ("forall", match_simple_forall, ST_FORALL)
+ match ("go to", gfc_match_goto, ST_GOTO)
+ match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
+ match ("inquire", gfc_match_inquire, ST_INQUIRE)
+ match ("nullify", gfc_match_nullify, ST_NULLIFY)
+ match ("open", gfc_match_open, ST_OPEN)
+ match ("pause", gfc_match_pause, ST_NONE)
+ match ("print", gfc_match_print, ST_WRITE)
+ match ("read", gfc_match_read, ST_READ)
+ match ("return", gfc_match_return, ST_RETURN)
+ match ("rewind", gfc_match_rewind, ST_REWIND)
+ match ("stop", gfc_match_stop, ST_STOP)
+ match ("where", match_simple_where, ST_WHERE)
+ match ("write", gfc_match_write, ST_WRITE)
+
+ /* 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)
+ if (gfc_error_check () == 0)
gfc_error ("Unclassifiable statement in IF-clause at %C");
gfc_free_expr (expr);
p = gfc_get_code ();
p->next = gfc_get_code ();
*p->next = new_st;
- p->next->loc = *gfc_current_locus ();
+ p->next->loc = gfc_current_locus;
p->expr = expr;
p->op = EXEC_IF;
/* 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)
gfc_st_label *label;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
label = NULL;
iter.var = iter.start = iter.end = iter.step = NULL;
if (gfc_match (" do") != MATCH_YES)
return MATCH_NO;
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
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;
/* See if we have a DO WHILE. */
}
/* 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_set_locus (&old_loc);
+ 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, 0); /* 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_syntax_error (ST_DO);
static match
match_exit_cycle (gfc_statement st, gfc_exec_op op)
{
- gfc_state_data *p;
+ gfc_state_data *p, *o;
gfc_symbol *sym;
match m;
}
}
- /* Find the loop mentioned specified by the label (or lack of a
- label). */
- for (p = gfc_state_stack; p; p = p->previous)
+ /* 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;
if (p == NULL)
{
return MATCH_ERROR;
}
+ if (o != NULL)
+ {
+ gfc_error ("%s statement at %C leaving OpenMP structured block",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+ else if (st == ST_EXIT
+ && p->previous != NULL
+ && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
+ && (p->previous->head->op == EXEC_OMP_DO
+ || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
+ {
+ gcc_assert (p->previous->head->next != NULL);
+ gcc_assert (p->previous->head->next->op == EXEC_DO
+ || p->previous->head->next->op == EXEC_DO_WHILE);
+ gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
+ return MATCH_ERROR;
+ }
+
/* Save the first statement in the loop - needed by the backend. */
new_st.ext.whichloop = p->head;
new_st.op = op;
-/* new_st.sym = sym;*/
return MATCH_YES;
}
match
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);
}
int stop_code;
gfc_expr *e;
match m;
+ int cnt;
- stop_code = 0;
+ stop_code = -1;
e = NULL;
if (gfc_match_eos () != MATCH_YES)
{
- m = gfc_match_small_literal_int (&stop_code);
+ m = gfc_match_small_literal_int (&stop_code, &cnt);
if (m == MATCH_ERROR)
- goto cleanup;
+ goto cleanup;
- if (m == MATCH_YES && stop_code > 99999)
- {
- gfc_error ("STOP code out of range at %C");
- goto cleanup;
- }
+ if (m == MATCH_YES && cnt > 5)
+ {
+ gfc_error ("Too many digits in STOP code at %C");
+ goto cleanup;
+ }
if (m == MATCH_NO)
- {
- /* Try a character constant. */
- m = gfc_match_expr (&e);
- if (m == MATCH_ERROR)
- goto cleanup;
- if (m == MATCH_NO)
- goto syntax;
- if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
- goto syntax;
- }
+ {
+ /* 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;
+ goto syntax;
}
if (gfc_pure (NULL))
{
gfc_error ("%s statement not allowed in PURE procedure at %C",
- gfc_ascii_statement (st));
+ gfc_ascii_statement (st));
goto cleanup;
}
return MATCH_ERROR;
}
+
/* Match the (deprecated) PAUSE statement. */
match
m = gfc_match_stopcode (ST_PAUSE);
if (m == MATCH_YES)
{
- if (gfc_notify_std (GFC_STD_F95_DEL,
- "Obsolete: PAUSE statement at %C")
+ if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
+ " at %C")
== FAILURE)
m = MATCH_ERROR;
}
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.label = label;
+ new_st.expr = expr;
+ return MATCH_YES;
+ }
}
return MATCH_NO;
}
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;
- expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
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;
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
/* 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;
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_impure_variable (tail->expr->symtree->n.sym))
{
gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
"PURE procedure");
goto cleanup;
}
+ if (tail->expr->ts.type == BT_DERIVED)
+ tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+
if (gfc_match_char (',') != MATCH_YES)
break;
if (stat != NULL)
{
+ bool is_variable;
+
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);
+ gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
+ "be INTENT(IN)", stat->symtree->n.sym->name);
goto cleanup;
}
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
{
- gfc_error
- ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
+ "for a PURE procedure");
+ goto cleanup;
+ }
+
+ is_variable = false;
+ if (stat->symtree->n.sym->attr.flavor == FL_VARIABLE)
+ is_variable = true;
+ else if (stat->symtree->n.sym->attr.function
+ && stat->symtree->n.sym->result == stat->symtree->n.sym
+ && (gfc_current_ns->proc_name == stat->symtree->n.sym
+ || (gfc_current_ns->parent
+ && gfc_current_ns->parent->proc_name
+ == stat->symtree->n.sym)))
+ is_variable = true;
+ else if (gfc_current_ns->entries
+ && stat->symtree->n.sym->result == stat->symtree->n.sym)
+ {
+ gfc_entry_list *el;
+ for (el = gfc_current_ns->entries; el; el = el->next)
+ if (el->sym == stat->symtree->n.sym)
+ {
+ is_variable = true;
+ }
+ }
+ else if (gfc_current_ns->parent && gfc_current_ns->parent->entries
+ && stat->symtree->n.sym->result == stat->symtree->n.sym)
+ {
+ gfc_entry_list *el;
+ for (el = gfc_current_ns->parent->entries; el; el = el->next)
+ if (el->sym == stat->symtree->n.sym)
+ {
+ is_variable = true;
+ }
+ }
+
+ if (!is_variable)
+ {
+ gfc_error ("STAT expression at %C must be a variable");
goto cleanup;
}
+
+ gfc_check_do_variable(stat->symtree);
}
if (gfc_match (" )%t") != MATCH_YES)
if (m == MATCH_NO)
goto syntax;
+ if (gfc_check_do_variable (p->symtree))
+ goto cleanup;
+
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
- gfc_error
- ("Illegal variable in NULLIFY at %C for a PURE procedure");
+ 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->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->expr = p;
tail->expr2 = e;
- if (gfc_match_char (')') == MATCH_YES)
+ if (gfc_match (" )%t") == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
gfc_syntax_error (ST_NULLIFY);
cleanup:
- gfc_free_statements (tail);
+ gfc_free_statements (new_st.next);
return MATCH_ERROR;
}
if (m == MATCH_NO)
goto syntax;
+ if (gfc_check_do_variable (tail->expr->symtree))
+ goto cleanup;
+
if (gfc_pure (NULL)
- && gfc_impure_variable (tail->expr->symtree->n.sym))
+ && gfc_impure_variable (tail->expr->symtree->n.sym))
{
- gfc_error
- ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
- "procedure");
+ gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
+ "for a PURE procedure");
goto cleanup;
}
break;
}
- if (stat != NULL && stat->symtree->n.sym->attr.intent == INTENT_IN)
+ if (stat != NULL)
{
- gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C cannot be "
- "INTENT(IN)", stat->symtree->n.sym->name);
- goto cleanup;
+ if (stat->symtree->n.sym->attr.intent == INTENT_IN)
+ {
+ gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
+ "cannot be INTENT(IN)", stat->symtree->n.sym->name);
+ goto cleanup;
+ }
+
+ if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
+ {
+ gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
+ "for a PURE procedure");
+ goto cleanup;
+ }
+
+ if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
+ {
+ gfc_error ("STAT expression at %C must be a variable");
+ goto cleanup;
+ }
+
+ gfc_check_do_variable(stat->symtree);
}
if (gfc_match (" )%t") != MATCH_YES)
{
gfc_expr *e;
match m;
+ gfc_compile_state s;
+ int c;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
goto cleanup;
}
- m = gfc_match ("% %e%t", &e);
+ 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 ();
+ if (ISALPHA (c) || ISDIGIT (c))
+ return MATCH_NO;
+ }
+
+ m = gfc_match (" %e%t", &e);
if (m == MATCH_YES)
goto done;
if (m == MATCH_ERROR)
return MATCH_ERROR;
done:
+ gfc_enclosing_unit (&s);
+ if (s == COMP_PROGRAM
+ && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
+ "main program at %C") == FAILURE)
+ return MATCH_ERROR;
+
new_st.op = EXEC_RETURN;
new_st.expr = e;
return MATCH_ERROR;
sym = st->n.sym;
- gfc_set_sym_referenced (sym);
+ /* If it does not seem to be callable... */
if (!sym->attr.generic
- && !sym->attr.subroutine
- && gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ && !sym->attr.subroutine)
+ {
+ 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) == 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)
{
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 ();
+ 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->expr->where = gfc_current_locus;
i = 0;
for (a = arglist; a; a = a->next)
}
-/* Match an IMPLICIT NONE statement. Actually, this statement is
- already matched in parse.c, or we would not end up here in the
- first place. So the only thing we need to check, is if there is
- trailing garbage. If not, the match is successful. */
+/* 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. */
-match
-gfc_match_implicit_none (void)
+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 (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+ return st->n.common;
}
-/* Match the letter range(s) of an IMPLICIT statement. */
+/* Match a common block name. */
-static match
-match_implicit_range (gfc_typespec * ts)
+match match_common_name (char *name)
{
- int c, c1, c2, inner;
- locus cur_loc;
-
- cur_loc = *gfc_current_locus ();
+ match m;
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if (c != '(')
+ if (gfc_match_char ('/') == MATCH_NO)
{
- gfc_error ("Missing character range in IMPLICIT at %C");
- goto bad;
+ name[0] = '\0';
+ return MATCH_YES;
}
- inner = 1;
- while (inner)
+ if (gfc_match_char ('/') == MATCH_YES)
{
- gfc_gobble_whitespace ();
- c1 = gfc_next_char ();
- if (!ISALPHA (c1))
- goto bad;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
-
- switch (c)
- {
- case ')':
- inner = 0; /* Fall through */
+ name[0] = '\0';
+ return MATCH_YES;
+ }
- case ',':
- c2 = c1;
- break;
+ m = gfc_match_name (name);
- case '-':
- gfc_gobble_whitespace ();
- c2 = gfc_next_char ();
- if (!ISALPHA (c2))
- goto bad;
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
+ return MATCH_YES;
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
+ gfc_error ("Syntax error in common block name at %C");
+ return MATCH_ERROR;
+}
- if ((c != ',') && (c != ')'))
- goto bad;
- if (c == ')')
- inner = 0;
- break;
-
- default:
- goto bad;
- }
-
- if (c1 > c2)
- {
- gfc_error ("Letters must be in alphabetic order in "
- "IMPLICIT statement at %C");
- goto bad;
- }
-
- /* See if we can add the newly matched range to the pending
- implicits from this IMPLICIT statement. We do not check for
- conflicts with whatever earlier IMPLICIT statements may have
- set. This is done when we've successfully finished matching
- the current one. */
- if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS)
- goto bad;
- }
-
- return MATCH_YES;
-
-bad:
- gfc_syntax_error (ST_IMPLICIT);
-
- gfc_set_locus (&cur_loc);
- return MATCH_ERROR;
-}
-
-
-/* Match an IMPLICIT statement, storing the types for
- gfc_set_implicit() if the statement is accepted by the parser.
- There is a strange looking, but legal syntactic construction
- possible. It looks like:
-
- IMPLICIT INTEGER (a-b) (c-d)
-
- This is legal if "a-b" is a constant expression that happens to
- equal one of the legal kinds for integers. The real problem
- happens with an implicit specification that looks like:
-
- IMPLICIT INTEGER (a-b)
-
- In this case, a typespec matcher that is "greedy" (as most of the
- matchers are) gobbles the character range as a kindspec, leaving
- nothing left. We therefore have to go a bit more slowly in the
- matching process by inhibiting the kindspec checking during
- typespec matching and checking for a kind later. */
-
-match
-gfc_match_implicit (void)
-{
- gfc_typespec ts;
- locus cur_loc;
- int c;
- match m;
-
- /* We don't allow empty implicit statements. */
- if (gfc_match_eos () == MATCH_YES)
- {
- gfc_error ("Empty IMPLICIT statement at %C");
- return MATCH_ERROR;
- }
-
- /* First cleanup. */
- gfc_clear_new_implicit ();
-
- do
- {
- /* A basic type is mandatory here. */
- m = gfc_match_type_spec (&ts, 0);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
-
- cur_loc = *gfc_current_locus ();
- m = match_implicit_range (&ts);
-
- if (m == MATCH_YES)
- {
- /* Looks like we have the <TYPE> (<RANGE>). */
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c == '\n') || (c == ','))
- continue;
-
- gfc_set_locus (&cur_loc);
- }
-
- /* Last chance -- check <TYPE> (<KIND>) (<RANGE>). */
- m = gfc_match_kind_spec (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- {
- m = gfc_match_old_kind_spec (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
- }
-
- m = match_implicit_range (&ts);
- if (m == MATCH_ERROR)
- goto error;
- if (m == MATCH_NO)
- goto syntax;
-
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c != '\n') && (c != ','))
- goto syntax;
-
- }
- while (c == ',');
-
- /* All we need to now is try to merge the new implicit types back
- into the existing types. This will fail if another implicit
- type is already defined for a letter. */
- return (gfc_merge_new_implicit () == SUCCESS) ?
- MATCH_YES : MATCH_ERROR;
-
-syntax:
- gfc_syntax_error (ST_IMPLICIT);
-
-error:
- return MATCH_ERROR;
-}
-
-
-/* Match a common block name. */
-
-static match
-match_common_name (gfc_symbol ** sym)
-{
- match m;
-
- if (gfc_match_char ('/') == MATCH_NO)
- return MATCH_NO;
-
- if (gfc_match_char ('/') == MATCH_YES)
- {
- *sym = NULL;
- return MATCH_YES;
- }
-
- m = gfc_match_symbol (sym, 0);
-
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
- return MATCH_YES;
-
- gfc_error ("Syntax error in common block name at %C");
- return MATCH_ERROR;
-}
-
-
-/* Match a COMMON statement. */
+/* Match a COMMON statement. */
match
gfc_match_common (void)
{
- gfc_symbol *sym, *common_name, **head, *tail, *old_blank_common;
+ 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;
+ 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;
}
- common_name = NULL;
as = NULL;
- if (gfc_match_eos () == MATCH_YES)
- goto syntax;
-
for (;;)
{
- m = match_common_name (&common_name);
+ m = match_common_name (name);
if (m == MATCH_ERROR)
goto cleanup;
- if (common_name == NULL)
- head = &gfc_current_ns->blank_common;
- else
+ 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)
{
- head = &common_name->common_head;
+ gsym->type = GSYM_COMMON;
+ gsym->where = gfc_current_locus;
+ gsym->defined = 1;
+ }
- if (!common_name->attr.common
- && gfc_add_common (&common_name->attr, NULL) == FAILURE)
- goto cleanup;
+ 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;
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 (sym->value != NULL
- && (common_name == NULL || !sym->attr.data))
+ if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
+ || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
- if (common_name == NULL)
- 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,
- common_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, NULL) == FAILURE)
+ 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. */
+ symbol name. */
m = gfc_match_array_spec (&as);
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 (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
+ 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);
+ 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_char () == '/')
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
+ gfc_gobble_whitespace ();
if (gfc_peek_char () == '/')
break;
}
return MATCH_YES;
syntax:
+ gfc_free_common_tree (gfc_current_ns->common_root);
+ gfc_current_ns->common_root = NULL;
gfc_syntax_error (ST_COMMON);
cleanup:
if (old_blank_common)
old_blank_common->common_next = NULL;
else
- gfc_current_ns->blank_common = NULL;
+ gfc_current_ns->blank_common.head = NULL;
gfc_free_array_spec (as);
return MATCH_ERROR;
}
return MATCH_YES;
}
- m = gfc_match (" %n%t", name);
+ m = gfc_match ("% %n%t", name);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
- if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
+ if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
/* 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)
+ return MATCH_ERROR;
+
if (group_name->attr.flavor != FL_NAMELIST
- && gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
+ && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
+ group_name->name, NULL) == FAILURE)
return MATCH_ERROR;
for (;;)
goto error;
if (sym->attr.in_namelist == 0
- && gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
+ && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
goto error;
- /* TODO: worry about PRIVATE members of a PUBLIC namelist
- group. */
+ /* 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 ();
+ }
+
+ if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
+ {
+ gfc_error ("Assumed character length '%s' in namelist '%s' at "
+ "%C is not allowed", sym->name, group_name->name);
+ gfc_error_check ();
+ }
nl = gfc_get_namelist ();
nl->sym = sym;
+ sym->refs++;
if (group_name->namelist == NULL)
group_name->namelist = group_name->namelist_tail = nl;
if (m != MATCH_YES)
return m;
- if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
+ if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
+ gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
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);
}
{
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;
goto syntax;
set = eq;
+ common_flag = FALSE;
+ cnt = 0;
for (;;)
{
- m = gfc_match_variable (&set->expr, 1);
+ 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");
+ 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 = set->eq;
}
- if (gfc_match_eos () == MATCH_YES)
- break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
- }
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_EQUIVALENCE);
-
-cleanup:
- eq = tail->next;
- tail->next = NULL;
-
- gfc_free_equiv (gfc_current_ns->equiv);
- gfc_current_ns->equiv = eq;
-
- return MATCH_ERROR;
-}
-
-
-/* Match a statement function declaration. It is so easy to match
- non-statement function statements with a MATCH_ERROR as opposed to
- MATCH_NO that we suppress error message in most cases. */
-
-match
-gfc_match_st_function (void)
-{
- gfc_error_buf old_error;
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
-
- m = gfc_match_symbol (&sym, 0);
- if (m != MATCH_YES)
- return m;
-
- gfc_push_error (&old_error);
-
- if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
- goto undo_error;
-
- if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
- goto undo_error;
-
- m = gfc_match (" = %e%t", &expr);
- if (m == MATCH_NO)
- goto undo_error;
- if (m == MATCH_ERROR)
- return m;
-
- sym->value = expr;
-
- return MATCH_YES;
-
-undo_error:
- gfc_pop_error (&old_error);
- return MATCH_NO;
-}
-
-
-/********************* DATA statement subroutines *********************/
-
-/* Free a gfc_data_variable structure and everything beneath it. */
-
-static void
-free_variable (gfc_data_variable * p)
-{
- gfc_data_variable *q;
-
- for (; p; p = q)
- {
- q = p->next;
- gfc_free_expr (p->expr);
- gfc_free_iterator (&p->iter, 0);
- free_variable (p->list);
-
- gfc_free (p);
- }
-}
-
-
-/* Free a gfc_data_value structure and everything beneath it. */
-
-static void
-free_value (gfc_data_value * p)
-{
- gfc_data_value *q;
-
- for (; p; p = q)
- {
- q = p->next;
- gfc_free_expr (p->expr);
- gfc_free (p);
- }
-}
-
-
-/* Free a list of gfc_data structures. */
-
-void
-gfc_free_data (gfc_data * p)
-{
- gfc_data *q;
-
- for (; p; p = q)
- {
- q = p->next;
-
- free_variable (p->var);
- free_value (p->value);
-
- gfc_free (p);
- }
-}
-
-
-static match var_element (gfc_data_variable *);
-
-/* Match a list of variables terminated by an iterator and a right
- parenthesis. */
-
-static match
-var_list (gfc_data_variable * parent)
-{
- gfc_data_variable *tail, var;
- match m;
-
- m = var_element (&var);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- goto syntax;
-
- tail = gfc_get_data_variable ();
- *tail = var;
-
- parent->list = tail;
-
- for (;;)
- {
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
-
- m = gfc_match_iterator (&parent->iter, 1);
- if (m == MATCH_YES)
- break;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- m = var_element (&var);
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- if (m == MATCH_NO)
- goto syntax;
-
- tail->next = gfc_get_data_variable ();
- tail = tail->next;
-
- *tail = var;
- }
-
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
-}
-
-
-/* Match a single element in a data variable list, which can be a
- variable-iterator list. */
-
-static match
-var_element (gfc_data_variable * new)
-{
- match m;
- gfc_symbol *sym, *t;
-
- memset (new, '\0', sizeof (gfc_data_variable));
-
- if (gfc_match_char ('(') == MATCH_YES)
- return var_list (new);
-
- m = gfc_match_variable (&new->expr, 0);
- if (m != MATCH_YES)
- return m;
-
- sym = new->expr->symtree->n.sym;
-
- if(sym->value != NULL)
- {
- gfc_error ("Variable '%s' at %C already has an initialization",
- sym->name);
- return MATCH_ERROR;
- }
-
- if (sym->attr.in_common)
- /* See if sym is in the blank common block. */
- for (t = sym->ns->blank_common; t; t = t->common_next)
- if (sym == t)
+ if (cnt < 2)
{
- gfc_error ("DATA statement at %C may not initialize variable "
- "'%s' from blank COMMON", sym->name);
- return MATCH_ERROR;
+ gfc_error ("EQUIVALENCE at %C requires two or more objects");
+ goto cleanup;
}
- sym->attr.data = 1;
-
- return MATCH_YES;
-}
-
-
-/* Match the top-level list of data variables. */
-
-static match
-top_var_list (gfc_data * d)
-{
- gfc_data_variable var, *tail, *new;
- match m;
-
- tail = NULL;
-
- for (;;)
- {
- m = var_element (&var);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- new = gfc_get_data_variable ();
- *new = var;
-
- if (tail == NULL)
- d->var = new;
- else
- tail->next = new;
-
- tail = new;
+ /* If 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_char ('/') == MATCH_YES)
+ if (gfc_match_eos () == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
return MATCH_YES;
syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
-}
-
-
-static match
-match_data_constant (gfc_expr ** result)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_symbol *sym;
- gfc_expr *expr;
- match m;
-
- m = gfc_match_literal_constant (&expr, 1);
- if (m == MATCH_YES)
- {
- *result = expr;
- return MATCH_YES;
- }
-
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
-
- m = gfc_match_null (result);
- if (m != MATCH_NO)
- return m;
-
- m = gfc_match_name (name);
- if (m != MATCH_YES)
- return m;
-
- if (gfc_find_symbol (name, NULL, 1, &sym))
- return MATCH_ERROR;
+ gfc_syntax_error (ST_EQUIVALENCE);
- if (sym == NULL
- || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
- {
- gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
- name);
- return MATCH_ERROR;
- }
- else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result);
+cleanup:
+ eq = tail->next;
+ tail->next = NULL;
- *result = gfc_copy_expr (sym->value);
- return MATCH_YES;
+ gfc_free_equiv (gfc_current_ns->equiv);
+ gfc_current_ns->equiv = eq;
+
+ return MATCH_ERROR;
}
-/* Match a list of values in a DATA statement. The leading '/' has
- already been seen at this point. */
+/* 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 match
-top_val_list (gfc_data * data)
+static bool
+check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
{
- gfc_data_value *new, *tail;
- gfc_expr *expr;
- const char *msg;
- match m;
- tail = NULL;
+ if (e == NULL)
+ return false;
- for (;;)
+ switch (e->expr_type)
{
- m = match_data_constant (&expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
+ case EXPR_FUNCTION:
+ if (e->symtree == NULL)
+ return false;
- new = gfc_get_data_value ();
+ /* Check the name before testing for nested recursion! */
+ if (sym->name == e->symtree->n.sym->name)
+ return true;
- if (tail == NULL)
- data->value = new;
- else
- tail->next = new;
+ /* 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;
- tail = new;
+ if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ gfc_set_default_type (e->symtree->n.sym, 0, NULL);
- if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
- {
- tail->expr = expr;
- tail->repeat = 1;
- }
- else
- {
- msg = gfc_extract_int (expr, &tail->repeat);
- gfc_free_expr (expr);
- if (msg != NULL)
- {
- gfc_error (msg);
- return MATCH_ERROR;
- }
+ break;
- m = match_data_constant (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- return MATCH_ERROR;
- }
+ case EXPR_VARIABLE:
+ if (e->symtree && sym->name == e->symtree->n.sym->name)
+ return true;
- if (gfc_match_char ('/') == MATCH_YES)
- break;
- if (gfc_match_char (',') == MATCH_NO)
- goto syntax;
+ if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
+ gfc_set_default_type (e->symtree->n.sym, 0, NULL);
+ break;
+
+ default:
+ break;
}
- return MATCH_YES;
+ return false;
+}
-syntax:
- gfc_syntax_error (ST_DATA);
- return MATCH_ERROR;
+
+static bool
+recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
+{
+ return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
}
-/* Match a DATA statement. */
+/* 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_data (void)
+gfc_match_st_function (void)
{
- gfc_data *new;
+ gfc_error_buf old_error;
+ gfc_symbol *sym;
+ gfc_expr *expr;
match m;
- for (;;)
- {
- new = gfc_get_data ();
- new->where = *gfc_current_locus ();
+ m = gfc_match_symbol (&sym, 0);
+ if (m != MATCH_YES)
+ return m;
- m = top_var_list (new);
- if (m != MATCH_YES)
- goto cleanup;
+ gfc_push_error (&old_error);
- m = top_val_list (new);
- if (m != MATCH_YES)
- goto cleanup;
+ if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
+ sym->name, NULL) == FAILURE)
+ goto undo_error;
- new->next = gfc_current_ns->data;
- gfc_current_ns->data = new;
+ if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
+ goto undo_error;
- if (gfc_match_eos () == MATCH_YES)
- break;
+ m = gfc_match (" = %e%t", &expr);
+ if (m == MATCH_NO)
+ goto undo_error;
- gfc_match_char (','); /* Optional comma */
- }
+ gfc_free_error (&old_error);
+ if (m == MATCH_ERROR)
+ return m;
- if (gfc_pure (NULL))
+ if (recursive_stmt_fcn (expr, sym))
{
- gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
+ gfc_error ("Statement function at %L is recursive", &expr->where);
return MATCH_ERROR;
}
+ sym->value = expr;
+
return MATCH_YES;
-cleanup:
- gfc_free_data (new);
- return MATCH_ERROR;
+undo_error:
+ gfc_pop_error (&old_error);
+ return MATCH_NO;
}
/* 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;
c = gfc_get_case ();
- c->where = *gfc_current_locus ();
+ c->where = gfc_current_locus;
if (gfc_match_char (':') == MATCH_YES)
{
- m = gfc_match_expr (&c->high);
+ m = gfc_match_init_expr (&c->high);
if (m == MATCH_NO)
goto need_expr;
if (m == MATCH_ERROR)
goto cleanup;
}
-
else
{
- m = gfc_match_expr (&c->low);
+ 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. */
+ target. Else get the upper bound for the case range. */
if (gfc_match_char (':') != MATCH_YES)
c->high = c->low;
else
{
- m = gfc_match_expr (&c->high);
+ m = gfc_match_init_expr (&c->high);
if (m == MATCH_ERROR)
goto cleanup;
/* MATCH_NO is fine. It's OK if nothing is there! */
return MATCH_YES;
need_expr:
- gfc_error ("Expected expression in CASE at %C");
+ gfc_error ("Expected initialization expression in CASE at %C");
cleanup:
free_case (c);
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 ())
+ {
+ gfc_error ("Expected the name of the SELECT CASE construct at %C");
+ return MATCH_ERROR;
+ }
+
gfc_gobble_whitespace ();
m = gfc_match_name (name);
new_st.op = EXEC_SELECT;
c = gfc_get_case ();
- c->where = *gfc_current_locus ();
+ c->where = gfc_current_locus;
new_st.ext.case_list = c;
return MATCH_YES;
}
/********************* 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->expr = expr;
+ c->next = gfc_get_code ();
+
+ *c->next = new_st;
+ gfc_clear_new_st ();
+
+ new_st.op = EXEC_WHERE;
+ new_st.block = c;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_WHERE);
+
+cleanup:
+ gfc_free_expr (expr);
+ return MATCH_ERROR;
+}
+
+
/* Match 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;
return MATCH_YES;
}
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;
/* 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 ();
+ where = gfc_current_locus;
iter = gfc_getmem (sizeof (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 = gfc_match_expr (&iter->start);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
+ if (m != MATCH_YES)
goto cleanup;
if (gfc_match_char (':') != MATCH_YES)
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;
m = MATCH_ERROR;
cleanup:
- gfc_set_locus (&where);
+
+ gfc_current_locus = where;
gfc_free_forall_iterator (iter);
return m;
}
-/* Match a FORALL statement. */
+/* Match the header of a FORALL statement. */
-match
-gfc_match_forall (gfc_statement * st)
+static match
+match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
{
gfc_forall_iterator *head, *tail, *new;
- gfc_expr *mask;
- gfc_code *c;
- match m0, m;
+ gfc_expr *msk;
+ match m;
- head = tail = NULL;
- mask = NULL;
- c = NULL;
+ gfc_gobble_whitespace ();
- m0 = gfc_match_label ();
- if (m0 == MATCH_ERROR)
- return MATCH_ERROR;
+ head = tail = NULL;
+ msk = NULL;
- m = gfc_match (" forall (");
- if (m != MATCH_YES)
- return m;
+ if (gfc_match_char ('(') != MATCH_YES)
+ return MATCH_NO;
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
goto cleanup;
+
if (m == MATCH_YES)
{
tail->next = new;
}
/* Have to have a mask expression. */
- m = gfc_match_expr (&mask);
+
+ m = gfc_match_expr (&msk);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
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.expr = mask;
+ new_st.ext.forall_iterator = head;
+ new_st.block = gfc_get_code ();
+
+ new_st.block->op = EXEC_FORALL;
+ new_st.block->next = c;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORALL);
+
+cleanup:
+ gfc_free_forall_iterator (head);
+ gfc_free_expr (mask);
+
+ return MATCH_ERROR;
+}
+
+
+/* Match 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.expr = mask;
new_st.ext.forall_iterator = head;
-
return MATCH_YES;
}
c = gfc_get_code ();
*c = new_st;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
+ c->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_FORALL;
new_st.expr = mask;
new_st.ext.forall_iterator = head;
new_st.block = gfc_get_code ();
-
new_st.block->op = EXEC_FORALL;
new_st.block->next = c;
OSDN Git Service
