/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include <setjmp.h>
#include "match.h"
#include "parse.h"
-/* Current statement label. Zero means no statement label. Because
- new_st can get wiped during statement matching, we have to keep it
- separate. */
+/* Current statement label. Zero means no statement label. Because new_st
+ can get wiped during statement matching, we have to keep it separate. */
gfc_st_label *gfc_statement_label;
gfc_match_eos(). */
static match
-match_word (const char *str, match (*subr) (void), locus * old_locus)
+match_word (const char *str, match (*subr) (void), locus *old_locus)
{
match m;
ambiguity. */
#define match(keyword, subr, st) \
- do { \
+ do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
+ return st; \
else \
- undo_new_statement (); \
+ undo_new_statement (); \
} while (0);
static gfc_statement
match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
+ match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
/* Try to match a subroutine statement, which has the same optional
prefixes that functions can have. */
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
match ("else if", gfc_match_elseif, ST_ELSEIF);
+ match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
if (gfc_match_end (&st) == MATCH_YES)
return st;
match ("inquire", gfc_match_inquire, ST_INQUIRE);
match ("implicit", gfc_match_implicit, ST_IMPLICIT);
match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
+ match ("import", gfc_match_import, ST_IMPORT);
match ("interface", gfc_match_interface, ST_INTERFACE);
match ("intent", gfc_match_intent, ST_ATTR_DECL);
match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
match ("program", gfc_match_program, ST_PROGRAM);
if (gfc_match_public (&st) == MATCH_YES)
return st;
+ match ("protected", gfc_match_protected, ST_ATTR_DECL);
break;
case 'r':
break;
case 'u':
- match ("use% ", gfc_match_use, ST_USE);
+ match ("use", gfc_match_use, ST_USE);
+ break;
+
+ case 'v':
+ match ("value", gfc_match_value, ST_ATTR_DECL);
+ match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
break;
case 'w':
return ST_NONE;
}
+static gfc_statement
+decode_omp_directive (void)
+{
+ locus old_locus;
+ int c;
+
+#ifdef GFC_DEBUG
+ gfc_symbol_state ();
+#endif
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error_now ("OpenMP directives at %C may not appear in PURE "
+ "or ELEMENTAL procedures");
+ gfc_error_recovery ();
+ return ST_NONE;
+ }
+
+ old_locus = gfc_current_locus;
+
+ /* General OpenMP directive matching: Instead of testing every possible
+ statement, we eliminate most possibilities by peeking at the
+ first character. */
+
+ c = gfc_peek_char ();
+
+ switch (c)
+ {
+ case 'a':
+ match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+ break;
+ case 'b':
+ match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+ break;
+ case 'c':
+ match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+ break;
+ case 'd':
+ match ("do", gfc_match_omp_do, ST_OMP_DO);
+ break;
+ case 'e':
+ match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+ match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+ match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+ match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+ match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+ match ("end parallel sections", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_SECTIONS);
+ match ("end parallel workshare", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_WORKSHARE);
+ match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+ match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+ match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ match ("end workshare", gfc_match_omp_end_nowait,
+ ST_OMP_END_WORKSHARE);
+ break;
+ case 'f':
+ match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+ break;
+ case 'm':
+ match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+ break;
+ case 'o':
+ match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+ break;
+ case 'p':
+ match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+ match ("parallel sections", gfc_match_omp_parallel_sections,
+ ST_OMP_PARALLEL_SECTIONS);
+ match ("parallel workshare", gfc_match_omp_parallel_workshare,
+ ST_OMP_PARALLEL_WORKSHARE);
+ match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
+ break;
+ case 's':
+ match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+ match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+ match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
+ break;
+ case 't':
+ match ("threadprivate", gfc_match_omp_threadprivate,
+ ST_OMP_THREADPRIVATE);
+ case 'w':
+ match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+ break;
+ }
+
+ /* All else has failed, so give up. See if any of the matchers has
+ stored an error message of some sort. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable OpenMP directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
#undef match
next_free (void)
{
match m;
- int c, d;
+ int c, d, cnt, at_bol;
+ at_bol = gfc_at_bol ();
gfc_gobble_whitespace ();
c = gfc_peek_char ();
if (ISDIGIT (c))
{
/* Found a statement label? */
- m = gfc_match_st_label (&gfc_statement_label, 0);
+ m = gfc_match_st_label (&gfc_statement_label);
d = gfc_peek_char ();
if (m != MATCH_YES || !gfc_is_whitespace (d))
{
+ gfc_match_small_literal_int (&c, &cnt);
+
+ if (cnt > 5)
+ gfc_error_now ("Too many digits in statement label at %C");
+
+ if (c == 0)
+ gfc_error_now ("Zero is not a valid statement label at %C");
+
do
- {
- /* Skip the bad statement label. */
- gfc_warning_now ("Ignoring bad statement label at %C");
- c = gfc_next_char ();
- }
- while (ISDIGIT (c));
+ c = gfc_next_char ();
+ while (ISDIGIT(c));
+
+ if (!gfc_is_whitespace (c))
+ gfc_error_now ("Non-numeric character in statement label at %C");
+
+ return ST_NONE;
}
else
{
label_locus = gfc_current_locus;
- if (gfc_statement_label->value == 0)
+ gfc_gobble_whitespace ();
+
+ if (at_bol && gfc_peek_char () == ';')
{
- gfc_warning_now ("Ignoring statement label of zero at %C");
- gfc_free_st_label (gfc_statement_label);
- gfc_statement_label = NULL;
+ gfc_error_now ("Semicolon at %C needs to be preceded by "
+ "statement");
+ gfc_next_char (); /* Eat up the semicolon. */
+ return ST_NONE;
}
- gfc_gobble_whitespace ();
-
if (gfc_match_eos () == MATCH_YES)
{
- gfc_warning_now
- ("Ignoring statement label in empty statement at %C");
+ gfc_warning_now ("Ignoring statement label in empty statement "
+ "at %C");
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
}
}
}
+ else if (c == '!')
+ {
+ /* Comments have already been skipped by the time we get here,
+ except for OpenMP directives. */
+ if (gfc_option.flag_openmp)
+ {
+ int i;
+
+ c = gfc_next_char ();
+ for (i = 0; i < 5; i++, c = gfc_next_char ())
+ gcc_assert (c == "!$omp"[i]);
+
+ gcc_assert (c == ' ');
+ gfc_gobble_whitespace ();
+ return decode_omp_directive ();
+ }
+ }
+
+ if (at_bol && c == ';')
+ {
+ gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ gfc_next_char (); /* Eat up the semicolon. */
+ return ST_NONE;
+ }
return decode_statement ();
}
digit_flag = 1;
break;
- /* Comments have already been skipped by the time we get
+ /* Comments have already been skipped by the time we get
+ here, except for OpenMP directives. */
+ case '*':
+ if (gfc_option.flag_openmp)
+ {
+ for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
+ gcc_assert (TOLOWER (c) == "*$omp"[i]);
+
+ if (c != ' ' && c != '0')
+ {
+ gfc_buffer_error (0);
+ gfc_error ("Bad continuation line at %C");
+ return ST_NONE;
+ }
+
+ return decode_omp_directive ();
+ }
+ /* FALLTHROUGH */
+
+ /* Comments have already been skipped by the time we get
here so don't bother checking for them. */
default:
if (c == '\n')
goto blank_line;
- if (c != ' ' && c!= '0')
+ if (c != ' ' && c != '0')
{
gfc_buffer_error (0);
gfc_error ("Bad continuation line at %C");
goto blank_line;
gfc_current_locus = loc;
+ if (c == ';')
+ {
+ gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ return ST_NONE;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto blank_line;
blank_line:
if (digit_flag)
- gfc_warning ("Statement label in blank line will be " "ignored at %C");
+ gfc_warning ("Ignoring statement label in empty statement at %C");
gfc_advance_line ();
return ST_NONE;
}
if (gfc_at_eol ())
{
if (gfc_option.warn_line_truncation
+ && gfc_current_locus.lb
&& gfc_current_locus.lb->truncated)
gfc_warning_now ("Line truncated at %C");
break;
}
- st =
- (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
+ st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE)
break;
case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
- case ST_LABEL_ASSIGNMENT: case ST_FLUSH
+ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
+ case ST_OMP_BARRIER
/* Statements that mark other executable statements. */
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
- case ST_WHERE_BLOCK: case ST_SELECT_CASE
+ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
+ case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
+ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
+ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
/* Declaration statements */
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
- case ST_TYPE: case ST_INTERFACE
+ case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
- case ST_END_PROGRAM: case ST_END_SUBROUTINE
+ case ST_END_PROGRAM: case ST_END_SUBROUTINE
/* Push a new state onto the stack. */
static void
-push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
+push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
{
-
p->state = new_state;
p->previous = gfc_state_stack;
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
-
gfc_state_stack = p;
}
static void
pop_state (void)
{
-
gfc_state_stack = gfc_state_stack->previous;
}
/* Starts a new level in the statement list. */
static gfc_code *
-new_level (gfc_code * q)
+new_level (gfc_code *q)
{
gfc_code *p;
break;
/* Statement labels are not restricted from appearing on a
- particular line. However, there are plenty of situations
- where the resulting label can't be referenced. */
+ particular line. However, there are plenty of situations
+ where the resulting label can't be referenced. */
default:
type = ST_LABEL_BAD_TARGET;
case ST_IMPLIED_ENDDO:
p = _("implied END DO");
break;
+ case ST_IMPORT:
+ p = "IMPORT";
+ break;
case ST_INQUIRE:
p = "INQUIRE";
break;
case ST_LABEL_ASSIGNMENT:
p = "LABEL ASSIGNMENT";
break;
+ case ST_ENUM:
+ p = "ENUM DEFINITION";
+ break;
+ case ST_ENUMERATOR:
+ p = "ENUMERATOR DEFINITION";
+ break;
+ case ST_END_ENUM:
+ p = "END ENUM";
+ break;
+ case ST_OMP_ATOMIC:
+ p = "!$OMP ATOMIC";
+ break;
+ case ST_OMP_BARRIER:
+ p = "!$OMP BARRIER";
+ break;
+ case ST_OMP_CRITICAL:
+ p = "!$OMP CRITICAL";
+ break;
+ case ST_OMP_DO:
+ p = "!$OMP DO";
+ break;
+ case ST_OMP_END_CRITICAL:
+ p = "!$OMP END CRITICAL";
+ break;
+ case ST_OMP_END_DO:
+ p = "!$OMP END DO";
+ break;
+ case ST_OMP_END_MASTER:
+ p = "!$OMP END MASTER";
+ break;
+ case ST_OMP_END_ORDERED:
+ p = "!$OMP END ORDERED";
+ break;
+ case ST_OMP_END_PARALLEL:
+ p = "!$OMP END PARALLEL";
+ break;
+ case ST_OMP_END_PARALLEL_DO:
+ p = "!$OMP END PARALLEL DO";
+ break;
+ case ST_OMP_END_PARALLEL_SECTIONS:
+ p = "!$OMP END PARALLEL SECTIONS";
+ break;
+ case ST_OMP_END_PARALLEL_WORKSHARE:
+ p = "!$OMP END PARALLEL WORKSHARE";
+ break;
+ case ST_OMP_END_SECTIONS:
+ p = "!$OMP END SECTIONS";
+ break;
+ case ST_OMP_END_SINGLE:
+ p = "!$OMP END SINGLE";
+ break;
+ case ST_OMP_END_WORKSHARE:
+ p = "!$OMP END WORKSHARE";
+ break;
+ case ST_OMP_FLUSH:
+ p = "!$OMP FLUSH";
+ break;
+ case ST_OMP_MASTER:
+ p = "!$OMP MASTER";
+ break;
+ case ST_OMP_ORDERED:
+ p = "!$OMP ORDERED";
+ break;
+ case ST_OMP_PARALLEL:
+ p = "!$OMP PARALLEL";
+ break;
+ case ST_OMP_PARALLEL_DO:
+ p = "!$OMP PARALLEL DO";
+ break;
+ case ST_OMP_PARALLEL_SECTIONS:
+ p = "!$OMP PARALLEL SECTIONS";
+ break;
+ case ST_OMP_PARALLEL_WORKSHARE:
+ p = "!$OMP PARALLEL WORKSHARE";
+ break;
+ case ST_OMP_SECTIONS:
+ p = "!$OMP SECTIONS";
+ break;
+ case ST_OMP_SECTION:
+ p = "!$OMP SECTION";
+ break;
+ case ST_OMP_SINGLE:
+ p = "!$OMP SINGLE";
+ break;
+ case ST_OMP_THREADPRIVATE:
+ p = "!$OMP THREADPRIVATE";
+ break;
+ case ST_OMP_WORKSHARE:
+ p = "!$OMP WORKSHARE";
+ break;
default:
gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
}
}
+/* Create a symbol for the main program and assign it to ns->proc_name. */
+
+static void
+main_program_symbol (gfc_namespace *ns)
+{
+ gfc_symbol *main_program;
+ symbol_attribute attr;
+
+ gfc_get_symbol ("MAIN__", ns, &main_program);
+ gfc_clear_attr (&attr);
+ attr.flavor = FL_PROCEDURE;
+ attr.proc = PROC_UNKNOWN;
+ attr.subroutine = 1;
+ attr.access = ACCESS_PUBLIC;
+ attr.is_main_program = 1;
+ main_program->attr = attr;
+ main_program->declared_at = gfc_current_locus;
+ ns->proc_name = main_program;
+ gfc_commit_symbols ();
+}
+
+
/* Do whatever is necessary to accept the last statement. */
static void
accept_statement (gfc_statement st)
{
-
switch (st)
{
case ST_USE:
break;
/* If the statement is the end of a block, lay down a special code
- that allows a branch to the end of the block from within the
- construct. */
+ that allows a branch to the end of the block from within the
+ construct. */
case ST_ENDIF:
case ST_END_SELECT:
break;
/* The end-of-program unit statements do not get the special
- marker and require a statement of some sort if they are a
- branch target. */
+ marker and require a statement of some sort if they are a
+ branch target. */
case ST_END_PROGRAM:
case ST_END_FUNCTION:
static void
reject_statement (void)
{
-
+ gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
undo_new_statement ();
static void
unexpected_statement (gfc_statement st)
{
-
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
reject_statement ();
valid before calling here, ie ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
- +---------------------------------------+
- | program subroutine function module |
- +---------------------------------------+
- | use |
- |---------------------------------------+
- | | implicit none |
- | +-----------+------------------+
- | | parameter | implicit |
- | +-----------+------------------+
- | format | | derived type |
- | entry | parameter | interface |
- | | data | specification |
- | | | statement func |
- | +-----------+------------------+
- | | data | executable |
- +--------+-----------+------------------+
- | contains |
- +---------------------------------------+
- | internal module/subprogram |
- +---------------------------------------+
- | end |
- +---------------------------------------+
+ +---------------------------------------+
+ | program subroutine function module |
+ +---------------------------------------+
+ | use |
+ +---------------------------------------+
+ | import |
+ +---------------------------------------+
+ | | implicit none |
+ | +-----------+------------------+
+ | | parameter | implicit |
+ | +-----------+------------------+
+ | format | | derived type |
+ | entry | parameter | interface |
+ | | data | specification |
+ | | | statement func |
+ | +-----------+------------------+
+ | | data | executable |
+ +--------+-----------+------------------+
+ | contains |
+ +---------------------------------------+
+ | internal module/subprogram |
+ +---------------------------------------+
+ | end |
+ +---------------------------------------+
*/
typedef struct
{
enum
- { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
- ORDER_SPEC, ORDER_EXEC
+ { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
+ ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
}
state;
gfc_statement last_statement;
st_state;
static try
-verify_st_order (st_state * p, gfc_statement st)
+verify_st_order (st_state *p, gfc_statement st)
{
switch (st)
p->state = ORDER_USE;
break;
+ case ST_IMPORT:
+ if (p->state > ORDER_IMPORT)
+ goto order;
+ p->state = ORDER_IMPORT;
+ break;
+
case ST_IMPLICIT_NONE:
if (p->state > ORDER_IMPLICIT_NONE)
goto order;
- /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
- statement disqualifies a USE but not an IMPLICIT NONE.
- Duplicate IMPLICIT NONEs are caught when the implicit types
- are set. */
+ /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
+ statement disqualifies a USE but not an IMPLICIT NONE.
+ Duplicate IMPLICIT NONEs are caught when the implicit types
+ are set. */
p->state = ORDER_IMPLICIT_NONE;
break;
break;
default:
- gfc_internal_error
- ("Unexpected %s statement in verify_st_order() at %C",
- gfc_ascii_statement (st));
+ gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
+ gfc_ascii_statement (st));
}
/* All is well, record the statement in case we need it next time. */
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
- gfc_component *c;
gfc_state_data s;
+ gfc_symbol *sym;
+ gfc_component *c;
error_flag = 0;
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
- gfc_error
- ("PRIVATE statement in TYPE at %C must be inside a MODULE");
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
error_flag = 1;
break;
}
}
}
- /* Sanity checks on the structure. If the structure has the
- SEQUENCE attribute, then all component structures must also have
- SEQUENCE. */
- if (error_flag == 0 && gfc_current_block ()->attr.sequence)
- for (c = gfc_current_block ()->components; c; c = c->next)
- {
- if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
- {
- gfc_error
- ("Component %s of SEQUENCE type declared at %C does not "
- "have the SEQUENCE attribute", c->ts.derived->name);
- }
- }
+ /* Look for allocatable components. */
+ sym = gfc_current_block ();
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->allocatable
+ || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
+ {
+ sym->attr.alloc_comp = 1;
+ break;
+ }
+ }
pop_state ();
}
+/* Parse an ENUM. */
+
+static void
+parse_enum (void)
+{
+ int error_flag;
+ gfc_statement st;
+ int compiling_enum;
+ gfc_state_data s;
+ int seen_enumerator = 0;
+
+ error_flag = 0;
+
+ push_state (&s, COMP_ENUM, gfc_new_block);
+
+ compiling_enum = 1;
+
+ while (compiling_enum)
+ {
+ st = next_statement ();
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
+
+ case ST_ENUMERATOR:
+ seen_enumerator = 1;
+ accept_statement (st);
+ break;
+
+ case ST_END_ENUM:
+ compiling_enum = 0;
+ if (!seen_enumerator)
+ {
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+ error_flag = 1;
+ }
+ accept_statement (st);
+ break;
+
+ default:
+ gfc_free_enum_history ();
+ unexpected_statement (st);
+ break;
+ }
+ }
+ pop_state ();
+}
+
/* Parse an interface. We must be able to deal with the possibility
of recursive interfaces. The parse_spec() subroutine is mutually
gfc_interface_info save;
gfc_state_data s1, s2;
gfc_statement st;
+ locus proc_locus;
accept_statement (ST_INTERFACE);
save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC
- || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
+ || current_interface.type == INTERFACE_USER_OP)
+ ? gfc_new_block : NULL;
push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE;
if (new_state != current_state)
{
if (new_state == COMP_SUBROUTINE)
- gfc_error
- ("SUBROUTINE at %C does not belong in a generic function "
- "interface");
+ gfc_error ("SUBROUTINE at %C does not belong in a "
+ "generic function interface");
if (new_state == COMP_FUNCTION)
- gfc_error
- ("FUNCTION at %C does not belong in a generic subroutine "
- "interface");
+ gfc_error ("FUNCTION at %C does not belong in a "
+ "generic subroutine interface");
}
}
}
accept_statement (st);
prog_unit = gfc_new_block;
prog_unit->formal_ns = gfc_current_ns;
+ proc_locus = gfc_current_locus;
decl:
/* Read data declaration statements. */
current_interface = save;
gfc_add_interface (prog_unit);
-
pop_state ();
+
+ if (current_interface.ns
+ && current_interface.ns->proc_name
+ && strcmp (current_interface.ns->proc_name->name,
+ prog_unit->name) == 0)
+ gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
+ "enclosing procedure", prog_unit->name, &proc_locus);
+
goto loop;
done:
/* Fall through */
case ST_USE:
+ case ST_IMPORT:
case ST_IMPLICIT_NONE:
case ST_IMPLICIT:
case ST_PARAMETER:
st = next_statement ();
goto loop;
+ case ST_ENUM:
+ accept_statement (st);
+ parse_enum();
+ st = next_statement ();
+ goto loop;
+
default:
break;
}
case ST_WHERE_BLOCK:
parse_where_block ();
- /* Fall through */
+ break;
case ST_ASSIGNMENT:
case ST_WHERE:
case ST_ELSEWHERE:
if (seen_empty_else)
{
- gfc_error
- ("ELSEWHERE statement at %C follows previous unmasked "
- "ELSEWHERE");
+ gfc_error ("ELSEWHERE statement at %C follows previous "
+ "unmasked ELSEWHERE");
break;
}
reject_statement ();
break;
}
-
}
while (st != ST_END_WHERE);
case ST_ELSEIF:
if (seen_else)
{
- gfc_error
- ("ELSE IF statement at %C cannot follow ELSE statement at %L",
- &else_locus);
+ gfc_error ("ELSE IF statement at %C cannot follow ELSE "
+ "statement at %L", &else_locus);
reject_statement ();
break;
if (st == ST_CASE)
break;
- gfc_error
- ("Expected a CASE or END SELECT statement following SELECT CASE "
- "at %C");
+ gfc_error ("Expected a CASE or END SELECT statement following SELECT "
+ "CASE at %C");
reject_statement ();
}
case ST_END_SELECT:
break;
- /* Can't have an executable statement because of
- parse_executable(). */
+ /* Can't have an executable statement because of
+ parse_executable(). */
default:
unexpected_statement (st);
break;
if (p == gfc_state_stack)
return 1;
- gfc_error
- ("End of nonblock DO statement at %C is within another block");
+ gfc_error ("End of nonblock DO statement at %C is within another block");
return 2;
}
case ST_ENDDO:
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
- gfc_error_now
- ("Statement label in ENDDO at %C doesn't match DO label");
+ gfc_error_now ("Statement label in ENDDO at %C doesn't match "
+ "DO label");
if (gfc_statement_label != NULL)
{
break;
case ST_IMPLIED_ENDDO:
+ /* If the do-stmt of this DO construct has a do-construct-name,
+ the corresponding end-do must be an end-do-stmt (with a matching
+ name, but in that case we must have seen ST_ENDDO first).
+ We only complain about this in pedantic mode. */
+ if (gfc_current_block () != NULL)
+ gfc_error_now ("named block DO at %L requires matching ENDDO name",
+ &gfc_current_block()->declared_at);
+
break;
default:
}
+/* Parse the statements of OpenMP do/parallel do. */
+
+static gfc_statement
+parse_omp_do (gfc_statement omp_st)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_DO)
+ break;
+ else
+ unexpected_statement (st);
+ }
+
+ parse_do_block ();
+ if (gfc_statement_label != NULL
+ && gfc_state_stack->previous != NULL
+ && gfc_state_stack->previous->state == COMP_DO
+ && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
+ {
+ /* In
+ DO 100 I=1,10
+ !$OMP DO
+ DO J=1,10
+ ...
+ 100 CONTINUE
+ there should be no !$OMP END DO. */
+ pop_state ();
+ return ST_IMPLIED_ENDDO;
+ }
+
+ check_do_closure ();
+ pop_state ();
+
+ st = next_statement ();
+ if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+ {
+ if (new_st.op == EXEC_OMP_END_NOWAIT)
+ cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+ else
+ gcc_assert (new_st.op == EXEC_NOP);
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ st = next_statement ();
+ }
+ return st;
+}
+
+
+/* Parse the statements of OpenMP atomic directive. */
+
+static void
+parse_omp_atomic (void)
+{
+ gfc_statement st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (ST_OMP_ATOMIC);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_ASSIGNMENT)
+ break;
+ else
+ unexpected_statement (st);
+ }
+
+ accept_statement (st);
+
+ pop_state ();
+}
+
+
+/* Parse the statements of an OpenMP structured block. */
+
+static void
+parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
+{
+ gfc_statement st, omp_end_st;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+
+ accept_statement (omp_st);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
+ np = new_level (cp);
+ np->op = cp->op;
+ np->block = NULL;
+
+ switch (omp_st)
+ {
+ case ST_OMP_PARALLEL:
+ omp_end_st = ST_OMP_END_PARALLEL;
+ break;
+ case ST_OMP_PARALLEL_SECTIONS:
+ omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
+ break;
+ case ST_OMP_SECTIONS:
+ omp_end_st = ST_OMP_END_SECTIONS;
+ break;
+ case ST_OMP_ORDERED:
+ omp_end_st = ST_OMP_END_ORDERED;
+ break;
+ case ST_OMP_CRITICAL:
+ omp_end_st = ST_OMP_END_CRITICAL;
+ break;
+ case ST_OMP_MASTER:
+ omp_end_st = ST_OMP_END_MASTER;
+ break;
+ case ST_OMP_SINGLE:
+ omp_end_st = ST_OMP_END_SINGLE;
+ break;
+ case ST_OMP_WORKSHARE:
+ omp_end_st = ST_OMP_END_WORKSHARE;
+ break;
+ case ST_OMP_PARALLEL_WORKSHARE:
+ omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ do
+ {
+ if (workshare_stmts_only)
+ {
+ /* Inside of !$omp workshare, only
+ scalar assignments
+ array assignments
+ where statements and constructs
+ forall statements and constructs
+ !$omp atomic
+ !$omp critical
+ !$omp parallel
+ are allowed. For !$omp critical these
+ restrictions apply recursively. */
+ bool cycle = true;
+
+ st = next_statement ();
+ for (;;)
+ {
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+
+ case ST_ASSIGNMENT:
+ case ST_WHERE:
+ case ST_FORALL:
+ accept_statement (st);
+ break;
+
+ case ST_WHERE_BLOCK:
+ parse_where_block ();
+ break;
+
+ case ST_FORALL_BLOCK:
+ parse_forall_block ();
+ break;
+
+ case ST_OMP_PARALLEL:
+ case ST_OMP_PARALLEL_SECTIONS:
+ parse_omp_structured_block (st, false);
+ break;
+
+ case ST_OMP_PARALLEL_WORKSHARE:
+ case ST_OMP_CRITICAL:
+ parse_omp_structured_block (st, true);
+ break;
+
+ case ST_OMP_PARALLEL_DO:
+ st = parse_omp_do (st);
+ continue;
+
+ case ST_OMP_ATOMIC:
+ parse_omp_atomic ();
+ break;
+
+ default:
+ cycle = false;
+ break;
+ }
+
+ if (!cycle)
+ break;
+
+ st = next_statement ();
+ }
+ }
+ else
+ st = parse_executable (ST_NONE);
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_OMP_SECTION
+ && (omp_st == ST_OMP_SECTIONS
+ || omp_st == ST_OMP_PARALLEL_SECTIONS))
+ {
+ np = new_level (np);
+ np->op = cp->op;
+ np->block = NULL;
+ }
+ else if (st != omp_end_st)
+ unexpected_statement (st);
+ }
+ while (st != omp_end_st);
+
+ switch (new_st.op)
+ {
+ case EXEC_OMP_END_NOWAIT:
+ cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
+ break;
+ case EXEC_OMP_CRITICAL:
+ if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
+ || (new_st.ext.omp_name != NULL
+ && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
+ gfc_error ("Name after !$omp critical and !$omp end critical does "
+ "not match at %C");
+ gfc_free ((char *) new_st.ext.omp_name);
+ break;
+ case EXEC_OMP_END_SINGLE:
+ cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
+ = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
+ new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
+ gfc_free_omp_clauses (new_st.ext.omp_clauses);
+ break;
+ case EXEC_NOP:
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ pop_state ();
+}
+
+
/* Accept a series of executable statements. We return the first
statement that doesn't fit to the caller. Any block statements are
passed on to the correct handler, which usually passes the buck
if (st == ST_NONE)
st = next_statement ();
- for (;; st = next_statement ())
+ for (;;)
{
-
close_flag = check_do_closure ();
if (close_flag)
switch (st)
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
- gfc_error
- ("%s statement at %C cannot terminate a non-block DO loop",
- gfc_ascii_statement (st));
+ gfc_error ("%s statement at %C cannot terminate a non-block "
+ "DO loop", gfc_ascii_statement (st));
break;
default:
accept_statement (st);
if (close_flag == 1)
return ST_IMPLIED_ENDDO;
- continue;
+ break;
case ST_IF_BLOCK:
parse_if_block ();
- continue;
+ break;
case ST_SELECT_CASE:
parse_select_block ();
- continue;
+ break;
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
return ST_IMPLIED_ENDDO;
- continue;
+ break;
case ST_WHERE_BLOCK:
parse_where_block ();
- continue;
+ break;
case ST_FORALL_BLOCK:
parse_forall_block ();
+ break;
+
+ case ST_OMP_PARALLEL:
+ case ST_OMP_PARALLEL_SECTIONS:
+ case ST_OMP_SECTIONS:
+ case ST_OMP_ORDERED:
+ case ST_OMP_CRITICAL:
+ case ST_OMP_MASTER:
+ case ST_OMP_SINGLE:
+ parse_omp_structured_block (st, false);
+ break;
+
+ case ST_OMP_WORKSHARE:
+ case ST_OMP_PARALLEL_WORKSHARE:
+ parse_omp_structured_block (st, true);
+ break;
+
+ case ST_OMP_DO:
+ case ST_OMP_PARALLEL_DO:
+ st = parse_omp_do (st);
+ if (st == ST_IMPLIED_ENDDO)
+ return st;
continue;
- default:
+ case ST_OMP_ATOMIC:
+ parse_omp_atomic ();
break;
+
+ default:
+ return st;
}
- break;
+ st = next_statement ();
}
-
- return st;
}
the child namespace as the parser didn't know about this procedure. */
static void
-gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
+gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
{
gfc_namespace *ns;
gfc_symtree *st;
for (ns = siblings; ns; ns = ns->sibling)
{
gfc_find_sym_tree (sym->name, ns, 0, &st);
- if (!st)
- continue;
+
+ if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
+ continue;
old_sym = st->n.sym;
if ((old_sym->attr.flavor == FL_PROCEDURE
|| old_sym->ts.type == BT_UNKNOWN)
&& old_sym->ns == ns
- && ! old_sym->attr.contained)
- {
- /* Replace it with the symbol from the parent namespace. */
- st->n.sym = sym;
- sym->refs++;
-
- /* Free the old (local) symbol. */
- old_sym->refs--;
- if (old_sym->refs == 0)
- gfc_free_symbol (old_sym);
- }
+ && !old_sym->attr.contained)
+ {
+ /* Replace it with the symbol from the parent namespace. */
+ st->n.sym = sym;
+ sym->refs++;
+
+ /* Free the old (local) symbol. */
+ old_sym->refs--;
+ if (old_sym->refs == 0)
+ gfc_free_symbol (old_sym);
+ }
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
gfc_statement st;
gfc_symbol *sym;
gfc_entry_list *el;
+ int contains_statements = 0;
push_state (&s1, COMP_CONTAINS, NULL);
parent_ns = gfc_current_ns;
case ST_FUNCTION:
case ST_SUBROUTINE:
+ contains_statements = 1;
accept_statement (st);
push_state (&s2,
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
- gfc_error
- ("Contained procedure '%s' at %C is already ambiguous",
- gfc_new_block->name);
+ gfc_error ("Contained procedure '%s' at %C is already "
+ "ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
gfc_commit_symbols ();
}
- else
- sym = gfc_new_block;
+ else
+ sym = gfc_new_block;
- /* Mark this as a contained function, so it isn't replaced
- by other module functions. */
- sym->attr.contained = 1;
+ /* Mark this as a contained function, so it isn't replaced
+ by other module functions. */
+ sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
- /* Fix up any sibling functions that refer to this one. */
- gfc_fixup_sibling_symbols (sym, gfc_current_ns);
+ /* Fix up any sibling functions that refer to this one. */
+ gfc_fixup_sibling_symbols (sym, gfc_current_ns);
/* Or refer to any of its alternate entry points. */
for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
pop_state ();
break;
- /* These statements are associated with the end of the host
- unit. */
+ /* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_PROGRAM:
gfc_free_namespace (ns);
pop_state ();
+ if (!contains_statements)
+ /* This is valid in Fortran 2008. */
+ gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
+ "FUNCTION or SUBROUTINE statement at %C");
}
/* Come here to complain about a global symbol already in use as
something else. */
-static void
+void
global_used (gfc_gsymbol *sym, locus *where)
{
const char *name;
}
gfc_error("Global name '%s' at %L is already being used as a %s at %L",
- gfc_new_block->name, where, name, &sym->where);
+ sym->name, where, name, &sym->where);
}
{
if (blank_block)
gfc_error ("Blank BLOCK DATA at %C conflicts with "
- "prior BLOCK DATA at %L", &blank_locus);
+ "prior BLOCK DATA at %L", &blank_locus);
else
{
- blank_block = 1;
- blank_locus = gfc_current_locus;
+ blank_block = 1;
+ blank_locus = gfc_current_locus;
}
}
else
{
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
global_used(s, NULL);
else
{
- s->type = GSYM_BLOCK_DATA;
- s->where = gfc_current_locus;
+ s->type = GSYM_BLOCK_DATA;
+ s->where = gfc_current_locus;
+ s->defined = 1;
}
}
gfc_gsymbol *s;
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
global_used(s, NULL);
else
{
s->type = GSYM_MODULE;
s->where = gfc_current_locus;
+ s->defined = 1;
}
st = parse_spec (ST_NONE);
s = gfc_get_gsymbol(gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN
+ && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
+ s->defined = 1;
}
}
return;
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->type != GSYM_UNKNOWN)
+ if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
global_used(s, NULL);
else
{
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
+ s->defined = 1;
}
}
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
+ main_program_symbol(gfc_current_ns);
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
+ main_program_symbol (gfc_current_ns);
parse_progunit (st);
break;
}
if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
- if (errors == 0 && ! gfc_option.flag_no_backend)
+ if (errors == 0)
gfc_generate_module_code (gfc_current_ns);
}
else
{
- if (errors == 0 && ! gfc_option.flag_no_backend)
+ if (errors == 0)
gfc_generate_code (gfc_current_ns);
}