/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
- Free Software Foundation, Inc.
+ Copyright (C) 2000-2016 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
-#include <setjmp.h>
+#include "coretypes.h"
+#include "options.h"
#include "gfortran.h"
+#include <setjmp.h>
#include "match.h"
#include "parse.h"
-#include "debug.h"
/* Current statement label. Zero means no statement label. Because new_st
can get wiped during statement matching, we have to keep it separate. */
static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
+static bool last_was_use_stmt = false;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
}
+/* Like match_word, but if str is matched, set a flag that it
+ was matched. */
+static match
+match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
+ bool *simd_matched)
+{
+ match m;
+
+ if (str != NULL)
+ {
+ m = gfc_match (str);
+ if (m != MATCH_YES)
+ return m;
+ *simd_matched = true;
+ }
+
+ m = (*subr) ();
+
+ if (m != MATCH_YES)
+ {
+ gfc_current_locus = *old_locus;
+ reject_statement ();
+ }
+
+ return m;
+}
+
+
+/* Load symbols from all USE statements encountered in this scoping unit. */
+
+static void
+use_modules (void)
+{
+ gfc_error_buffer old_error;
+
+ gfc_push_error (&old_error);
+ gfc_buffer_error (false);
+ gfc_use_modules ();
+ gfc_buffer_error (true);
+ gfc_pop_error (&old_error);
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
+ gfc_current_ns->old_equiv = gfc_current_ns->equiv;
+ gfc_current_ns->old_data = gfc_current_ns->data;
+ last_was_use_stmt = false;
+}
+
+
/* Figure out what the next statement is, (mostly) regardless of
proper ordering. The do...while(0) is there to prevent if/else
ambiguity. */
#define match(keyword, subr, st) \
do { \
- if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
+ if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
return st; \
else \
- undo_new_statement (); \
+ undo_new_statement (); \
} while (0);
for the specification statements in a function, whose
characteristics are deferred into the specification statements.
eg.: INTEGER (king = mykind) foo ()
- USE mymodule, ONLY mykind.....
+ USE mymodule, ONLY mykind.....
The KIND parameter needs a return after USE or IMPORT, whereas
derived type declarations can occur anywhere, up the executable
block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
old_locus = gfc_current_locus;
+ if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
+ {
+ last_was_use_stmt = true;
+ return ST_USE;
+ }
+ else
+ {
+ undo_new_statement ();
+ if (last_was_use_stmt)
+ use_modules ();
+ }
+
match ("import", gfc_match_import, ST_IMPORT);
- match ("use", gfc_match_use, ST_USE);
if (gfc_current_block ()->result->ts.type != BT_DERIVED)
goto end_of_block;
case 'a':
match ("abstract% interface", gfc_match_abstract_interface,
ST_INTERFACE);
- match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
+ match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
break;
end_of_block:
gfc_clear_error ();
- gfc_buffer_error (0);
+ gfc_buffer_error (false);
gfc_current_locus = old_locus;
return ST_GET_FCN_CHARACTERISTICS;
}
+static bool in_specification_block;
/* This is the primary 'decode_statement'. */
static gfc_statement
decode_statement (void)
{
+ gfc_namespace *ns;
gfc_statement st;
locus old_locus;
- match m;
+ match m = MATCH_NO;
char c;
gfc_enforce_clean_symbol_state ();
old_locus = gfc_current_locus;
+ c = gfc_peek_ascii_char ();
+
+ if (c == 'u')
+ {
+ if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
+ {
+ last_was_use_stmt = true;
+ return ST_USE;
+ }
+ else
+ undo_new_statement ();
+ }
+
+ if (last_was_use_stmt)
+ use_modules ();
+
/* Try matching a data declaration or function declaration. The
input "REALFUNCTIONA(N)" can mean several things in different
contexts, so it (and its relatives) get special treatment. */
return ST_FUNCTION;
else if (m == MATCH_ERROR)
reject_statement ();
- else
+ else
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
- match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+
+ if (in_specification_block)
+ {
+ m = match_word (NULL, gfc_match_st_function, &old_locus);
+ if (m == MATCH_YES)
+ return ST_STATEMENT_FUNCTION;
+ }
+
+ if (!(in_specification_block && m == MATCH_ERROR))
+ {
+ match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
+ }
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
gfc_undo_symbols ();
gfc_current_locus = old_locus;
+ if (gfc_match_submod_proc () == MATCH_YES)
+ {
+ if (gfc_new_block->attr.subroutine)
+ return ST_SUBROUTINE;
+ else if (gfc_new_block->attr.function)
+ return ST_FUNCTION;
+ }
+ gfc_undo_symbols ();
+ gfc_current_locus = old_locus;
+
/* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
statements, which might begin with a block label. The match functions for
these statements are unusual in that their keyword is not seen before
match (NULL, gfc_match_associate, ST_ASSOCIATE);
match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
+
+ gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
+ ns = gfc_current_ns;
+ gfc_current_ns = gfc_current_ns->parent;
+ gfc_free_namespace (ns);
/* General statement matching: Instead of testing every possible
statement, we eliminate most possibilities by peeking at the
first character. */
- c = gfc_peek_ascii_char ();
-
switch (c)
{
case 'a':
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
+ match ("event post", gfc_match_event_post, ST_EVENT_POST);
+ match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
break;
case 'f':
match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
break;
+ case 'l':
+ match ("lock", gfc_match_lock, ST_LOCK);
+ break;
+
case 'm':
- match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
+ match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
match ("module", gfc_match_module, ST_MODULE);
break;
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
+ match ("submodule", gfc_match_submodule, ST_SUBMODULE);
match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
break;
case 'u':
- match ("use", gfc_match_use, ST_USE);
+ match ("unlock", gfc_match_unlock, ST_UNLOCK);
break;
case 'v':
/* 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 ())
gfc_error_now ("Unclassifiable statement at %C");
reject_statement ();
return ST_NONE;
}
+/* Like match, but set a flag simd_matched if keyword matched. */
+#define matchs(keyword, subr, st) \
+ do { \
+ if (match_word_omp_simd (keyword, subr, &old_locus, \
+ &simd_matched) == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
+
+/* Like match, but don't match anything if not -fopenmp. */
+#define matcho(keyword, subr, st) \
+ do { \
+ if (!flag_openmp) \
+ ; \
+ else if (match_word (keyword, subr, &old_locus) \
+ == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
+
+static gfc_statement
+decode_oacc_directive (void)
+{
+ locus old_locus;
+ char c;
+
+ gfc_enforce_clean_symbol_state ();
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error_now ("OpenACC directives at %C may not appear in PURE "
+ "procedures");
+ gfc_error_recovery ();
+ return ST_NONE;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ old_locus = gfc_current_locus;
+
+ /* General OpenACC directive matching: Instead of testing every possible
+ statement, we eliminate most possibilities by peeking at the
+ first character. */
+
+ c = gfc_peek_ascii_char ();
+
+ switch (c)
+ {
+ case 'a':
+ match ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
+ break;
+ case 'c':
+ match ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
+ break;
+ case 'd':
+ match ("data", gfc_match_oacc_data, ST_OACC_DATA);
+ match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
+ break;
+ case 'e':
+ match ("end atomic", gfc_match_omp_eos, ST_OACC_END_ATOMIC);
+ match ("end data", gfc_match_omp_eos, ST_OACC_END_DATA);
+ match ("end host_data", gfc_match_omp_eos, ST_OACC_END_HOST_DATA);
+ match ("end kernels loop", gfc_match_omp_eos, ST_OACC_END_KERNELS_LOOP);
+ match ("end kernels", gfc_match_omp_eos, ST_OACC_END_KERNELS);
+ match ("end loop", gfc_match_omp_eos, ST_OACC_END_LOOP);
+ match ("end parallel loop", gfc_match_omp_eos, ST_OACC_END_PARALLEL_LOOP);
+ match ("end parallel", gfc_match_omp_eos, ST_OACC_END_PARALLEL);
+ match ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
+ match ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
+ break;
+ case 'h':
+ match ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
+ break;
+ case 'p':
+ match ("parallel loop", gfc_match_oacc_parallel_loop, ST_OACC_PARALLEL_LOOP);
+ match ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
+ break;
+ case 'k':
+ match ("kernels loop", gfc_match_oacc_kernels_loop, ST_OACC_KERNELS_LOOP);
+ match ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
+ break;
+ case 'l':
+ match ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
+ break;
+ case 'r':
+ match ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
+ break;
+ case 'u':
+ match ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
+ break;
+ case 'w':
+ match ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
+ break;
+ }
+
+ /* Directive not found or stored an error message.
+ Check and give up. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable OpenACC directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
static gfc_statement
decode_omp_directive (void)
{
locus old_locus;
char c;
+ bool simd_matched = false;
gfc_enforce_clean_symbol_state ();
return ST_NONE;
}
+ gfc_unset_implicit_pure (NULL);
+
old_locus = gfc_current_locus;
/* General OpenMP directive matching: Instead of testing every possible
c = gfc_peek_ascii_char ();
+ /* match is for directives that should be recognized only if
+ -fopenmp, matchs for directives that should be recognized
+ if either -fopenmp or -fopenmp-simd. */
switch (c)
{
case 'a':
- match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
+ matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
break;
case 'b':
- match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
+ matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
break;
case 'c':
- match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
+ matcho ("cancellation% point", gfc_match_omp_cancellation_point,
+ ST_OMP_CANCELLATION_POINT);
+ matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
+ matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
break;
case 'd':
- match ("do", gfc_match_omp_do, ST_OMP_DO);
+ matchs ("declare reduction", gfc_match_omp_declare_reduction,
+ ST_OMP_DECLARE_REDUCTION);
+ matchs ("declare simd", gfc_match_omp_declare_simd,
+ ST_OMP_DECLARE_SIMD);
+ matcho ("declare target", gfc_match_omp_declare_target,
+ ST_OMP_DECLARE_TARGET);
+ matchs ("distribute parallel do simd",
+ gfc_match_omp_distribute_parallel_do_simd,
+ ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
+ ST_OMP_DISTRIBUTE_PARALLEL_DO);
+ matchs ("distribute simd", gfc_match_omp_distribute_simd,
+ ST_OMP_DISTRIBUTE_SIMD);
+ matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
+ matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
+ matcho ("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 task", gfc_match_omp_eos, ST_OMP_END_TASK);
- match ("end workshare", gfc_match_omp_end_nowait,
- ST_OMP_END_WORKSHARE);
+ matcho ("end atomic", gfc_match_omp_eos, ST_OMP_END_ATOMIC);
+ matcho ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
+ matchs ("end distribute parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_DISTRIBUTE_SIMD);
+ matcho ("end distribute", gfc_match_omp_eos, ST_OMP_END_DISTRIBUTE);
+ matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
+ matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
+ matchs ("end simd", gfc_match_omp_eos, ST_OMP_END_SIMD);
+ matcho ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
+ matcho ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
+ matchs ("end parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_DO_SIMD);
+ matcho ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
+ matcho ("end parallel sections", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_SECTIONS);
+ matcho ("end parallel workshare", gfc_match_omp_eos,
+ ST_OMP_END_PARALLEL_WORKSHARE);
+ matcho ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
+ matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
+ matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ matcho ("end target data", gfc_match_omp_eos, ST_OMP_END_TARGET_DATA);
+ matchs ("end target teams distribute parallel do simd",
+ gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end target teams distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end target teams distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("end target teams distribute", gfc_match_omp_eos,
+ ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
+ matcho ("end target teams", gfc_match_omp_eos, ST_OMP_END_TARGET_TEAMS);
+ matcho ("end target", gfc_match_omp_eos, ST_OMP_END_TARGET);
+ matcho ("end taskgroup", gfc_match_omp_eos, ST_OMP_END_TASKGROUP);
+ matcho ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
+ matchs ("end teams distribute parallel do simd", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("end teams distribute parallel do", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("end teams distribute simd", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("end teams distribute", gfc_match_omp_eos,
+ ST_OMP_END_TEAMS_DISTRIBUTE);
+ matcho ("end teams", gfc_match_omp_eos, ST_OMP_END_TEAMS);
+ matcho ("end workshare", gfc_match_omp_end_nowait,
+ ST_OMP_END_WORKSHARE);
break;
case 'f':
- match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
+ matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
break;
case 'm':
- match ("master", gfc_match_omp_master, ST_OMP_MASTER);
+ matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
break;
case 'o':
- match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
+ matcho ("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);
+ matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
+ ST_OMP_PARALLEL_DO_SIMD);
+ matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
+ matcho ("parallel sections", gfc_match_omp_parallel_sections,
+ ST_OMP_PARALLEL_SECTIONS);
+ matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
+ ST_OMP_PARALLEL_WORKSHARE);
+ matcho ("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);
+ matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
+ matcho ("section", gfc_match_omp_eos, ST_OMP_SECTION);
+ matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
+ matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
break;
case 't':
- match ("task", gfc_match_omp_task, ST_OMP_TASK);
- match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
- match ("threadprivate", gfc_match_omp_threadprivate,
- ST_OMP_THREADPRIVATE);
+ matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
+ matchs ("target teams distribute parallel do simd",
+ gfc_match_omp_target_teams_distribute_parallel_do_simd,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("target teams distribute parallel do",
+ gfc_match_omp_target_teams_distribute_parallel_do,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("target teams distribute simd",
+ gfc_match_omp_target_teams_distribute_simd,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
+ ST_OMP_TARGET_TEAMS_DISTRIBUTE);
+ matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
+ matcho ("target update", gfc_match_omp_target_update,
+ ST_OMP_TARGET_UPDATE);
+ matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
+ matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
+ matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
+ matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
+ matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
+ matchs ("teams distribute parallel do simd",
+ gfc_match_omp_teams_distribute_parallel_do_simd,
+ ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
+ matcho ("teams distribute parallel do",
+ gfc_match_omp_teams_distribute_parallel_do,
+ ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
+ matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
+ ST_OMP_TEAMS_DISTRIBUTE_SIMD);
+ matcho ("teams distribute", gfc_match_omp_teams_distribute,
+ ST_OMP_TEAMS_DISTRIBUTE);
+ matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
+ matcho ("threadprivate", gfc_match_omp_threadprivate,
+ ST_OMP_THREADPRIVATE);
+ break;
case 'w':
- match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
+ matcho ("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. */
+ stored an error message of some sort. Don't error out if
+ not -fopenmp and simd_matched is false, i.e. if a directive other
+ than one marked with match has been seen. */
- if (gfc_error_check () == 0)
- gfc_error_now ("Unclassifiable OpenMP directive at %C");
+ if (flag_openmp || simd_matched)
+ {
+ if (!gfc_error_check ())
+ gfc_error_now ("Unclassifiable OpenMP directive at %C");
+ }
reject_statement ();
/* 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 ())
gfc_error_now ("Unclassifiable GCC directive at %C");
reject_statement ();
#undef match
+/* Assert next length characters to be equal to token in free form. */
+
+static void
+verify_token_free (const char* token, int length, bool last_was_use_stmt)
+{
+ int i;
+ char c;
+
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == token[i]);
+
+ gcc_assert (gfc_is_whitespace(c));
+ gfc_gobble_whitespace ();
+ if (last_was_use_stmt)
+ use_modules ();
+}
/* Get the next statement in free form source. */
if (gfc_match_eos () == MATCH_YES)
{
- gfc_warning_now ("Ignoring statement label in empty statement "
+ gfc_warning_now (0, "Ignoring statement label in empty statement "
"at %L", &label_locus);
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
else if (c == '!')
{
/* Comments have already been skipped by the time we get here,
- except for GCC attributes and OpenMP directives. */
+ except for GCC attributes and OpenMP/OpenACC directives. */
gfc_next_ascii_char (); /* Eat up the exclamation sign. */
c = gfc_peek_ascii_char ();
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.gfc_flag_openmp)
+ else if (c == '$')
{
- int i;
-
- c = gfc_next_ascii_char ();
- for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == "$omp"[i]);
+ /* Since both OpenMP and OpenACC directives starts with
+ !$ character sequence, we must check all flags combinations */
+ if ((flag_openmp || flag_openmp_simd)
+ && !flag_openacc)
+ {
+ verify_token_free ("$omp", 4, last_was_use_stmt);
+ return decode_omp_directive ();
+ }
+ else if ((flag_openmp || flag_openmp_simd)
+ && flag_openacc)
+ {
+ gfc_next_ascii_char (); /* Eat up dollar character */
+ c = gfc_peek_ascii_char ();
- gcc_assert (c == ' ' || c == '\t');
- gfc_gobble_whitespace ();
- return decode_omp_directive ();
+ if (c == 'o')
+ {
+ verify_token_free ("omp", 3, last_was_use_stmt);
+ return decode_omp_directive ();
+ }
+ else if (c == 'a')
+ {
+ verify_token_free ("acc", 3, last_was_use_stmt);
+ return decode_oacc_directive ();
+ }
+ }
+ else if (flag_openacc)
+ {
+ verify_token_free ("$acc", 4, last_was_use_stmt);
+ return decode_oacc_directive ();
+ }
}
-
- gcc_unreachable ();
+ gcc_unreachable ();
}
-
+
if (at_bol && c == ';')
{
if (!(gfc_option.allow_std & GFC_STD_F2008))
return decode_statement ();
}
+/* Assert next length characters to be equal to token in fixed form. */
+
+static bool
+verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
+{
+ int i;
+ char c = gfc_next_char_literal (NONSTRING);
+
+ for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
+ gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
+
+ if (c != ' ' && c != '0')
+ {
+ gfc_buffer_error (false);
+ gfc_error ("Bad continuation line at %C");
+ return false;
+ }
+ if (last_was_use_stmt)
+ use_modules ();
+
+ return true;
+}
/* Get the next statement in fixed-form source. */
for (i = 0; i < 5; i++)
{
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
switch (c)
{
here, except for GCC attributes and OpenMP directives. */
case '*':
- c = gfc_next_char_literal (0);
-
+ c = gfc_next_char_literal (NONSTRING);
+
if (TOLOWER (c) == 'g')
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert (TOLOWER (c) == "gcc$"[i]);
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.gfc_flag_openmp)
+ else if (c == '$')
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
- gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
-
- if (c != ' ' && c != '0')
+ if ((flag_openmp || flag_openmp_simd)
+ && !flag_openacc)
{
- gfc_buffer_error (0);
- gfc_error ("Bad continuation line at %C");
- return ST_NONE;
+ if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
+ return ST_NONE;
+ return decode_omp_directive ();
+ }
+ else if ((flag_openmp || flag_openmp_simd)
+ && flag_openacc)
+ {
+ c = gfc_next_char_literal(NONSTRING);
+ if (c == 'o' || c == 'O')
+ {
+ if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
+ return ST_NONE;
+ return decode_omp_directive ();
+ }
+ else if (c == 'a' || c == 'A')
+ {
+ if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
+ return ST_NONE;
+ return decode_oacc_directive ();
+ }
+ }
+ else if (flag_openacc)
+ {
+ if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
+ return ST_NONE;
+ return decode_oacc_directive ();
}
-
- return decode_omp_directive ();
}
/* FALLTHROUGH */
here so don't bother checking for them. */
default:
- gfc_buffer_error (0);
+ gfc_buffer_error (false);
gfc_error ("Non-numeric character in statement label at %C");
return ST_NONE;
}
if (digit_flag)
{
if (label == 0)
- gfc_warning_now ("Zero is not a valid statement label at %C");
+ gfc_warning_now (0, "Zero is not a valid statement label at %C");
else
{
/* We've found a valid statement label. */
of a previous statement. If we see something here besides a
space or zero, it must be a bad continuation line. */
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (c == '\n')
goto blank_line;
if (c != ' ' && c != '0')
{
- gfc_buffer_error (0);
+ gfc_buffer_error (false);
gfc_error ("Bad continuation line at %C");
return ST_NONE;
}
do
{
loc = gfc_current_locus;
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
}
while (gfc_is_whitespace (c));
blank_line:
if (digit_flag)
- gfc_warning_now ("Ignoring statement label in empty statement at %L",
+ gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
&label_locus);
-
+
gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
gfc_current_ns->old_equiv = gfc_current_ns->equiv;
+ gfc_current_ns->old_data = gfc_current_ns->data;
for (;;)
{
gfc_statement_label = NULL;
- gfc_buffer_error (1);
+ gfc_buffer_error (true);
if (gfc_at_eol ())
gfc_advance_line ();
break;
}
- gfc_buffer_error (0);
+ gfc_buffer_error (false);
if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
{
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_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: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
- case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
+ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
+ case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
+ case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
+ case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
+ case ST_EVENT_POST: case ST_EVENT_WAIT: \
+ case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
+ case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
/* Statements that mark other executable statements. */
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: \
- case ST_OMP_TASK: case ST_CRITICAL
+ case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
+ case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
+ case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
+ case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
+ case ST_CRITICAL: \
+ case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
+ case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
+ case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
/* 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_OMP_THREADPRIVATE: \
- case ST_PROCEDURE
+ case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
+ case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
+ if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
+ p->ext.oacc_declare_clauses = NULL;
/* If this the state of a construct like BLOCK, DO or IF, the corresponding
construct statement was accepted right before pushing the state. Thus,
/* Try to find the given state in the state stack. */
-gfc_try
+bool
gfc_find_state (gfc_compile_state state)
{
gfc_state_data *p;
if (p->state == state)
break;
- return (p == NULL) ? FAILURE : SUCCESS;
+ return (p == NULL) ? false : true;
}
{
gfc_code *p;
- p = q->block = gfc_get_code ();
+ p = q->block = gfc_get_code (EXEC_NOP);
gfc_state_stack->head = gfc_state_stack->tail = p;
{
gfc_code *p;
- p = gfc_get_code ();
+ p = XCNEW (gfc_code);
*p = new_st;
p->loc = gfc_current_locus;
case ST_ENDIF:
case ST_END_SELECT:
case ST_END_CRITICAL:
+ case ST_END_BLOCK:
+ case ST_END_ASSOCIATE:
case_executable:
case_exec_markers:
- type = ST_LABEL_TARGET;
+ if (st == ST_ENDDO || st == ST_CONTINUE)
+ type = ST_LABEL_DO_TARGET;
+ else
+ type = ST_LABEL_TARGET;
break;
case ST_FORMAT:
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
- || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
- || p->state == COMP_PROGRAM)
+ || p->state == COMP_MODULE || p->state == COMP_SUBMODULE
+ || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
{
if (result != NULL)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_EVENT_POST:
+ p = "EVENT POST";
+ break;
+ case ST_EVENT_WAIT:
+ p = "EVENT WAIT";
+ break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
case ST_END_MODULE:
p = "END MODULE";
break;
+ case ST_END_SUBMODULE:
+ p = "END SUBMODULE";
+ break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
case ST_INTERFACE:
p = "INTERFACE";
break;
+ case ST_LOCK:
+ p = "LOCK";
+ break;
case ST_PARAMETER:
p = "PARAMETER";
break;
case ST_MODULE:
p = "MODULE";
break;
+ case ST_SUBMODULE:
+ p = "SUBMODULE";
+ break;
case ST_PAUSE:
p = "PAUSE";
break;
case ST_TYPE:
p = "TYPE";
break;
+ case ST_UNLOCK:
+ p = "UNLOCK";
+ break;
case ST_USE:
p = "USE";
break;
case ST_END_ENUM:
p = "END ENUM";
break;
+ case ST_OACC_PARALLEL_LOOP:
+ p = "!$ACC PARALLEL LOOP";
+ break;
+ case ST_OACC_END_PARALLEL_LOOP:
+ p = "!$ACC END PARALLEL LOOP";
+ break;
+ case ST_OACC_PARALLEL:
+ p = "!$ACC PARALLEL";
+ break;
+ case ST_OACC_END_PARALLEL:
+ p = "!$ACC END PARALLEL";
+ break;
+ case ST_OACC_KERNELS:
+ p = "!$ACC KERNELS";
+ break;
+ case ST_OACC_END_KERNELS:
+ p = "!$ACC END KERNELS";
+ break;
+ case ST_OACC_KERNELS_LOOP:
+ p = "!$ACC KERNELS LOOP";
+ break;
+ case ST_OACC_END_KERNELS_LOOP:
+ p = "!$ACC END KERNELS LOOP";
+ break;
+ case ST_OACC_DATA:
+ p = "!$ACC DATA";
+ break;
+ case ST_OACC_END_DATA:
+ p = "!$ACC END DATA";
+ break;
+ case ST_OACC_HOST_DATA:
+ p = "!$ACC HOST_DATA";
+ break;
+ case ST_OACC_END_HOST_DATA:
+ p = "!$ACC END HOST_DATA";
+ break;
+ case ST_OACC_LOOP:
+ p = "!$ACC LOOP";
+ break;
+ case ST_OACC_END_LOOP:
+ p = "!$ACC END LOOP";
+ break;
+ case ST_OACC_DECLARE:
+ p = "!$ACC DECLARE";
+ break;
+ case ST_OACC_UPDATE:
+ p = "!$ACC UPDATE";
+ break;
+ case ST_OACC_WAIT:
+ p = "!$ACC WAIT";
+ break;
+ case ST_OACC_CACHE:
+ p = "!$ACC CACHE";
+ break;
+ case ST_OACC_ENTER_DATA:
+ p = "!$ACC ENTER DATA";
+ break;
+ case ST_OACC_EXIT_DATA:
+ p = "!$ACC EXIT DATA";
+ break;
+ case ST_OACC_ROUTINE:
+ p = "!$ACC ROUTINE";
+ break;
+ case ST_OACC_ATOMIC:
+ p = "!ACC ATOMIC";
+ break;
+ case ST_OACC_END_ATOMIC:
+ p = "!ACC END ATOMIC";
+ break;
case ST_OMP_ATOMIC:
p = "!$OMP ATOMIC";
break;
case ST_OMP_BARRIER:
p = "!$OMP BARRIER";
break;
+ case ST_OMP_CANCEL:
+ p = "!$OMP CANCEL";
+ break;
+ case ST_OMP_CANCELLATION_POINT:
+ p = "!$OMP CANCELLATION POINT";
+ break;
case ST_OMP_CRITICAL:
p = "!$OMP CRITICAL";
break;
+ case ST_OMP_DECLARE_REDUCTION:
+ p = "!$OMP DECLARE REDUCTION";
+ break;
+ case ST_OMP_DECLARE_SIMD:
+ p = "!$OMP DECLARE SIMD";
+ break;
+ case ST_OMP_DECLARE_TARGET:
+ p = "!$OMP DECLARE TARGET";
+ break;
+ case ST_OMP_DISTRIBUTE:
+ p = "!$OMP DISTRIBUTE";
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ p = "!$OMP DISTRIBUTE SIMD";
+ break;
case ST_OMP_DO:
p = "!$OMP DO";
break;
+ case ST_OMP_DO_SIMD:
+ p = "!$OMP DO SIMD";
+ break;
+ case ST_OMP_END_ATOMIC:
+ p = "!$OMP END ATOMIC";
+ break;
case ST_OMP_END_CRITICAL:
p = "!$OMP END CRITICAL";
break;
+ case ST_OMP_END_DISTRIBUTE:
+ p = "!$OMP END DISTRIBUTE";
+ break;
+ case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_DISTRIBUTE_SIMD:
+ p = "!$OMP END DISTRIBUTE SIMD";
+ break;
case ST_OMP_END_DO:
p = "!$OMP END DO";
break;
+ case ST_OMP_END_DO_SIMD:
+ p = "!$OMP END DO SIMD";
+ break;
+ case ST_OMP_END_SIMD:
+ p = "!$OMP END SIMD";
+ break;
case ST_OMP_END_MASTER:
p = "!$OMP END MASTER";
break;
case ST_OMP_END_PARALLEL_DO:
p = "!$OMP END PARALLEL DO";
break;
+ case ST_OMP_END_PARALLEL_DO_SIMD:
+ p = "!$OMP END PARALLEL DO SIMD";
+ break;
case ST_OMP_END_PARALLEL_SECTIONS:
p = "!$OMP END PARALLEL SECTIONS";
break;
case ST_OMP_END_TASK:
p = "!$OMP END TASK";
break;
- case ST_OMP_END_WORKSHARE:
- p = "!$OMP END WORKSHARE";
+ case ST_OMP_END_TARGET:
+ p = "!$OMP END TARGET";
break;
- case ST_OMP_FLUSH:
- p = "!$OMP FLUSH";
+ case ST_OMP_END_TARGET_DATA:
+ p = "!$OMP END TARGET DATA";
break;
- case ST_OMP_MASTER:
- p = "!$OMP MASTER";
+ case ST_OMP_END_TARGET_TEAMS:
+ p = "!$OMP END TARGET TEAMS";
break;
- case ST_OMP_ORDERED:
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
+ break;
+ case ST_OMP_END_TASKGROUP:
+ p = "!$OMP END TASKGROUP";
+ break;
+ case ST_OMP_END_TEAMS:
+ p = "!$OMP END TEAMS";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE:
+ p = "!$OMP END TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP END TEAMS DISTRIBUTE SIMD";
+ 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:
case ST_OMP_PARALLEL_DO:
p = "!$OMP PARALLEL DO";
break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ p = "!$OMP PARALLEL DO SIMD";
+ break;
case ST_OMP_PARALLEL_SECTIONS:
p = "!$OMP PARALLEL SECTIONS";
break;
case ST_OMP_SECTION:
p = "!$OMP SECTION";
break;
+ case ST_OMP_SIMD:
+ p = "!$OMP SIMD";
+ break;
case ST_OMP_SINGLE:
p = "!$OMP SINGLE";
break;
+ case ST_OMP_TARGET:
+ p = "!$OMP TARGET";
+ break;
+ case ST_OMP_TARGET_DATA:
+ p = "!$OMP TARGET DATA";
+ break;
+ case ST_OMP_TARGET_TEAMS:
+ p = "!$OMP TARGET TEAMS";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
+ break;
+ case ST_OMP_TARGET_UPDATE:
+ p = "!$OMP TARGET UPDATE";
+ break;
case ST_OMP_TASK:
p = "!$OMP TASK";
break;
+ case ST_OMP_TASKGROUP:
+ p = "!$OMP TASKGROUP";
+ break;
case ST_OMP_TASKWAIT:
p = "!$OMP TASKWAIT";
break;
+ case ST_OMP_TASKYIELD:
+ p = "!$OMP TASKYIELD";
+ break;
+ case ST_OMP_TEAMS:
+ p = "!$OMP TEAMS";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ p = "!$OMP TEAMS DISTRIBUTE";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ p = "!$OMP TEAMS DISTRIBUTE SIMD";
+ break;
case ST_OMP_THREADPRIVATE:
p = "!$OMP THREADPRIVATE";
break;
/* Create a symbol for the main program and assign it to ns->proc_name. */
-
-static void
+
+static void
main_program_symbol (gfc_namespace *ns, const char *name)
{
gfc_symbol *main_program;
{
switch (st)
{
- case ST_USE:
- gfc_use_module ();
- break;
-
case ST_IMPLICIT_NONE:
- gfc_set_implicit_none ();
- break;
-
case ST_IMPLICIT:
break;
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
+ case ST_SUBMODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
case ST_ENDIF:
case ST_END_SELECT:
case ST_END_CRITICAL:
+ if (gfc_statement_label != NULL)
+ {
+ new_st.op = EXEC_END_NESTED_BLOCK;
+ add_statement ();
+ }
+ break;
+
+ /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
+ one parallel block. Thus, we add the special code to the nested block
+ itself, instead of the parent one. */
+ case ST_END_BLOCK:
+ case ST_END_ASSOCIATE:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_END_BLOCK;
gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
gfc_current_ns->equiv = gfc_current_ns->old_equiv;
+ gfc_reject_data (gfc_current_ns);
+
gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
/* Given the next statement seen by the matcher, make sure that it is
in proper order with the last. This subroutine is initialized by
calling it with an argument of ST_NONE. If there is a problem, we
- issue an error and return FAILURE. Otherwise we return SUCCESS.
+ issue an error and return false. Otherwise we return true.
Individual parsers need to verify that the statements seen are
valid before calling here, i.e., ENTRY statements are not allowed in
}
st_state;
-static gfc_try
+static bool
verify_st_order (st_state *p, gfc_statement st, bool silent)
{
break;
case ST_IMPLICIT_NONE:
- if (p->state > ORDER_IMPLICIT_NONE)
+ if (p->state > ORDER_IMPLICIT)
goto order;
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
break;
default:
- gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
- gfc_ascii_statement (st));
+ return false;
}
/* All is well, record the statement in case we need it next time. */
p->where = gfc_current_locus;
p->last_statement = st;
- return SUCCESS;
+ return true;
order:
if (!silent)
gfc_ascii_statement (st),
gfc_ascii_statement (p->last_statement), &p->where);
- return FAILURE;
+ return false;
}
{
gfc_state_data *p;
- gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
+ gfc_error ("Unexpected end of file in %qs", gfc_source_file);
/* Memory cleanup. Move to "second to last". */
for (p = gfc_state_stack; p && p->previous && p->previous->previous;
/* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
section. */
if (gfc_current_block ()->attr.sequence)
- gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
+ gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
" section at %C", gfc_current_block ()->name);
if (gfc_current_block ()->attr.is_bind_c)
- gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
+ gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
" section at %C", gfc_current_block ()->name);
accept_statement (ST_CONTAINS);
goto error;
case ST_PROCEDURE:
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
- " procedure at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
goto error;
accept_statement (ST_PROCEDURE);
break;
case ST_GENERIC:
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
- " at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
goto error;
accept_statement (ST_GENERIC);
break;
case ST_FINAL:
- if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: FINAL procedure declaration"
- " at %C") == FAILURE)
+ if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
+ " at %C"))
goto error;
accept_statement (ST_FINAL);
to_finish = true;
if (!seen_comps
- && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
- "definition at %C with empty CONTAINS "
- "section") == FAILURE))
+ && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
+ "at %C with empty CONTAINS section")))
goto error;
/* ST_END_TYPE is accepted by parse_derived after return. */
break;
case ST_PRIVATE:
- if (gfc_find_state (COMP_MODULE) == FAILURE)
+ if (!gfc_find_state (COMP_MODULE))
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
- gfc_component *c;
+ gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
compiling_type = 0;
if (!seen_component)
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+ gfc_notify_std (GFC_STD_F2003, "Derived type "
"definition at %C without components");
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
- if (gfc_find_state (COMP_MODULE) == FAILURE)
+ if (!gfc_find_state (COMP_MODULE))
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
}
if (gfc_current_block ()->attr.sequence)
- gfc_warning ("SEQUENCE attribute at %C already specified in "
+ gfc_warning (0, "SEQUENCE attribute at %C already specified in "
"TYPE statement");
if (seen_sequence)
}
seen_sequence = 1;
- gfc_add_sequence (&gfc_current_block ()->attr,
+ gfc_add_sequence (&gfc_current_block ()->attr,
gfc_current_block ()->name, NULL);
break;
case ST_CONTAINS:
gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: CONTAINS block in derived type"
+ "CONTAINS block in derived type"
" definition at %C");
accept_statement (ST_CONTAINS);
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
+ bool coarray, lock_type, event_type, allocatable, pointer;
+ coarray = lock_type = event_type = allocatable = pointer = false;
+
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
- || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
- sym->attr.alloc_comp = 1;
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.allocatable)
+ || (c->ts.type == BT_DERIVED && !c->attr.pointer
+ && c->ts.u.derived->attr.alloc_comp))
+ {
+ allocatable = true;
+ sym->attr.alloc_comp = 1;
+ }
/* Look for pointer components. */
if (c->attr.pointer
- || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.class_pointer)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
- sym->attr.pointer_comp = 1;
+ {
+ pointer = true;
+ sym->attr.pointer_comp = 1;
+ }
/* Look for procedure pointer components. */
if (c->attr.proc_pointer
/* Looking for coarray components. */
if (c->attr.codimension
- || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
- sym->attr.coarray_comp = 1;
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->attr.codimension))
+ {
+ coarray = true;
+ sym->attr.coarray_comp = 1;
+ }
+
+ if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
+ && !c->attr.pointer)
+ {
+ coarray = true;
+ sym->attr.coarray_comp = 1;
+ }
+
+ /* Looking for lock_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_LOCK_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
+ && !allocatable && !pointer))
+ {
+ lock_type = 1;
+ lock_comp = c;
+ sym->attr.lock_comp = 1;
+ }
+
+ /* Looking for event_type components. */
+ if ((c->ts.type == BT_DERIVED
+ && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_CLASS && c->attr.class_ok
+ && CLASS_DATA (c)->ts.u.derived->from_intmod
+ == INTMOD_ISO_FORTRAN_ENV
+ && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
+ == ISOFORTRAN_EVENT_TYPE)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
+ && !allocatable && !pointer))
+ {
+ event_type = 1;
+ event_comp = c;
+ sym->attr.event_comp = 1;
+ }
+
+ /* Check for F2008, C1302 - and recall that pointers may not be coarrays
+ (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
+ unless there are nondirect [allocatable or pointer] components
+ involved (cf. 1.3.33.1 and 1.3.33.3). */
+
+ if (pointer && !coarray && lock_type)
+ gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.lock_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type LOCK_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (lock_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (lock_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.lock_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type LOCK_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && lock_type)
+ gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+ "subcomponent of type LOCK_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.lock_comp && coarray && !lock_type)
+ gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
+ "subcomponent of type LOCK_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
+ sym->name, c->name, &c->loc);
+
+ /* Similarly for EVENT TYPE. */
+
+ if (pointer && !coarray && event_type)
+ gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
+ "codimension or be a subcomponent of a coarray, "
+ "which is not possible as the component has the "
+ "pointer attribute", c->name, &c->loc);
+ else if (pointer && !coarray && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
+ "of type EVENT_TYPE, which must have a codimension or be a "
+ "subcomponent of a coarray", c->name, &c->loc);
+
+ if (event_type && allocatable && !coarray)
+ gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
+ "a codimension", c->name, &c->loc);
+ else if (event_type && allocatable && c->ts.type == BT_DERIVED
+ && c->ts.u.derived->attr.event_comp)
+ gfc_error ("Allocatable component %s at %L must have a codimension as "
+ "it has a noncoarray subcomponent of type EVENT_TYPE",
+ c->name, &c->loc);
+
+ if (sym->attr.coarray_comp && !coarray && event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as already a coarray "
+ "subcomponent exists)", c->name, &c->loc, sym->name);
+
+ if (sym->attr.event_comp && coarray && !event_type)
+ gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
+ "subcomponent of type EVENT_TYPE must have a codimension or "
+ "be a subcomponent of a coarray. (Variables of type %s may "
+ "not have a codimension as %s at %L has a codimension or a "
+ "coarray subcomponent)", event_comp->name, &event_comp->loc,
+ sym->name, c->name, &c->loc);
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
/* Parse an ENUM. */
-
+
static void
parse_enum (void)
{
gfc_interface_info save;
gfc_state_data s1, s2;
gfc_statement st;
- locus proc_locus;
accept_statement (ST_INTERFACE);
gfc_new_block->attr.pointer = 0;
gfc_new_block->attr.proc_pointer = 1;
}
- if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
- gfc_new_block->formal, NULL) == FAILURE)
+ if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
+ gfc_new_block->formal, NULL))
{
reject_statement ();
gfc_free_namespace (gfc_current_ns);
goto loop;
}
+ /* F2008 C1210 forbids the IMPORT statement in module procedure
+ interface bodies and the flag is set to import symbols. */
+ if (gfc_new_block->attr.module_procedure)
+ gfc_current_ns->has_import_set = 1;
break;
case ST_PROCEDURE:
}
- /* Make sure that a generic interface has only subroutines or
- functions and that the generic name has the right attribute. */
- if (current_interface.type == INTERFACE_GENERIC)
+ /* Make sure that the generic name has the right attribute. */
+ if (current_interface.type == INTERFACE_GENERIC
+ && current_state == COMP_NONE)
{
- if (current_state == COMP_NONE)
- {
- if (new_state == COMP_FUNCTION && sym)
- gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE && sym)
- gfc_add_subroutine (&sym->attr, sym->name, NULL);
-
- current_state = new_state;
- }
- else
- {
- if (new_state != current_state)
- {
- if (new_state == COMP_SUBROUTINE)
- gfc_error ("SUBROUTINE at %C does not belong in a "
- "generic function interface");
+ if (new_state == COMP_FUNCTION && sym)
+ gfc_add_function (&sym->attr, sym->name, NULL);
+ else if (new_state == COMP_SUBROUTINE && sym)
+ gfc_add_subroutine (&sym->attr, sym->name, NULL);
- if (new_state == COMP_FUNCTION)
- gfc_error ("FUNCTION at %C does not belong in a "
- "generic subroutine interface");
- }
- }
+ current_state = new_state;
}
if (current_interface.type == INTERFACE_ABSTRACT)
{
gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
if (gfc_is_intrinsic_typename (gfc_new_block->name))
- gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
+ gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
"cannot be the same as an intrinsic type",
gfc_new_block->name);
}
accept_statement (st);
prog_unit = gfc_new_block;
prog_unit->formal_ns = gfc_current_ns;
- proc_locus = gfc_current_locus;
+ if (prog_unit == prog_unit->formal_ns->proc_name
+ && prog_unit->ns != prog_unit->formal_ns)
+ prog_unit->refs++;
decl:
/* Read data declaration statements. */
st = parse_spec (ST_NONE);
+ in_specification_block = true;
/* Since the interface block does not permit an IMPLICIT statement,
the default type for the function or the result must be taken
&& 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);
+ gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
+ "enclosing procedure", prog_unit->name,
+ ¤t_interface.ns->proc_name->declared_at);
goto loop;
gfc_current_locus = gfc_current_block ()->declared_at;
gfc_clear_error ();
- gfc_buffer_error (1);
+ gfc_buffer_error (true);
m = gfc_match_prefix (ts);
- gfc_buffer_error (0);
+ gfc_buffer_error (false);
if (ts->type == BT_DERIVED)
{
static void
check_function_result_typed (void)
{
- gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
+ gfc_typespec ts;
gcc_assert (gfc_current_state () == COMP_FUNCTION);
- gcc_assert (ts->type != BT_UNKNOWN);
+
+ if (!gfc_current_ns->proc_name->result) return;
+
+ ts = gfc_current_ns->proc_name->result->ts;
/* Check type-parameters, at the moment only CHARACTER lengths possible. */
/* TODO: Extend when KIND type parameters are implemented. */
- if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
- gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
+ if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
+ gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
}
bool bad_characteristic = false;
gfc_typespec *ts;
+ in_specification_block = true;
+
verify_st_order (&ss, ST_NONE, false);
if (st == ST_NONE)
st = next_statement ();
default:
break;
}
-
+ else if (gfc_current_state () == COMP_BLOCK_DATA)
+ /* Fortran 2008, C1116. */
+ switch (st)
+ {
+ case ST_DATA_DECL:
+ case ST_COMMON:
+ case ST_DATA:
+ case ST_TYPE:
+ case ST_END_BLOCK_DATA:
+ case ST_ATTR_DECL:
+ case ST_EQUIVALENCE:
+ case ST_PARAMETER:
+ case ST_IMPLICIT:
+ case ST_IMPLICIT_NONE:
+ case ST_DERIVED_DECL:
+ case ST_USE:
+ break;
+
+ case ST_NONE:
+ break;
+
+ default:
+ gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
+ gfc_ascii_statement (st));
+ reject_statement ();
+ break;
+ }
+
/* If we find a statement that can not be followed by an IMPLICIT statement
(and thus we can expect to see none any further), type the function result
if it has not yet been typed. Be careful not to give the END statement
verify_st_order (&dummyss, ST_NONE, false);
verify_st_order (&dummyss, st, false);
- if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
+ if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
verify_now = true;
}
case ST_DERIVED_DECL:
case_decl:
declSt:
- if (verify_st_order (&ss, st, false) == FAILURE)
+ if (!verify_st_order (&ss, st, false))
{
reject_statement ();
st = next_statement ();
break;
case ST_STATEMENT_FUNCTION:
- if (gfc_current_state () == COMP_MODULE)
+ if (gfc_current_state () == COMP_MODULE
+ || gfc_current_state () == COMP_SUBMODULE)
{
unexpected_statement (st);
break;
break;
}
- /* If match_deferred_characteristics failed, then there is an error. */
+ /* If match_deferred_characteristics failed, then there is an error. */
if (bad_characteristic)
{
ts = &gfc_current_block ()->result->ts;
if (ts->type != BT_DERIVED)
- gfc_error ("Bad kind expression for function '%s' at %L",
+ gfc_error ("Bad kind expression for function %qs at %L",
gfc_current_block ()->name,
&gfc_current_block ()->declared_at);
else
- gfc_error ("The type for function '%s' at %L is not accessible",
+ gfc_error ("The type for function %qs at %L is not accessible",
gfc_current_block ()->name,
&gfc_current_block ()->declared_at);
ts->type = BT_UNKNOWN;
}
+ in_specification_block = false;
+
return st;
}
{
gfc_error ("ELSEWHERE statement at %C follows previous "
"unmasked ELSEWHERE");
+ reject_statement ();
break;
}
{
gfc_select_type_stack *old = select_type_stack;
select_type_stack = old->prev;
- gfc_free (old);
+ free (old);
}
context that causes it to become redefined. If the symbol is an
iterator, we generate an error message and return nonzero. */
-int
+int
gfc_check_do_variable (gfc_symtree *st)
{
gfc_state_data *s;
for (s=gfc_state_stack; s; s = s->previous)
if (s->do_variable == st)
{
- gfc_error_now("Variable '%s' at %C cannot be redefined inside "
- "loop beginning at %L", st->name, &s->head->loc);
+ gfc_error_now ("Variable %qs at %C cannot be redefined inside "
+ "loop beginning at %L", st->name, &s->head->loc);
return 1;
}
return 0;
}
-
+
/* Checks to see if the current statement label closes an enddo.
Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
return 0;
for (p = gfc_state_stack; p; p = p->previous)
- if (p->state == COMP_DO)
+ if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
break;
if (p == NULL)
/* At this point, the label doesn't terminate the innermost loop.
Make sure it doesn't terminate another one. */
for (; p; p = p->previous)
- if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
+ if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
+ && p->ext.end_do_label == gfc_statement_label)
{
gfc_error ("End of nonblock DO statement at %C is interwoven "
"with another DO loop");
parse_critical_block (void)
{
gfc_code *top, *d;
- gfc_state_data s;
+ gfc_state_data s, *sd;
gfc_statement st;
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
+ gfc_error_now (is_oacc (sd)
+ ? "CRITICAL block inside of OpenACC region at %C"
+ : "CRITICAL block inside of OpenMP region at %C");
+
s.ext.end_do_label = new_st.label1;
accept_statement (ST_CRITICAL);
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
gfc_error_now ("Statement label in END CRITICAL at %C does not "
- "match CRITIAL label");
+ "match CRITICAL label");
if (gfc_statement_label != NULL)
{
gfc_build_block_ns (gfc_namespace *parent_ns)
{
gfc_namespace* my_ns;
+ static int numblock = 1;
my_ns = gfc_get_namespace (parent_ns, 1);
my_ns->construct_entities = 1;
my_ns->proc_name = gfc_new_block;
else
{
- gfc_try t;
+ bool t;
+ char buffer[20]; /* Enough to hold "block@2147483648\n". */
- gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+ snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
+ gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
my_ns->proc_name->name, NULL);
- gcc_assert (t == SUCCESS);
+ gcc_assert (t);
+ gfc_commit_symbol (my_ns->proc_name);
}
if (parent_ns->proc_name)
parse_block_construct (void)
{
gfc_namespace* my_ns;
+ gfc_namespace* my_parent;
gfc_state_data s;
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+ gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
my_ns = gfc_build_block_ns (gfc_current_ns);
push_state (&s, COMP_BLOCK, my_ns->proc_name);
gfc_current_ns = my_ns;
+ my_parent = my_ns->parent;
parse_progunit (ST_NONE);
- gfc_current_ns = gfc_current_ns->parent;
+ /* Don't depend on the value of gfc_current_ns; it might have been
+ reset if the block had errors and was cleaned up. */
+ gfc_current_ns = my_parent;
+
pop_state ();
}
gfc_statement st;
gfc_association_list* a;
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
+ gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
my_ns = gfc_build_block_ns (gfc_current_ns);
for (a = new_st.ext.block.assoc; a; a = a->next)
{
gfc_symbol* sym;
+ gfc_ref *ref;
+ gfc_array_ref *array_ref;
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
gcc_unreachable ();
however, as it may only be set on the target during resolution.
Still, sometimes it helps to have it right now -- especially
for parsing component references on the associate-name
- in case of assication to a derived-type. */
+ in case of association to a derived-type. */
sym->ts = a->target->ts;
+
+ /* Check if the target expression is array valued. This can not always
+ be done by looking at target.rank, because that might not have been
+ set yet. Therefore traverse the chain of refs, looking for the last
+ array ref and evaluate that. */
+ array_ref = NULL;
+ for (ref = a->target->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY)
+ array_ref = &ref->u.ar;
+ if (array_ref || a->target->rank)
+ {
+ gfc_array_spec *as;
+ int dim, rank = 0;
+ if (array_ref)
+ {
+ /* Count the dimension, that have a non-scalar extend. */
+ for (dim = 0; dim < array_ref->dimen; ++dim)
+ if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
+ && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
+ && array_ref->end[dim] == NULL
+ && array_ref->start[dim] != NULL))
+ ++rank;
+ }
+ else
+ rank = a->target->rank;
+ /* When the rank is greater than zero then sym will be an array. */
+ if (sym->ts.type == BT_CLASS)
+ {
+ if ((!CLASS_DATA (sym)->as && rank != 0)
+ || (CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->rank != rank))
+ {
+ /* Don't just (re-)set the attr and as in the sym.ts,
+ because this modifies the target's attr and as. Copy the
+ data and do a build_class_symbol. */
+ symbol_attribute attr = CLASS_DATA (a->target)->attr;
+ int corank = gfc_get_corank (a->target);
+ gfc_typespec type;
+
+ if (rank || corank)
+ {
+ as = gfc_get_array_spec ();
+ as->type = AS_DEFERRED;
+ as->rank = rank;
+ as->corank = corank;
+ attr.dimension = rank ? 1 : 0;
+ attr.codimension = corank ? 1 : 0;
+ }
+ else
+ {
+ as = NULL;
+ attr.dimension = attr.codimension = 0;
+ }
+ attr.class_ok = 0;
+ type = CLASS_DATA (sym)->ts;
+ if (!gfc_build_class_symbol (&type,
+ &attr, &as))
+ gcc_unreachable ();
+ sym->ts = type;
+ sym->ts.type = BT_CLASS;
+ sym->attr.class_ok = 1;
+ }
+ else
+ sym->attr.class_ok = 1;
+ }
+ else if ((!sym->as && rank != 0)
+ || (sym->as && sym->as->rank != rank))
+ {
+ as = gfc_get_array_spec ();
+ as->type = AS_DEFERRED;
+ as->rank = rank;
+ as->corank = gfc_get_corank (a->target);
+ sym->as = as;
+ sym->attr.dimension = 1;
+ if (as->corank)
+ sym->attr.codimension = 1;
+ }
+ }
}
accept_statement (ST_ASSOCIATE);
gfc_code *top;
gfc_state_data s;
gfc_symtree *stree;
+ gfc_exec_op do_op;
+ do_op = new_st.op;
s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL)
accept_statement (ST_DO);
top = gfc_state_stack->tail;
- push_state (&s, COMP_DO, gfc_new_block);
+ push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
+ gfc_new_block);
s.do_variable = stree;
pop_state ();
st = next_statement ();
- if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
+ gfc_statement omp_end_st = ST_OMP_END_DO;
+ switch (omp_st)
+ {
+ case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
+ case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
+ case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
+ case ST_OMP_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ default: gcc_unreachable ();
+ }
+ if (st == omp_end_st)
{
if (new_st.op == EXEC_OMP_END_NOWAIT)
cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
/* Parse the statements of OpenMP atomic directive. */
+static gfc_statement
+parse_omp_oacc_atomic (bool omp_p)
+{
+ gfc_statement st, st_atomic, st_end_atomic;
+ gfc_code *cp, *np;
+ gfc_state_data s;
+ int count;
+
+ if (omp_p)
+ {
+ st_atomic = ST_OMP_ATOMIC;
+ st_end_atomic = ST_OMP_END_ATOMIC;
+ }
+ else
+ {
+ st_atomic = ST_OACC_ATOMIC;
+ st_end_atomic = ST_OACC_END_ATOMIC;
+ }
+ accept_statement (st_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;
+ count = 1 + ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE);
+
+ while (count)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st == ST_ASSIGNMENT)
+ {
+ accept_statement (st);
+ count--;
+ }
+ else
+ unexpected_statement (st);
+ }
+
+ pop_state ();
+
+ st = next_statement ();
+ if (st == st_end_atomic)
+ {
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ st = next_statement ();
+ }
+ else if ((cp->ext.omp_atomic & GFC_OMP_ATOMIC_MASK)
+ == GFC_OMP_ATOMIC_CAPTURE)
+ gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
+ return st;
+}
+
+
+/* Parse the statements of an OpenACC structured block. */
+
static void
-parse_omp_atomic (void)
+parse_oacc_structured_block (gfc_statement acc_st)
+{
+ gfc_statement st, acc_end_st;
+ gfc_code *cp, *np;
+ gfc_state_data s, *sd;
+
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_CRITICAL)
+ gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
+
+ accept_statement (acc_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 (acc_st)
+ {
+ case ST_OACC_PARALLEL:
+ acc_end_st = ST_OACC_END_PARALLEL;
+ break;
+ case ST_OACC_KERNELS:
+ acc_end_st = ST_OACC_END_KERNELS;
+ break;
+ case ST_OACC_DATA:
+ acc_end_st = ST_OACC_END_DATA;
+ break;
+ case ST_OACC_HOST_DATA:
+ acc_end_st = ST_OACC_END_HOST_DATA;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ do
+ {
+ st = parse_executable (ST_NONE);
+ if (st == ST_NONE)
+ unexpected_eof ();
+ else if (st != acc_end_st)
+ {
+ gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
+ reject_statement ();
+ }
+ }
+ while (st != acc_end_st);
+
+ gcc_assert (new_st.op == EXEC_NOP);
+
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ pop_state ();
+}
+
+/* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
+
+static gfc_statement
+parse_oacc_loop (gfc_statement acc_st)
{
gfc_statement st;
gfc_code *cp, *np;
- gfc_state_data s;
+ gfc_state_data s, *sd;
+
+ for (sd = gfc_state_stack; sd; sd = sd->previous)
+ if (sd->state == COMP_CRITICAL)
+ gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
- accept_statement (ST_OMP_ATOMIC);
+ accept_statement (acc_st);
cp = gfc_state_stack->tail;
push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
- else if (st == ST_ASSIGNMENT)
+ else if (st == ST_DO)
break;
else
- unexpected_statement (st);
+ {
+ gfc_error ("Expected DO loop at %C");
+ reject_statement ();
+ }
}
- accept_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)
+ {
+ pop_state ();
+ return ST_IMPLIED_ENDDO;
+ }
+ check_do_closure ();
pop_state ();
+
+ st = next_statement ();
+ if (st == ST_OACC_END_LOOP)
+ gfc_warning (0, "Redundant !$ACC END LOOP at %C");
+ if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
+ (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
+ (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
+ {
+ gcc_assert (new_st.op == EXEC_NOP);
+ gfc_clear_new_st ();
+ gfc_commit_symbols ();
+ gfc_warning_check ();
+ st = next_statement ();
+ }
+ return st;
}
case ST_OMP_SINGLE:
omp_end_st = ST_OMP_END_SINGLE;
break;
+ case ST_OMP_TARGET:
+ omp_end_st = ST_OMP_END_TARGET;
+ break;
+ case ST_OMP_TARGET_DATA:
+ omp_end_st = ST_OMP_END_TARGET_DATA;
+ break;
+ case ST_OMP_TARGET_TEAMS:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
+ break;
case ST_OMP_TASK:
omp_end_st = ST_OMP_END_TASK;
break;
+ case ST_OMP_TASKGROUP:
+ omp_end_st = ST_OMP_END_TASKGROUP;
+ break;
+ case ST_OMP_TEAMS:
+ omp_end_st = ST_OMP_END_TEAMS;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE:
+ omp_end_st = ST_OMP_END_DISTRIBUTE;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
+ break;
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
+ break;
+ case ST_OMP_DISTRIBUTE_SIMD:
+ omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
+ break;
case ST_OMP_WORKSHARE:
omp_end_st = ST_OMP_END_WORKSHARE;
break;
break;
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
st = parse_omp_do (st);
continue;
case ST_OMP_ATOMIC:
- parse_omp_atomic ();
- break;
+ st = parse_omp_oacc_atomic (true);
+ continue;
default:
cycle = false;
&& 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 (CONST_CAST (char *, new_st.ext.omp_name));
+ free (CONST_CAST (char *, new_st.ext.omp_name));
break;
case EXEC_OMP_END_SINGLE:
cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
case ST_NONE:
unexpected_eof ();
- case ST_FORMAT:
case ST_DATA:
+ gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
+ "first executable statement");
+ /* Fall through. */
+
+ case ST_FORMAT:
case ST_ENTRY:
case_executable:
accept_statement (st);
parse_forall_block ();
break;
+ case ST_OACC_PARALLEL_LOOP:
+ case ST_OACC_KERNELS_LOOP:
+ case ST_OACC_LOOP:
+ st = parse_oacc_loop (st);
+ if (st == ST_IMPLIED_ENDDO)
+ return st;
+ continue;
+
+ case ST_OACC_PARALLEL:
+ case ST_OACC_KERNELS:
+ case ST_OACC_DATA:
+ case ST_OACC_HOST_DATA:
+ parse_oacc_structured_block (st);
+ break;
+
case ST_OMP_PARALLEL:
case ST_OMP_PARALLEL_SECTIONS:
case ST_OMP_SECTIONS:
case ST_OMP_CRITICAL:
case ST_OMP_MASTER:
case ST_OMP_SINGLE:
+ case ST_OMP_TARGET:
+ case ST_OMP_TARGET_DATA:
+ case ST_OMP_TARGET_TEAMS:
+ case ST_OMP_TEAMS:
case ST_OMP_TASK:
+ case ST_OMP_TASKGROUP:
parse_omp_structured_block (st, false);
break;
parse_omp_structured_block (st, true);
break;
+ case ST_OMP_DISTRIBUTE:
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_DISTRIBUTE_SIMD:
case ST_OMP_DO:
+ case ST_OMP_DO_SIMD:
case ST_OMP_PARALLEL_DO:
+ case ST_OMP_PARALLEL_DO_SIMD:
+ case ST_OMP_SIMD:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case ST_OMP_TEAMS_DISTRIBUTE:
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
st = parse_omp_do (st);
if (st == ST_IMPLIED_ENDDO)
return st;
continue;
+ case ST_OACC_ATOMIC:
+ st = parse_omp_oacc_atomic (false);
+ continue;
+
case ST_OMP_ATOMIC:
- parse_omp_atomic ();
- break;
+ st = parse_omp_oacc_atomic (true);
+ continue;
default:
return st;
gfc_symtree *st;
gfc_symbol *old_sym;
- sym->attr.referenced = 1;
for (ns = siblings; ns; ns = ns->sibling)
{
st = gfc_find_symtree (ns->sym_root, sym->name);
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
goto fixup_contained;
+ if ((st->n.sym->attr.flavor == FL_DERIVED
+ && sym->attr.generic && sym->attr.function)
+ ||(sym->attr.flavor == FL_DERIVED
+ && st->n.sym->attr.generic && st->n.sym->attr.function))
+ goto fixup_contained;
+
old_sym = st->n.sym;
if (old_sym->ns == ns
&& !old_sym->attr.contained
|| old_sym->attr.intrinsic
|| old_sym->attr.generic
|| old_sym->attr.flavor == FL_NAMELIST
+ || old_sym->attr.flavor == FL_LABEL
|| old_sym->attr.proc == PROC_ST_FUNCTION))
{
/* Replace it with the symbol from the parent namespace. */
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
- gfc_error ("Contained procedure '%s' at %C is already "
+ gfc_error ("Contained procedure %qs at %C is already "
"ambiguous", gfc_new_block->name);
else
{
- if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
- &gfc_new_block->declared_at) ==
- SUCCESS)
+ if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
+ sym->name,
+ &gfc_new_block->declared_at))
{
if (st == ST_FUNCTION)
gfc_add_function (&sym->attr, sym->name,
/* Mark this as a contained function, so it isn't replaced
by other module functions. */
sym->attr.contained = 1;
- sym->attr.referenced = 1;
+
+ /* Set implicit_pure so that it can be reset if any of the
+ tests for purity fail. This is used for some optimisation
+ during translation. */
+ if (!sym->attr.pure)
+ sym->attr.implicit_pure = 1;
parse_progunit (ST_NONE);
/* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
+ case ST_END_SUBMODULE:
case ST_END_PROGRAM:
case ST_END_SUBROUTINE:
accept_statement (st);
+ gfc_current_ns->code = s1.head;
break;
default:
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
- && st != ST_END_MODULE && st != ST_END_PROGRAM);
+ && st != ST_END_MODULE && st != ST_END_SUBMODULE
+ && st != ST_END_PROGRAM);
/* The first namespace in the list is guaranteed to not have
anything (worthwhile) in it. */
pop_state ();
if (!contains_statements)
- gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
+ gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
"FUNCTION or SUBROUTINE statement at %C");
}
+/* The result variable in a MODULE PROCEDURE needs to be created and
+ its characteristics copied from the interface since it is neither
+ declared in the procedure declaration nor in the specification
+ part. */
+
+static void
+get_modproc_result (void)
+{
+ gfc_symbol *proc;
+ if (gfc_state_stack->previous
+ && gfc_state_stack->previous->state == COMP_CONTAINS
+ && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
+ {
+ proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
+ if (proc != NULL
+ && proc->attr.function
+ && proc->ts.interface
+ && proc->ts.interface->result
+ && proc->ts.interface->result != proc->ts.interface)
+ {
+ gfc_copy_dummy_sym (&proc->result, proc->ts.interface->result, 1);
+ gfc_set_sym_referenced (proc->result);
+ proc->result->attr.if_source = IFSRC_DECL;
+ gfc_commit_symbol (proc->result);
+ }
+ }
+}
+
+
/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
gfc_state_data *p;
int n;
+ if (gfc_new_block
+ && gfc_new_block->abr_modproc_decl
+ && gfc_new_block->attr.function)
+ get_modproc_result ();
+
st = parse_spec (st);
switch (st)
{
if (p->state == COMP_CONTAINS)
n++;
- if (gfc_find_state (COMP_MODULE) == SUCCESS)
+ if (gfc_find_state (COMP_MODULE) == true
+ || gfc_find_state (COMP_SUBMODULE) == true)
n--;
if (n > 0)
name = NULL;
}
- gfc_error("Global name '%s' at %L is already being used as a %s at %L",
- sym->name, where, name, &sym->where);
+ if (sym->binding_label)
+ gfc_error ("Global binding name %qs at %L is already being used as a %s "
+ "at %L", sym->binding_label, where, name, &sym->where);
+ else
+ gfc_error ("Global name %qs at %L is already being used as a %s at %L",
+ sym->name, where, name, &sym->where);
}
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
- gfc_global_used(s, NULL);
+ gfc_global_used (s, &gfc_new_block->declared_at);
else
{
s->type = GSYM_BLOCK_DATA;
- s->where = gfc_current_locus;
+ s->where = gfc_new_block->declared_at;
s->defined = 1;
}
}
}
+/* Following the association of the ancestor (sub)module symbols, they
+ must be set host rather than use associated and all must be public.
+ They are flagged up by 'used_in_submodule' so that they can be set
+ DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
+ linker chokes on multiple symbol definitions. */
+
+static void
+set_syms_host_assoc (gfc_symbol *sym)
+{
+ gfc_component *c;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->attr.module_procedure)
+ sym->attr.external = 0;
+
+/* sym->attr.access = ACCESS_PUBLIC; */
+
+ sym->attr.use_assoc = 0;
+ sym->attr.host_assoc = 1;
+ sym->attr.used_in_submodule =1;
+
+ if (sym->attr.flavor == FL_DERIVED)
+ {
+ for (c = sym->components; c; c = c->next)
+ c->attr.access = ACCESS_PUBLIC;
+ }
+}
+
/* Parse a module subprogram. */
static void
{
gfc_statement st;
gfc_gsymbol *s;
+ bool error;
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
- gfc_global_used(s, NULL);
+ gfc_global_used (s, &gfc_new_block->declared_at);
else
{
s->type = GSYM_MODULE;
- s->where = gfc_current_locus;
+ s->where = gfc_new_block->declared_at;
s->defined = 1;
}
+ /* Something is nulling the module_list after this point. This is good
+ since it allows us to 'USE' the parent modules that the submodule
+ inherits and to set (most) of the symbols as host associated. */
+ if (gfc_current_state () == COMP_SUBMODULE)
+ {
+ use_modules ();
+ gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
+ }
+
st = parse_spec (ST_NONE);
+ error = false;
loop:
switch (st)
{
break;
case ST_END_MODULE:
+ case ST_END_SUBMODULE:
accept_statement (st);
break;
gfc_error ("Unexpected %s statement in MODULE at %C",
gfc_ascii_statement (st));
+ error = true;
reject_statement ();
st = next_statement ();
goto loop;
}
- s->ns = gfc_current_ns;
+ /* Make sure not to free the namespace twice on error. */
+ if (!error)
+ s->ns = gfc_current_ns;
}
/* Add a procedure name to the global symbol table. */
static void
-add_global_procedure (int sub)
+add_global_procedure (bool sub)
{
gfc_gsymbol *s;
- s = gfc_get_gsymbol(gfc_new_block->name);
+ /* Only in Fortran 2003: For procedures with a binding label also the Fortran
+ name is a global identifier. */
+ if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
+ {
+ s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->defined
- || (s->type != GSYM_UNKNOWN
- && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
- gfc_global_used(s, NULL);
- else
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN
+ && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ {
+ gfc_global_used (s, &gfc_new_block->declared_at);
+ /* Silence follow-up errors. */
+ gfc_new_block->binding_label = NULL;
+ }
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->sym_name = gfc_new_block->name;
+ s->where = gfc_new_block->declared_at;
+ s->defined = 1;
+ s->ns = gfc_current_ns;
+ }
+ }
+
+ /* Don't add the symbol multiple times. */
+ if (gfc_new_block->binding_label
+ && (!gfc_notification_std (GFC_STD_F2008)
+ || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
{
- s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
- s->where = gfc_current_locus;
- s->defined = 1;
- s->ns = gfc_current_ns;
+ s = gfc_get_gsymbol (gfc_new_block->binding_label);
+
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN
+ && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ {
+ gfc_global_used (s, &gfc_new_block->declared_at);
+ /* Silence follow-up errors. */
+ gfc_new_block->binding_label = NULL;
+ }
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->sym_name = gfc_new_block->name;
+ s->binding_label = gfc_new_block->binding_label;
+ s->where = gfc_new_block->declared_at;
+ s->defined = 1;
+ s->ns = gfc_current_ns;
+ }
}
}
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
- gfc_global_used(s, NULL);
+ gfc_global_used (s, &gfc_new_block->declared_at);
else
{
s->type = GSYM_PROGRAM;
- s->where = gfc_current_locus;
+ s->where = gfc_new_block->declared_at;
s->defined = 1;
s->ns = gfc_current_ns;
}
}
-/* Resolve all the program units when whole file scope option
- is active. */
+/* Resolve all the program units. */
static void
resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
{
gfc_current_ns = gfc_global_ns_list;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ continue; /* Already resolved. */
+
+ if (gfc_current_ns->proc_name)
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_resolve (gfc_current_ns);
gfc_current_ns->derived_types = gfc_derived_types;
gfc_derived_types = NULL;
}
-/* Translate all the program units when whole file scope option
- is active. This could be in a different order to resolution if
- there are forward references in the file. */
+/* Translate all the program units. This could be in a different order
+ to resolution if there are forward references in the file. */
static void
translate_all_program_units (gfc_namespace *gfc_global_ns_list)
{
gfc_current_ns = gfc_global_ns_list;
gfc_get_errors (NULL, &errors);
+ /* We first translate all modules to make sure that later parts
+ of the program can use the decl. Then we translate the nonmodules. */
+
+ for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ if (!gfc_current_ns->proc_name
+ || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ continue;
+
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_generate_module_code (gfc_current_ns);
+ gfc_current_ns->translated = 1;
+ }
+
+ gfc_current_ns = gfc_global_ns_list;
for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ continue;
+
gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_derived_types = gfc_current_ns->derived_types;
gfc_generate_code (gfc_current_ns);
gfc_current_ns = gfc_global_ns_list;
for (;gfc_current_ns;)
{
- gfc_namespace *ns = gfc_current_ns->sibling;
+ gfc_namespace *ns;
+
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ gfc_current_ns = gfc_current_ns->sibling;
+ continue;
+ }
+
+ ns = gfc_current_ns->sibling;
gfc_derived_types = gfc_current_ns->derived_types;
gfc_done_2 ();
gfc_current_ns = ns;
/* Top level parser. */
-gfc_try
+bool
gfc_parse_file (void)
{
int seen_program, errors_before, errors;
gfc_statement_label = NULL;
if (setjmp (eof_buf))
- return FAILURE; /* Come here on unexpected EOF */
+ return false; /* Come here on unexpected EOF */
/* Prepare the global namespace that will contain the
program units. */
gfc_global_ns_list = next = NULL;
seen_program = 0;
+ errors_before = 0;
/* Exit early for empty files. */
if (gfc_at_eof ())
goto done;
+ in_specification_block = true;
loop:
gfc_init_2 ();
st = next_statement ();
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
- if (gfc_option.flag_whole_file)
- goto prog_units;
+ goto prog_units;
break;
case ST_SUBROUTINE:
- add_global_procedure (1);
+ add_global_procedure (true);
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
- if (gfc_option.flag_whole_file)
- goto prog_units;
+ goto prog_units;
break;
case ST_FUNCTION:
- add_global_procedure (0);
+ add_global_procedure (false);
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
- if (gfc_option.flag_whole_file)
- goto prog_units;
+ goto prog_units;
break;
case ST_BLOCK_DATA:
parse_module ();
break;
+ case ST_SUBMODULE:
+ push_state (&s, COMP_SUBMODULE, gfc_new_block);
+ accept_statement (st);
+
+ gfc_get_errors (NULL, &errors_before);
+ parse_module ();
+ break;
+
/* Anything else starts a nameless main program block. */
default:
if (seen_program)
push_state (&s, COMP_PROGRAM, gfc_new_block);
main_program_symbol (gfc_current_ns, "MAIN__");
parse_progunit (st);
- if (gfc_option.flag_whole_file)
- goto prog_units;
+ goto prog_units;
break;
}
gfc_resolve (gfc_current_ns);
/* Dump the parse tree if requested. */
- if (gfc_option.dump_parse_tree)
+ if (flag_dump_fortran_original)
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
- if (s.state == COMP_MODULE)
+ if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
- if (errors == 0)
- gfc_generate_module_code (gfc_current_ns);
- pop_state ();
- if (!gfc_option.flag_whole_file)
- gfc_done_2 ();
- else
- {
- gfc_current_ns->derived_types = gfc_derived_types;
- gfc_derived_types = NULL;
- gfc_current_ns = NULL;
- }
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ goto prog_units;
}
else
{
done:
- if (!gfc_option.flag_whole_file)
- goto termination;
-
/* Do the resolution. */
resolve_all_program_units (gfc_global_ns_list);
- /* Do the parse tree dump. */
+ /* Do the parse tree dump. */
gfc_current_ns
- = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+ = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_dump_parse_tree (gfc_current_ns, stdout);
- fputs ("------------------------------------------\n\n", stdout);
- }
+ if (!gfc_current_ns->proc_name
+ || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
+ {
+ gfc_dump_parse_tree (gfc_current_ns, stdout);
+ fputs ("------------------------------------------\n\n", stdout);
+ }
/* Do the translation. */
translate_all_program_units (gfc_global_ns_list);
-termination:
-
gfc_end_source_files ();
- return SUCCESS;
+ return true;
duplicate_main:
/* If we see a duplicate main program, shut down. If the second
gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
reject_statement ();
gfc_done_2 ();
- return SUCCESS;
+ return true;
+}
+
+/* Return true if this state data represents an OpenACC region. */
+bool
+is_oacc (gfc_state_data *sd)
+{
+ switch (sd->construct->op)
+ {
+ case EXEC_OACC_PARALLEL_LOOP:
+ case EXEC_OACC_PARALLEL:
+ case EXEC_OACC_KERNELS_LOOP:
+ case EXEC_OACC_KERNELS:
+ case EXEC_OACC_DATA:
+ case EXEC_OACC_HOST_DATA:
+ case EXEC_OACC_LOOP:
+ case EXEC_OACC_UPDATE:
+ case EXEC_OACC_WAIT:
+ case EXEC_OACC_CACHE:
+ case EXEC_OACC_ENTER_DATA:
+ case EXEC_OACC_EXIT_DATA:
+ case EXEC_OACC_ATOMIC:
+ case EXEC_OACC_ROUTINE:
+ return true;
+
+ default:
+ return false;
+ }
}
projects / thirdparty / gcc.git / blobdiff