X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Fmatch.c;h=f21748c1b9ae4cdd395a9a1a4b5fd952209c00c6;hp=6c7251f05c0314aea9285f0d2004f2bb8024e52a;hb=922715fd70a4c052eeb69eff2a0a02b49610a2cf;hpb=6cbc841e3b888760aa462440bbb50dde2d2d6841
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 6c7251f05c0..f21748c1b9a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1,13 +1,13 @@
/* 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
@@ -16,58 +16,206 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file 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
+. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include
-#include
-
#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. */
@@ -80,12 +228,12 @@ gfc_match_space (void)
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;
}
@@ -109,7 +257,7 @@ gfc_match_eos (void)
for (;;)
{
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
c = gfc_next_char ();
@@ -122,7 +270,7 @@ gfc_match_eos (void)
}
while (c != '\n');
- /* Fall through */
+ /* Fall through. */
case '\n':
return MATCH_YES;
@@ -135,44 +283,49 @@ gfc_match_eos (void)
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)
{
@@ -181,9 +334,11 @@ gfc_match_small_literal_int (int *value)
}
}
- gfc_set_locus (&old_loc);
+ gfc_current_locus = old_loc;
*value = i;
+ if (cnt)
+ *cnt = j;
return MATCH_YES;
}
@@ -217,30 +372,72 @@ gfc_match_small_int (int *value)
}
+/* 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;
}
@@ -254,7 +451,6 @@ match
gfc_match_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_state_data *p;
match m;
gfc_new_block = NULL;
@@ -269,147 +465,155 @@ gfc_match_label (void)
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;
}
@@ -419,7 +623,7 @@ gfc_match_name (char *buffer)
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;
@@ -430,7 +634,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
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;
@@ -440,7 +644,7 @@ gfc_match_sym_tree (gfc_symtree ** matched_symbol, int host_assoc)
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;
@@ -450,61 +654,272 @@ gfc_match_symbol (gfc_symbol ** matched_symbol, int host_assoc)
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;
- = , [, ]
+ 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:
+
+ = , [, ]
+
+ 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 ('=');
@@ -523,11 +938,7 @@ gfc_match_iterator (gfc_iterator * iter, int init_flag)
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)
@@ -586,13 +997,13 @@ gfc_match_char (char c)
{
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;
}
@@ -624,7 +1035,7 @@ gfc_match (const char *target, ...)
void **vp;
const char *p;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
va_start (argp, target);
m = MATCH_NO;
matches = 0;
@@ -695,7 +1106,7 @@ loop:
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;
@@ -732,7 +1143,7 @@ loop:
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);
@@ -750,7 +1161,7 @@ not_yes:
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;
@@ -762,14 +1173,14 @@ not_yes:
{
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':
@@ -791,7 +1202,7 @@ not_yes:
/*********************** 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)
@@ -799,10 +1210,6 @@ 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)
@@ -814,7 +1221,7 @@ gfc_match_program (void)
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;
@@ -832,16 +1239,35 @@ gfc_match_assignment (void)
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);
@@ -849,13 +1275,9 @@ gfc_match_assignment (void)
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;
}
@@ -868,7 +1290,7 @@ gfc_match_pointer_assignment (void)
locus old_loc;
match m;
- old_loc = *gfc_current_locus ();
+ old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
@@ -883,6 +1305,14 @@ gfc_match_pointer_assignment (void)
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;
@@ -890,13 +1320,51 @@ gfc_match_pointer_assignment (void)
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.
@@ -907,12 +1375,15 @@ cleanup:
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;
@@ -920,12 +1391,20 @@ gfc_match_if (gfc_statement * if_type)
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");
@@ -939,10 +1418,8 @@ gfc_match_if (gfc_statement * if_type)
{
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;
}
@@ -951,10 +1428,13 @@ gfc_match_if (gfc_statement * if_type)
|| 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;
@@ -966,19 +1446,17 @@ gfc_match_if (gfc_statement * if_type)
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;
}
@@ -996,9 +1474,15 @@ gfc_match_if (gfc_statement * if_type)
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)
@@ -1006,9 +1490,9 @@ gfc_match_if (gfc_statement * if_type)
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
@@ -1020,31 +1504,47 @@ gfc_match_if (gfc_statement * if_type)
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);
@@ -1066,7 +1566,7 @@ got_match:
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;
@@ -1156,7 +1656,7 @@ 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)
@@ -1182,7 +1682,7 @@ gfc_match_do (void)
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;
@@ -1194,11 +1694,11 @@ gfc_match_do (void)
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)
{
@@ -1207,9 +1707,8 @@ gfc_match_do (void)
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. */
@@ -1220,15 +1719,15 @@ gfc_match_do (void)
}
/* 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)
@@ -1236,6 +1735,9 @@ gfc_match_do (void)
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);
@@ -1273,7 +1775,7 @@ cleanup:
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;
@@ -1298,11 +1800,12 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
}
}
- /* 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)
{
@@ -1316,11 +1819,29 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
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;
}
@@ -1331,7 +1852,6 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
match
gfc_match_exit (void)
{
-
return match_exit_cycle (ST_EXIT, EXEC_EXIT);
}
@@ -1341,7 +1861,6 @@ gfc_match_exit (void)
match
gfc_match_cycle (void)
{
-
return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
}
@@ -1354,42 +1873,43 @@ gfc_match_stopcode (gfc_statement st)
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;
}
@@ -1408,6 +1928,7 @@ cleanup:
return MATCH_ERROR;
}
+
/* Match the (deprecated) PAUSE statement. */
match
@@ -1418,8 +1939,8 @@ gfc_match_pause (void)
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;
}
@@ -1441,7 +1962,6 @@ gfc_match_stop (void)
match
gfc_match_continue (void)
{
-
if (gfc_match_eos () != MATCH_YES)
{
gfc_syntax_error (ST_CONTINUE);
@@ -1464,21 +1984,21 @@ gfc_match_assign (void)
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;
}
@@ -1513,12 +2033,11 @@ gfc_match_goto (void)
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;
@@ -1536,7 +2055,7 @@ gfc_match_goto (void)
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
@@ -1561,8 +2080,7 @@ gfc_match_goto (void)
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;
@@ -1582,7 +2100,7 @@ gfc_match_goto (void)
do
{
- m = gfc_match_st_label (&label, 0);
+ m = gfc_match_st_label (&label);
if (m != MATCH_YES)
goto syntax;
@@ -1648,7 +2166,7 @@ cleanup:
/* 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;
@@ -1692,14 +2210,20 @@ gfc_match_allocate (void)
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;
@@ -1712,21 +2236,60 @@ gfc_match_allocate (void)
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)
@@ -1771,20 +2334,22 @@ gfc_match_nullify (void)
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
@@ -1797,7 +2362,7 @@ gfc_match_nullify (void)
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;
@@ -1809,7 +2374,7 @@ syntax:
gfc_syntax_error (ST_NULLIFY);
cleanup:
- gfc_free_statements (tail);
+ gfc_free_statements (new_st.next);
return MATCH_ERROR;
}
@@ -1845,12 +2410,14 @@ gfc_match_deallocate (void)
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;
}
@@ -1864,11 +2431,29 @@ gfc_match_deallocate (void)
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)
@@ -1897,6 +2482,8 @@ gfc_match_return (void)
{
gfc_expr *e;
match m;
+ gfc_compile_state s;
+ int c;
e = NULL;
if (gfc_match_eos () == MATCH_YES)
@@ -1909,7 +2496,18 @@ gfc_match_return (void)
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)
@@ -1922,6 +2520,12 @@ cleanup:
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;
@@ -1960,12 +2564,28 @@ gfc_match_call (void)
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)
{
@@ -1995,18 +2615,18 @@ gfc_match_call (void)
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)
@@ -2048,270 +2668,131 @@ cleanup:
}
-/* 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 (). */
- gfc_gobble_whitespace ();
- c = gfc_next_char ();
- if ((c == '\n') || (c == ','))
- continue;
-
- gfc_set_locus (&cur_loc);
- }
-
- /* Last chance -- check () (). */
- 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;
@@ -2331,6 +2812,35 @@ gfc_match_common (void)
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",
@@ -2338,31 +2848,19 @@ gfc_match_common (void)
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
@@ -2371,7 +2869,7 @@ gfc_match_common (void)
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;
@@ -2380,33 +2878,70 @@ gfc_match_common (void)
{
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;
}
@@ -2416,13 +2951,15 @@ done:
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;
}
@@ -2443,14 +2980,14 @@ gfc_match_block_data (void)
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;
@@ -2462,7 +2999,7 @@ gfc_match_block_data (void)
/* Free a namelist structure. */
void
-gfc_free_namelist (gfc_namelist * name)
+gfc_free_namelist (gfc_namelist *name)
{
gfc_namelist *n;
@@ -2493,14 +3030,23 @@ gfc_match_namelist (void)
{
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 (;;)
@@ -2512,14 +3058,28 @@ gfc_match_namelist (void)
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;
@@ -2571,7 +3131,8 @@ gfc_match_module (void)
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;
@@ -2582,15 +3143,13 @@ gfc_match_module (void)
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);
}
@@ -2603,7 +3162,11 @@ gfc_match_equivalence (void)
{
gfc_equiv *eq, *set, *tail;
gfc_ref *ref;
+ gfc_symbol *sym;
match m;
+ gfc_common_head *common_head = NULL;
+ bool common_flag;
+ int cnt;
tail = NULL;
@@ -2620,26 +3183,49 @@ gfc_match_equivalence (void)
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;
@@ -2647,251 +3233,32 @@ gfc_match_equivalence (void)
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;
@@ -2900,162 +3267,125 @@ top_var_list (gfc_data * d)
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;
}
@@ -3064,7 +3394,7 @@ cleanup:
/* 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;
@@ -3077,7 +3407,7 @@ free_case (gfc_case * p)
/* Free a list of case structures. */
void
-gfc_free_case_list (gfc_case * p)
+gfc_free_case_list (gfc_case *p)
{
gfc_case *q;
@@ -3092,38 +3422,37 @@ gfc_free_case_list (gfc_case * p)
/* 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! */
@@ -3134,7 +3463,7 @@ match_case_selector (gfc_case ** cp)
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);
@@ -3153,6 +3482,14 @@ match_case_eos (void)
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);
@@ -3219,7 +3556,7 @@ gfc_match_case (void)
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;
}
@@ -3266,10 +3603,56 @@ cleanup:
/********************* 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;
@@ -3286,7 +3669,6 @@ gfc_match_where (gfc_statement * st)
if (gfc_match_eos () == MATCH_YES)
{
*st = ST_WHERE_BLOCK;
-
new_st.op = EXEC_WHERE;
new_st.expr = expr;
return MATCH_YES;
@@ -3351,7 +3733,14 @@ gfc_match_elsewhere (void)
}
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;
@@ -3387,19 +3776,17 @@ cleanup:
/* 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;
}
@@ -3408,32 +3795,34 @@ gfc_free_forall_iterator (gfc_forall_iterator * iter)
/* Match an iterator as part of a FORALL statement. The format is:
- = :[:][, ] */
+ = :[:]
+
+ 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)
@@ -3456,6 +3845,9 @@ match_forall_iterator (gfc_forall_iterator ** result)
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;
@@ -3464,33 +3856,29 @@ syntax:
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)
@@ -3508,6 +3896,7 @@ gfc_match_forall (gfc_statement * st)
m = match_forall_iterator (&new);
if (m == MATCH_ERROR)
goto cleanup;
+
if (m == MATCH_YES)
{
tail->next = new;
@@ -3516,7 +3905,8 @@ gfc_match_forall (gfc_statement * st)
}
/* 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)
@@ -3528,14 +3918,118 @@ gfc_match_forall (gfc_statement * st)
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;
}
@@ -3553,16 +4047,13 @@ gfc_match_forall (gfc_statement * st)
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;