/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
Inc.
Contributed by Andy Vaught
/* Figure out what the next statement is, (mostly) regardless of
- proper ordering. */
+ proper ordering. The do...while(0) is there to prevent if/else
+ ambiguity. */
#define match(keyword, subr, st) \
- if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
- else \
- undo_new_statement ();
+ do { \
+ if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
static gfc_statement
decode_statement (void)
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;
break;
case 'f':
+ match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
break;
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;
gfc_gobble_whitespace ();
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 ("Statement label at %C is zero");
+
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");
+
}
else
{
label_locus = gfc_current_locus;
- if (gfc_statement_label->value == 0)
- {
- gfc_warning_now ("Ignoring statement label of zero at %C");
- gfc_free_st_label (gfc_statement_label);
- gfc_statement_label = NULL;
- }
-
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
}
}
}
+ 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 == ' ');
+ return decode_omp_directive ();
+ }
+ }
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:
blank_line:
if (digit_flag)
- gfc_warning ("Statement label in blank line will be " "ignored at %C");
+ gfc_warning ("Statement label in blank line will be ignored at %C");
gfc_advance_line ();
return ST_NONE;
}
case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
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_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
+ 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(). */
switch (st)
{
case ST_ARITHMETIC_IF:
- p = "arithmetic IF";
+ p = _("arithmetic IF");
break;
case ST_ALLOCATE:
p = "ALLOCATE";
break;
case ST_ATTR_DECL:
- p = "attribute declaration";
+ p = _("attribute declaration");
break;
case ST_BACKSPACE:
p = "BACKSPACE";
p = "CYCLE";
break;
case ST_DATA_DECL:
- p = "data declaration";
+ p = _("data declaration");
break;
case ST_DATA:
p = "DATA";
p = "DEALLOCATE";
break;
case ST_DERIVED_DECL:
- p = "Derived type declaration";
+ p = _("derived type declaration");
break;
case ST_DO:
p = "DO";
case ST_EXIT:
p = "EXIT";
break;
+ case ST_FLUSH:
+ p = "FLUSH";
+ break;
case ST_FORALL_BLOCK: /* Fall through */
case ST_FORALL:
p = "FORALL";
p = "GOTO";
break;
case ST_IF_BLOCK:
- p = "block IF";
+ p = _("block IF");
break;
case ST_IMPLICIT:
p = "IMPLICIT";
p = "IMPLICIT NONE";
break;
case ST_IMPLIED_ENDDO:
- p = "implied END DO";
+ p = _("implied END DO");
break;
case ST_INQUIRE:
p = "INQUIRE";
p = "WRITE";
break;
case ST_ASSIGNMENT:
- p = "assignment";
+ p = _("assignment");
break;
case ST_POINTER_ASSIGNMENT:
- p = "pointer assignment";
+ p = _("pointer assignment");
break;
case ST_SELECT_CASE:
p = "SELECT CASE";
p = "SEQUENCE";
break;
case ST_SIMPLE_IF:
- p = "Simple IF";
+ p = _("simple IF");
break;
case ST_STATEMENT_FUNCTION:
p = "STATEMENT FUNCTION";
case ST_LABEL_ASSIGNMENT:
p = "LABEL ASSIGNMENT";
break;
- default:
- gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
- }
-
- return p;
-}
-
-
-/* Return the name of a compile state. */
-
-const char *
-gfc_state_name (gfc_compile_state state)
-{
- const char *p;
-
- switch (state)
- {
- case COMP_PROGRAM:
- p = "a PROGRAM";
+ case ST_ENUM:
+ p = "ENUM DEFINITION";
break;
- case COMP_MODULE:
- p = "a MODULE";
+ case ST_ENUMERATOR:
+ p = "ENUMERATOR DEFINITION";
break;
- case COMP_SUBROUTINE:
- p = "a SUBROUTINE";
+ case ST_END_ENUM:
+ p = "END ENUM";
break;
- case COMP_FUNCTION:
- p = "a FUNCTION";
+ case ST_OMP_ATOMIC:
+ p = "!$OMP ATOMIC";
break;
- case COMP_BLOCK_DATA:
- p = "a BLOCK DATA";
+ case ST_OMP_BARRIER:
+ p = "!$OMP BARRIER";
break;
- case COMP_INTERFACE:
- p = "an INTERFACE";
+ case ST_OMP_CRITICAL:
+ p = "!$OMP CRITICAL";
break;
- case COMP_DERIVED:
- p = "a DERIVED TYPE block";
+ case ST_OMP_DO:
+ p = "!$OMP DO";
break;
- case COMP_IF:
- p = "an IF-THEN block";
+ case ST_OMP_END_CRITICAL:
+ p = "!$OMP END CRITICAL";
break;
- case COMP_DO:
- p = "a DO block";
+ case ST_OMP_END_DO:
+ p = "!$OMP END DO";
break;
- case COMP_SELECT:
- p = "a SELECT block";
+ case ST_OMP_END_MASTER:
+ p = "!$OMP END MASTER";
break;
- case COMP_FORALL:
- p = "a FORALL block";
+ case ST_OMP_END_ORDERED:
+ p = "!$OMP END ORDERED";
break;
- case COMP_WHERE:
- p = "a WHERE block";
+ case ST_OMP_END_PARALLEL:
+ p = "!$OMP END PARALLEL";
break;
- case COMP_CONTAINS:
- p = "a contained subprogram";
+ 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_state_name(): Bad state");
+ gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
}
return p;
}
+/* 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
+/* 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
recursive with parse_interface(). */
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:
}
+/* 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)
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;
}
/* 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);
}
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->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;
}
}
seen_program = 0;
+ /* Exit early for empty files. */
+ if (gfc_at_eof ())
+ goto done;
+
loop:
gfc_init_2 ();
st = next_statement ();
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;
}
OSDN Git Service
