mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-03 00:29:47 +00:00
7006 lines
180 KiB
C++
7006 lines
180 KiB
C++
/* Main parser.
|
||
Copyright (C) 2000-2022 Free Software Foundation, Inc.
|
||
Contributed by Andy Vaught
|
||
|
||
This file is part of GCC.
|
||
|
||
GCC is free software; you can redistribute it and/or modify it under
|
||
the terms of the GNU General Public License as published by the Free
|
||
Software Foundation; either version 3, or (at your option) any later
|
||
version.
|
||
|
||
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
||
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
||
for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with GCC; see the file COPYING3. If not see
|
||
<http://www.gnu.org/licenses/>. */
|
||
|
||
#include "config.h"
|
||
#include "system.h"
|
||
#include "coretypes.h"
|
||
#include "options.h"
|
||
#include "gfortran.h"
|
||
#include <setjmp.h>
|
||
#include "match.h"
|
||
#include "parse.h"
|
||
#include "tree-core.h"
|
||
#include "omp-general.h"
|
||
|
||
/* Current statement label. Zero means no statement label. Because new_st
|
||
can get wiped during statement matching, we have to keep it separate. */
|
||
|
||
gfc_st_label *gfc_statement_label;
|
||
|
||
static locus label_locus;
|
||
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);
|
||
static void undo_new_statement (void);
|
||
static void reject_statement (void);
|
||
|
||
|
||
/* A sort of half-matching function. We try to match the word on the
|
||
input with the passed string. If this succeeds, we call the
|
||
keyword-dependent matching function that will match the rest of the
|
||
statement. For single keywords, the matching subroutine is
|
||
gfc_match_eos(). */
|
||
|
||
static match
|
||
match_word (const char *str, match (*subr) (void), locus *old_locus)
|
||
{
|
||
match m;
|
||
|
||
if (str != NULL)
|
||
{
|
||
m = gfc_match (str);
|
||
if (m != MATCH_YES)
|
||
return m;
|
||
}
|
||
|
||
m = (*subr) ();
|
||
|
||
if (m != MATCH_YES)
|
||
{
|
||
gfc_current_locus = *old_locus;
|
||
reject_statement ();
|
||
}
|
||
|
||
return m;
|
||
}
|
||
|
||
|
||
/* 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_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) \
|
||
return st; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
|
||
/* This is a specialist version of decode_statement that is used
|
||
for the specification statements in a function, whose
|
||
characteristics are deferred into the specification statements.
|
||
eg.: INTEGER (king = mykind) foo ()
|
||
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
|
||
out of the correct kind of specification statements. */
|
||
static gfc_statement
|
||
decode_specification_statement (void)
|
||
{
|
||
gfc_statement st;
|
||
locus old_locus;
|
||
char c;
|
||
|
||
if (gfc_match_eos () == MATCH_YES)
|
||
return ST_NONE;
|
||
|
||
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);
|
||
|
||
if (gfc_current_block ()->result->ts.type != BT_DERIVED)
|
||
goto end_of_block;
|
||
|
||
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);
|
||
|
||
/* 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 ("abstract% interface", gfc_match_abstract_interface,
|
||
ST_INTERFACE);
|
||
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
|
||
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
|
||
match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'b':
|
||
match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'c':
|
||
match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
|
||
match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'd':
|
||
match ("data", gfc_match_data, ST_DATA);
|
||
match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'e':
|
||
match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
|
||
match ("entry% ", gfc_match_entry, ST_ENTRY);
|
||
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
|
||
match ("external", gfc_match_external, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'f':
|
||
match ("format", gfc_match_format, ST_FORMAT);
|
||
break;
|
||
|
||
case 'g':
|
||
break;
|
||
|
||
case 'i':
|
||
match ("implicit", gfc_match_implicit, ST_IMPLICIT);
|
||
match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
|
||
match ("interface", gfc_match_interface, ST_INTERFACE);
|
||
match ("intent", gfc_match_intent, ST_ATTR_DECL);
|
||
match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'm':
|
||
break;
|
||
|
||
case 'n':
|
||
match ("namelist", gfc_match_namelist, ST_NAMELIST);
|
||
break;
|
||
|
||
case 'o':
|
||
match ("optional", gfc_match_optional, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'p':
|
||
match ("parameter", gfc_match_parameter, ST_PARAMETER);
|
||
match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
|
||
if (gfc_match_private (&st) == MATCH_YES)
|
||
return st;
|
||
match ("procedure", gfc_match_procedure, ST_PROCEDURE);
|
||
if (gfc_match_public (&st) == MATCH_YES)
|
||
return st;
|
||
match ("protected", gfc_match_protected, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'r':
|
||
break;
|
||
|
||
case 's':
|
||
match ("save", gfc_match_save, ST_ATTR_DECL);
|
||
match ("static", gfc_match_static, ST_ATTR_DECL);
|
||
match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
|
||
break;
|
||
|
||
case 't':
|
||
match ("target", gfc_match_target, ST_ATTR_DECL);
|
||
match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
|
||
break;
|
||
|
||
case 'u':
|
||
break;
|
||
|
||
case 'v':
|
||
match ("value", gfc_match_value, ST_ATTR_DECL);
|
||
match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'w':
|
||
break;
|
||
}
|
||
|
||
/* This is not a specification statement. See if any of the matchers
|
||
has stored an error message of some sort. */
|
||
|
||
end_of_block:
|
||
gfc_clear_error ();
|
||
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_statement st;
|
||
locus old_locus;
|
||
match m = MATCH_NO;
|
||
char c;
|
||
|
||
gfc_enforce_clean_symbol_state ();
|
||
|
||
gfc_clear_error (); /* Clear any pending errors. */
|
||
gfc_clear_warning (); /* Clear any pending warnings. */
|
||
|
||
gfc_matching_function = false;
|
||
|
||
if (gfc_match_eos () == MATCH_YES)
|
||
return ST_NONE;
|
||
|
||
if (gfc_current_state () == COMP_FUNCTION
|
||
&& gfc_current_block ()->result->ts.kind == -1)
|
||
return decode_specification_statement ();
|
||
|
||
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. */
|
||
|
||
if (gfc_current_state () == COMP_NONE
|
||
|| gfc_current_state () == COMP_INTERFACE
|
||
|| gfc_current_state () == COMP_CONTAINS)
|
||
{
|
||
gfc_matching_function = true;
|
||
m = gfc_match_function_decl ();
|
||
if (m == MATCH_YES)
|
||
return ST_FUNCTION;
|
||
else if (m == MATCH_ERROR)
|
||
reject_statement ();
|
||
else
|
||
gfc_undo_symbols ();
|
||
gfc_current_locus = old_locus;
|
||
}
|
||
gfc_matching_function = false;
|
||
|
||
/* Legacy parameter statements are ambiguous with assignments so try parameter
|
||
first. */
|
||
match ("parameter", gfc_match_parameter, ST_PARAMETER);
|
||
|
||
/* Match statements whose error messages are meant to be overwritten
|
||
by something better. */
|
||
|
||
match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
|
||
match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
|
||
|
||
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);
|
||
|
||
/* Try to match a subroutine statement, which has the same optional
|
||
prefixes that functions can have. */
|
||
|
||
if (gfc_match_subroutine () == MATCH_YES)
|
||
return ST_SUBROUTINE;
|
||
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
|
||
the matcher is called. */
|
||
|
||
if (gfc_match_if (&st) == MATCH_YES)
|
||
return st;
|
||
gfc_undo_symbols ();
|
||
gfc_current_locus = old_locus;
|
||
|
||
if (gfc_match_where (&st) == MATCH_YES)
|
||
return st;
|
||
gfc_undo_symbols ();
|
||
gfc_current_locus = old_locus;
|
||
|
||
if (gfc_match_forall (&st) == MATCH_YES)
|
||
return st;
|
||
gfc_undo_symbols ();
|
||
gfc_current_locus = old_locus;
|
||
|
||
/* Try to match TYPE as an alias for PRINT. */
|
||
if (gfc_match_type (&st) == MATCH_YES)
|
||
return st;
|
||
gfc_undo_symbols ();
|
||
gfc_current_locus = old_locus;
|
||
|
||
match (NULL, gfc_match_do, ST_DO);
|
||
match (NULL, gfc_match_block, ST_BLOCK);
|
||
match (NULL, gfc_match_associate, ST_ASSOCIATE);
|
||
match (NULL, gfc_match_critical, ST_CRITICAL);
|
||
match (NULL, gfc_match_select, ST_SELECT_CASE);
|
||
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
|
||
match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
|
||
|
||
/* General statement matching: Instead of testing every possible
|
||
statement, we eliminate most possibilities by peeking at the
|
||
first character. */
|
||
|
||
switch (c)
|
||
{
|
||
case 'a':
|
||
match ("abstract% interface", gfc_match_abstract_interface,
|
||
ST_INTERFACE);
|
||
match ("allocate", gfc_match_allocate, ST_ALLOCATE);
|
||
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
|
||
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
|
||
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
|
||
match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'b':
|
||
match ("backspace", gfc_match_backspace, ST_BACKSPACE);
|
||
match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
|
||
match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'c':
|
||
match ("call", gfc_match_call, ST_CALL);
|
||
match ("change team", gfc_match_change_team, ST_CHANGE_TEAM);
|
||
match ("close", gfc_match_close, ST_CLOSE);
|
||
match ("continue", gfc_match_continue, ST_CONTINUE);
|
||
match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
|
||
match ("cycle", gfc_match_cycle, ST_CYCLE);
|
||
match ("case", gfc_match_case, ST_CASE);
|
||
match ("common", gfc_match_common, ST_COMMON);
|
||
match ("contains", gfc_match_eos, ST_CONTAINS);
|
||
match ("class", gfc_match_class_is, ST_CLASS_IS);
|
||
match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'd':
|
||
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
|
||
match ("data", gfc_match_data, ST_DATA);
|
||
match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'e':
|
||
match ("end file", gfc_match_endfile, ST_END_FILE);
|
||
match ("end team", gfc_match_end_team, ST_END_TEAM);
|
||
match ("exit", gfc_match_exit, ST_EXIT);
|
||
match ("else", gfc_match_else, ST_ELSE);
|
||
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
|
||
match ("else if", gfc_match_elseif, ST_ELSEIF);
|
||
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
|
||
match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
|
||
|
||
if (gfc_match_end (&st) == MATCH_YES)
|
||
return st;
|
||
|
||
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 ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
|
||
match ("final", gfc_match_final_decl, ST_FINAL);
|
||
match ("flush", gfc_match_flush, ST_FLUSH);
|
||
match ("form team", gfc_match_form_team, ST_FORM_TEAM);
|
||
match ("format", gfc_match_format, ST_FORMAT);
|
||
break;
|
||
|
||
case 'g':
|
||
match ("generic", gfc_match_generic, ST_GENERIC);
|
||
match ("go to", gfc_match_goto, ST_GOTO);
|
||
break;
|
||
|
||
case 'i':
|
||
match ("inquire", gfc_match_inquire, ST_INQUIRE);
|
||
match ("implicit", gfc_match_implicit, ST_IMPLICIT);
|
||
match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
|
||
match ("import", gfc_match_import, ST_IMPORT);
|
||
match ("interface", gfc_match_interface, ST_INTERFACE);
|
||
match ("intent", gfc_match_intent, ST_ATTR_DECL);
|
||
match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'l':
|
||
match ("lock", gfc_match_lock, ST_LOCK);
|
||
break;
|
||
|
||
case 'm':
|
||
match ("map", gfc_match_map, ST_MAP);
|
||
match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
|
||
match ("module", gfc_match_module, ST_MODULE);
|
||
break;
|
||
|
||
case 'n':
|
||
match ("nullify", gfc_match_nullify, ST_NULLIFY);
|
||
match ("namelist", gfc_match_namelist, ST_NAMELIST);
|
||
break;
|
||
|
||
case 'o':
|
||
match ("open", gfc_match_open, ST_OPEN);
|
||
match ("optional", gfc_match_optional, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'p':
|
||
match ("print", gfc_match_print, ST_WRITE);
|
||
match ("pause", gfc_match_pause, ST_PAUSE);
|
||
match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
|
||
if (gfc_match_private (&st) == MATCH_YES)
|
||
return st;
|
||
match ("procedure", gfc_match_procedure, ST_PROCEDURE);
|
||
match ("program", gfc_match_program, ST_PROGRAM);
|
||
if (gfc_match_public (&st) == MATCH_YES)
|
||
return st;
|
||
match ("protected", gfc_match_protected, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'r':
|
||
match ("rank", gfc_match_rank_is, ST_RANK);
|
||
match ("read", gfc_match_read, ST_READ);
|
||
match ("return", gfc_match_return, ST_RETURN);
|
||
match ("rewind", gfc_match_rewind, ST_REWIND);
|
||
break;
|
||
|
||
case 's':
|
||
match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
|
||
match ("sequence", gfc_match_eos, ST_SEQUENCE);
|
||
match ("stop", gfc_match_stop, ST_STOP);
|
||
match ("save", gfc_match_save, ST_ATTR_DECL);
|
||
match ("static", gfc_match_static, 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);
|
||
match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM);
|
||
break;
|
||
|
||
case 't':
|
||
match ("target", gfc_match_target, ST_ATTR_DECL);
|
||
match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
|
||
match ("type is", gfc_match_type_is, ST_TYPE_IS);
|
||
break;
|
||
|
||
case 'u':
|
||
match ("union", gfc_match_union, ST_UNION);
|
||
match ("unlock", gfc_match_unlock, ST_UNLOCK);
|
||
break;
|
||
|
||
case 'v':
|
||
match ("value", gfc_match_value, ST_ATTR_DECL);
|
||
match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
|
||
break;
|
||
|
||
case 'w':
|
||
match ("wait", gfc_match_wait, ST_WAIT);
|
||
match ("write", gfc_match_write, ST_WRITE);
|
||
break;
|
||
}
|
||
|
||
/* All else has failed, so give up. See if any of the matchers has
|
||
stored an error message of some sort. Suppress the "Unclassifiable
|
||
statement" if a previous error message was emitted, e.g., by
|
||
gfc_error_now (). */
|
||
if (!gfc_error_check ())
|
||
{
|
||
int ecnt;
|
||
gfc_get_errors (NULL, &ecnt);
|
||
if (ecnt <= 0)
|
||
gfc_error_now ("Unclassifiable statement at %C");
|
||
}
|
||
|
||
reject_statement ();
|
||
|
||
gfc_error_recovery ();
|
||
|
||
return ST_NONE;
|
||
}
|
||
|
||
/* Like match and if spec_only, goto do_spec_only without actually
|
||
matching. */
|
||
/* If the directive matched but the clauses failed, do not start
|
||
matching the next directive in the same switch statement. */
|
||
#define matcha(keyword, subr, st) \
|
||
do { \
|
||
match m2; \
|
||
if (spec_only && gfc_match (keyword) == MATCH_YES) \
|
||
goto do_spec_only; \
|
||
else if ((m2 = match_word (keyword, subr, &old_locus)) \
|
||
== MATCH_YES) \
|
||
return st; \
|
||
else if (m2 == MATCH_ERROR) \
|
||
goto error_handling; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
static gfc_statement
|
||
decode_oacc_directive (void)
|
||
{
|
||
locus old_locus;
|
||
char c;
|
||
bool spec_only = false;
|
||
|
||
gfc_enforce_clean_symbol_state ();
|
||
|
||
gfc_clear_error (); /* Clear any pending errors. */
|
||
gfc_clear_warning (); /* Clear any pending warnings. */
|
||
|
||
gfc_matching_function = false;
|
||
|
||
if (gfc_current_state () == COMP_FUNCTION
|
||
&& gfc_current_block ()->result->ts.kind == -1)
|
||
spec_only = true;
|
||
|
||
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 'r':
|
||
matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
|
||
break;
|
||
}
|
||
|
||
gfc_unset_implicit_pure (NULL);
|
||
if (gfc_pure (NULL))
|
||
{
|
||
gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
|
||
"procedures at %C");
|
||
goto error_handling;
|
||
}
|
||
|
||
switch (c)
|
||
{
|
||
case 'a':
|
||
matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
|
||
break;
|
||
case 'c':
|
||
matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
|
||
break;
|
||
case 'd':
|
||
matcha ("data", gfc_match_oacc_data, ST_OACC_DATA);
|
||
match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
|
||
break;
|
||
case 'e':
|
||
matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC);
|
||
matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA);
|
||
matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA);
|
||
matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP);
|
||
matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS);
|
||
matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP);
|
||
matcha ("end parallel loop", gfc_match_omp_eos_error,
|
||
ST_OACC_END_PARALLEL_LOOP);
|
||
matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL);
|
||
matcha ("end serial loop", gfc_match_omp_eos_error,
|
||
ST_OACC_END_SERIAL_LOOP);
|
||
matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL);
|
||
matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
|
||
matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
|
||
break;
|
||
case 'h':
|
||
matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
|
||
break;
|
||
case 'p':
|
||
matcha ("parallel loop", gfc_match_oacc_parallel_loop,
|
||
ST_OACC_PARALLEL_LOOP);
|
||
matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
|
||
break;
|
||
case 'k':
|
||
matcha ("kernels loop", gfc_match_oacc_kernels_loop,
|
||
ST_OACC_KERNELS_LOOP);
|
||
matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
|
||
break;
|
||
case 'l':
|
||
matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
|
||
break;
|
||
case 's':
|
||
matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
|
||
matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);
|
||
break;
|
||
case 'u':
|
||
matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
|
||
break;
|
||
case 'w':
|
||
matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
|
||
break;
|
||
}
|
||
|
||
/* Directive not found or stored an error message.
|
||
Check and give up. */
|
||
|
||
error_handling:
|
||
if (gfc_error_check () == 0)
|
||
gfc_error_now ("Unclassifiable OpenACC directive at %C");
|
||
|
||
reject_statement ();
|
||
|
||
gfc_error_recovery ();
|
||
|
||
return ST_NONE;
|
||
|
||
do_spec_only:
|
||
reject_statement ();
|
||
gfc_clear_error ();
|
||
gfc_buffer_error (false);
|
||
gfc_current_locus = old_locus;
|
||
return ST_GET_FCN_CHARACTERISTICS;
|
||
}
|
||
|
||
/* Like match, but set a flag simd_matched if keyword matched
|
||
and if spec_only, goto do_spec_only without actually matching. */
|
||
#define matchs(keyword, subr, st) \
|
||
do { \
|
||
match m2; \
|
||
if (spec_only && gfc_match (keyword) == MATCH_YES) \
|
||
goto do_spec_only; \
|
||
if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
|
||
&simd_matched)) == MATCH_YES) \
|
||
{ \
|
||
ret = st; \
|
||
goto finish; \
|
||
} \
|
||
else if (m2 == MATCH_ERROR) \
|
||
goto error_handling; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
/* Like match, but don't match anything if not -fopenmp
|
||
and if spec_only, goto do_spec_only without actually matching. */
|
||
/* If the directive matched but the clauses failed, do not start
|
||
matching the next directive in the same switch statement. */
|
||
#define matcho(keyword, subr, st) \
|
||
do { \
|
||
match m2; \
|
||
if (!flag_openmp) \
|
||
; \
|
||
else if (spec_only && gfc_match (keyword) == MATCH_YES) \
|
||
goto do_spec_only; \
|
||
else if ((m2 = match_word (keyword, subr, &old_locus)) \
|
||
== MATCH_YES) \
|
||
{ \
|
||
ret = st; \
|
||
goto finish; \
|
||
} \
|
||
else if (m2 == MATCH_ERROR) \
|
||
goto error_handling; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
/* Like match, but set a flag simd_matched if keyword matched. */
|
||
#define matchds(keyword, subr, st) \
|
||
do { \
|
||
match m2; \
|
||
if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
|
||
&simd_matched)) == MATCH_YES) \
|
||
{ \
|
||
ret = st; \
|
||
goto finish; \
|
||
} \
|
||
else if (m2 == MATCH_ERROR) \
|
||
goto error_handling; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
/* Like match, but don't match anything if not -fopenmp. */
|
||
#define matchdo(keyword, subr, st) \
|
||
do { \
|
||
match m2; \
|
||
if (!flag_openmp) \
|
||
; \
|
||
else if ((m2 = match_word (keyword, subr, &old_locus)) \
|
||
== MATCH_YES) \
|
||
{ \
|
||
ret = st; \
|
||
goto finish; \
|
||
} \
|
||
else if (m2 == MATCH_ERROR) \
|
||
goto error_handling; \
|
||
else \
|
||
undo_new_statement (); \
|
||
} while (0)
|
||
|
||
static gfc_statement
|
||
decode_omp_directive (void)
|
||
{
|
||
locus old_locus;
|
||
char c;
|
||
bool simd_matched = false;
|
||
bool spec_only = false;
|
||
gfc_statement ret = ST_NONE;
|
||
bool pure_ok = true;
|
||
|
||
gfc_enforce_clean_symbol_state ();
|
||
|
||
gfc_clear_error (); /* Clear any pending errors. */
|
||
gfc_clear_warning (); /* Clear any pending warnings. */
|
||
|
||
gfc_matching_function = false;
|
||
|
||
if (gfc_current_state () == COMP_FUNCTION
|
||
&& gfc_current_block ()->result->ts.kind == -1)
|
||
spec_only = true;
|
||
|
||
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_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.
|
||
Handle only the directives allowed in PURE procedures
|
||
first (those also shall not turn off implicit pure). */
|
||
switch (c)
|
||
{
|
||
case 'd':
|
||
matchds ("declare simd", gfc_match_omp_declare_simd,
|
||
ST_OMP_DECLARE_SIMD);
|
||
matchdo ("declare target", gfc_match_omp_declare_target,
|
||
ST_OMP_DECLARE_TARGET);
|
||
matchdo ("declare variant", gfc_match_omp_declare_variant,
|
||
ST_OMP_DECLARE_VARIANT);
|
||
break;
|
||
case 's':
|
||
matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
|
||
break;
|
||
}
|
||
|
||
pure_ok = false;
|
||
if (flag_openmp && gfc_pure (NULL))
|
||
{
|
||
gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
|
||
"at %C may not appear in PURE procedures");
|
||
gfc_error_recovery ();
|
||
return ST_NONE;
|
||
}
|
||
|
||
/* 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':
|
||
matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
|
||
break;
|
||
case 'b':
|
||
matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
|
||
break;
|
||
case 'c':
|
||
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':
|
||
matchds ("declare reduction", gfc_match_omp_declare_reduction,
|
||
ST_OMP_DECLARE_REDUCTION);
|
||
matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
|
||
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':
|
||
matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
|
||
matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
|
||
matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
|
||
matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
|
||
matcho ("end distribute parallel do", gfc_match_omp_eos_error,
|
||
ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
|
||
matchs ("end distribute simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_DISTRIBUTE_SIMD);
|
||
matcho ("end distribute", gfc_match_omp_eos_error, 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);
|
||
matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP);
|
||
matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
|
||
matcho ("end masked taskloop simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_MASKED_TASKLOOP_SIMD);
|
||
matcho ("end masked taskloop", gfc_match_omp_eos_error,
|
||
ST_OMP_END_MASKED_TASKLOOP);
|
||
matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED);
|
||
matcho ("end master taskloop simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_MASTER_TASKLOOP_SIMD);
|
||
matcho ("end master taskloop", gfc_match_omp_eos_error,
|
||
ST_OMP_END_MASTER_TASKLOOP);
|
||
matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
|
||
matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
|
||
matchs ("end parallel do simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_DO_SIMD);
|
||
matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO);
|
||
matcho ("end parallel loop", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_LOOP);
|
||
matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD);
|
||
matcho ("end parallel masked taskloop", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASKED_TASKLOOP);
|
||
matcho ("end parallel masked", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASKED);
|
||
matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD);
|
||
matcho ("end parallel master taskloop", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASTER_TASKLOOP);
|
||
matcho ("end parallel master", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_MASTER);
|
||
matcho ("end parallel sections", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_SECTIONS);
|
||
matcho ("end parallel workshare", gfc_match_omp_eos_error,
|
||
ST_OMP_END_PARALLEL_WORKSHARE);
|
||
matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
|
||
matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE);
|
||
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_error, ST_OMP_END_TARGET_DATA);
|
||
matchs ("end target parallel do simd", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
|
||
matcho ("end target parallel do", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_PARALLEL_DO);
|
||
matcho ("end target parallel loop", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_PARALLEL_LOOP);
|
||
matcho ("end target parallel", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_PARALLEL);
|
||
matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD);
|
||
matchs ("end target teams distribute parallel do simd",
|
||
gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
|
||
matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
|
||
matchs ("end target teams distribute simd", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
|
||
matcho ("end target teams distribute", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
|
||
matcho ("end target teams loop", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS_LOOP);
|
||
matcho ("end target teams", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_TARGET_TEAMS);
|
||
matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET);
|
||
matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
|
||
matchs ("end taskloop simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_TASKLOOP_SIMD);
|
||
matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
|
||
matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK);
|
||
matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
|
||
matcho ("end teams distribute parallel do", gfc_match_omp_eos_error,
|
||
ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
|
||
matchs ("end teams distribute simd", gfc_match_omp_eos_error,
|
||
ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
|
||
matcho ("end teams distribute", gfc_match_omp_eos_error,
|
||
ST_OMP_END_TEAMS_DISTRIBUTE);
|
||
matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP);
|
||
matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS);
|
||
matcho ("end workshare", gfc_match_omp_end_nowait,
|
||
ST_OMP_END_WORKSHARE);
|
||
break;
|
||
case 'f':
|
||
matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
|
||
break;
|
||
case 'm':
|
||
matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd,
|
||
ST_OMP_MASKED_TASKLOOP_SIMD);
|
||
matcho ("masked taskloop", gfc_match_omp_masked_taskloop,
|
||
ST_OMP_MASKED_TASKLOOP);
|
||
matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED);
|
||
matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd,
|
||
ST_OMP_MASTER_TASKLOOP_SIMD);
|
||
matcho ("master taskloop", gfc_match_omp_master_taskloop,
|
||
ST_OMP_MASTER_TASKLOOP);
|
||
matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
|
||
break;
|
||
case 'n':
|
||
matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
|
||
break;
|
||
case 'l':
|
||
matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP);
|
||
break;
|
||
case 'o':
|
||
if (gfc_match ("ordered depend (") == MATCH_YES)
|
||
{
|
||
gfc_current_locus = old_locus;
|
||
if (!flag_openmp)
|
||
break;
|
||
matcho ("ordered", gfc_match_omp_ordered_depend,
|
||
ST_OMP_ORDERED_DEPEND);
|
||
}
|
||
else
|
||
matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
|
||
break;
|
||
case 'p':
|
||
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 loop", gfc_match_omp_parallel_loop,
|
||
ST_OMP_PARALLEL_LOOP);
|
||
matcho ("parallel masked taskloop simd",
|
||
gfc_match_omp_parallel_masked_taskloop_simd,
|
||
ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD);
|
||
matcho ("parallel masked taskloop",
|
||
gfc_match_omp_parallel_masked_taskloop,
|
||
ST_OMP_PARALLEL_MASKED_TASKLOOP);
|
||
matcho ("parallel masked", gfc_match_omp_parallel_masked,
|
||
ST_OMP_PARALLEL_MASKED);
|
||
matcho ("parallel master taskloop simd",
|
||
gfc_match_omp_parallel_master_taskloop_simd,
|
||
ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD);
|
||
matcho ("parallel master taskloop",
|
||
gfc_match_omp_parallel_master_taskloop,
|
||
ST_OMP_PARALLEL_MASTER_TASKLOOP);
|
||
matcho ("parallel master", gfc_match_omp_parallel_master,
|
||
ST_OMP_PARALLEL_MASTER);
|
||
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 'r':
|
||
matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES);
|
||
break;
|
||
case 's':
|
||
matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN);
|
||
matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE);
|
||
matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
|
||
matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
|
||
matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
|
||
break;
|
||
case 't':
|
||
matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
|
||
matcho ("target enter data", gfc_match_omp_target_enter_data,
|
||
ST_OMP_TARGET_ENTER_DATA);
|
||
matcho ("target exit data", gfc_match_omp_target_exit_data,
|
||
ST_OMP_TARGET_EXIT_DATA);
|
||
matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
|
||
ST_OMP_TARGET_PARALLEL_DO_SIMD);
|
||
matcho ("target parallel do", gfc_match_omp_target_parallel_do,
|
||
ST_OMP_TARGET_PARALLEL_DO);
|
||
matcho ("target parallel loop", gfc_match_omp_target_parallel_loop,
|
||
ST_OMP_TARGET_PARALLEL_LOOP);
|
||
matcho ("target parallel", gfc_match_omp_target_parallel,
|
||
ST_OMP_TARGET_PARALLEL);
|
||
matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
|
||
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 loop", gfc_match_omp_target_teams_loop,
|
||
ST_OMP_TARGET_TEAMS_LOOP);
|
||
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);
|
||
matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
|
||
ST_OMP_TASKLOOP_SIMD);
|
||
matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
|
||
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 loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP);
|
||
matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
|
||
matchdo ("threadprivate", gfc_match_omp_threadprivate,
|
||
ST_OMP_THREADPRIVATE);
|
||
break;
|
||
case 'w':
|
||
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. 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. */
|
||
|
||
error_handling:
|
||
if (flag_openmp || simd_matched)
|
||
{
|
||
if (!gfc_error_check ())
|
||
gfc_error_now ("Unclassifiable OpenMP directive at %C");
|
||
}
|
||
|
||
reject_statement ();
|
||
|
||
gfc_error_recovery ();
|
||
|
||
return ST_NONE;
|
||
|
||
finish:
|
||
if (!pure_ok)
|
||
{
|
||
gfc_unset_implicit_pure (NULL);
|
||
|
||
if (!flag_openmp && gfc_pure (NULL))
|
||
{
|
||
gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
|
||
"at %C may not appear in PURE procedures");
|
||
reject_statement ();
|
||
gfc_error_recovery ();
|
||
return ST_NONE;
|
||
}
|
||
}
|
||
switch (ret)
|
||
{
|
||
case ST_OMP_DECLARE_TARGET:
|
||
case ST_OMP_TARGET:
|
||
case ST_OMP_TARGET_DATA:
|
||
case ST_OMP_TARGET_ENTER_DATA:
|
||
case ST_OMP_TARGET_EXIT_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_TARGET_TEAMS_LOOP:
|
||
case ST_OMP_TARGET_PARALLEL:
|
||
case ST_OMP_TARGET_PARALLEL_DO:
|
||
case ST_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
case ST_OMP_TARGET_PARALLEL_LOOP:
|
||
case ST_OMP_TARGET_SIMD:
|
||
case ST_OMP_TARGET_UPDATE:
|
||
{
|
||
gfc_namespace *prog_unit = gfc_current_ns;
|
||
while (prog_unit->parent)
|
||
{
|
||
if (gfc_state_stack->previous
|
||
&& gfc_state_stack->previous->state == COMP_INTERFACE)
|
||
break;
|
||
prog_unit = prog_unit->parent;
|
||
}
|
||
prog_unit->omp_target_seen = true;
|
||
break;
|
||
}
|
||
case ST_OMP_ERROR:
|
||
if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
|
||
return ST_NONE;
|
||
default:
|
||
break;
|
||
}
|
||
return ret;
|
||
|
||
do_spec_only:
|
||
reject_statement ();
|
||
gfc_clear_error ();
|
||
gfc_buffer_error (false);
|
||
gfc_current_locus = old_locus;
|
||
return ST_GET_FCN_CHARACTERISTICS;
|
||
}
|
||
|
||
static gfc_statement
|
||
decode_gcc_attribute (void)
|
||
{
|
||
locus old_locus;
|
||
|
||
gfc_enforce_clean_symbol_state ();
|
||
|
||
gfc_clear_error (); /* Clear any pending errors. */
|
||
gfc_clear_warning (); /* Clear any pending warnings. */
|
||
old_locus = gfc_current_locus;
|
||
|
||
match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
|
||
match ("unroll", gfc_match_gcc_unroll, ST_NONE);
|
||
match ("builtin", gfc_match_gcc_builtin, ST_NONE);
|
||
match ("ivdep", gfc_match_gcc_ivdep, ST_NONE);
|
||
match ("vector", gfc_match_gcc_vector, ST_NONE);
|
||
match ("novector", gfc_match_gcc_novector, ST_NONE);
|
||
|
||
/* 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 ())
|
||
{
|
||
if (pedantic)
|
||
gfc_error_now ("Unclassifiable GCC directive at %C");
|
||
else
|
||
gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
|
||
}
|
||
|
||
reject_statement ();
|
||
|
||
gfc_error_recovery ();
|
||
|
||
return ST_NONE;
|
||
}
|
||
|
||
#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. */
|
||
|
||
static gfc_statement
|
||
next_free (void)
|
||
{
|
||
match m;
|
||
int i, cnt, at_bol;
|
||
char c;
|
||
|
||
at_bol = gfc_at_bol ();
|
||
gfc_gobble_whitespace ();
|
||
|
||
c = gfc_peek_ascii_char ();
|
||
|
||
if (ISDIGIT (c))
|
||
{
|
||
char d;
|
||
|
||
/* Found a statement label? */
|
||
m = gfc_match_st_label (&gfc_statement_label);
|
||
|
||
d = gfc_peek_ascii_char ();
|
||
if (m != MATCH_YES || !gfc_is_whitespace (d))
|
||
{
|
||
gfc_match_small_literal_int (&i, &cnt);
|
||
|
||
if (cnt > 5)
|
||
gfc_error_now ("Too many digits in statement label at %C");
|
||
|
||
if (i == 0)
|
||
gfc_error_now ("Zero is not a valid statement label at %C");
|
||
|
||
do
|
||
c = gfc_next_ascii_char ();
|
||
while (ISDIGIT(c));
|
||
|
||
if (!gfc_is_whitespace (c))
|
||
gfc_error_now ("Non-numeric character in statement label at %C");
|
||
|
||
return ST_NONE;
|
||
}
|
||
else
|
||
{
|
||
label_locus = gfc_current_locus;
|
||
|
||
gfc_gobble_whitespace ();
|
||
|
||
if (at_bol && gfc_peek_ascii_char () == ';')
|
||
{
|
||
gfc_error_now ("Semicolon at %C needs to be preceded by "
|
||
"statement");
|
||
gfc_next_ascii_char (); /* Eat up the semicolon. */
|
||
return ST_NONE;
|
||
}
|
||
|
||
if (gfc_match_eos () == MATCH_YES)
|
||
gfc_error_now ("Statement label without statement at %L",
|
||
&label_locus);
|
||
}
|
||
}
|
||
else if (c == '!')
|
||
{
|
||
/* Comments have already been skipped by the time we get here,
|
||
except for GCC attributes and OpenMP/OpenACC directives. */
|
||
|
||
gfc_next_ascii_char (); /* Eat up the exclamation sign. */
|
||
c = gfc_peek_ascii_char ();
|
||
|
||
if (c == 'g')
|
||
{
|
||
int i;
|
||
|
||
c = gfc_next_ascii_char ();
|
||
for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
|
||
gcc_assert (c == "gcc$"[i]);
|
||
|
||
gfc_gobble_whitespace ();
|
||
return decode_gcc_attribute ();
|
||
|
||
}
|
||
else if (c == '$')
|
||
{
|
||
/* 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 ();
|
||
|
||
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 ();
|
||
}
|
||
|
||
if (at_bol && c == ';')
|
||
{
|
||
if (!(gfc_option.allow_std & GFC_STD_F2008))
|
||
gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
|
||
"statement");
|
||
gfc_next_ascii_char (); /* Eat up the semicolon. */
|
||
return ST_NONE;
|
||
}
|
||
|
||
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. */
|
||
|
||
static gfc_statement
|
||
next_fixed (void)
|
||
{
|
||
int label, digit_flag, i;
|
||
locus loc;
|
||
gfc_char_t c;
|
||
|
||
if (!gfc_at_bol ())
|
||
return decode_statement ();
|
||
|
||
/* Skip past the current label field, parsing a statement label if
|
||
one is there. This is a weird number parser, since the number is
|
||
contained within five columns and can have any kind of embedded
|
||
spaces. We also check for characters that make the rest of the
|
||
line a comment. */
|
||
|
||
label = 0;
|
||
digit_flag = 0;
|
||
|
||
for (i = 0; i < 5; i++)
|
||
{
|
||
c = gfc_next_char_literal (NONSTRING);
|
||
|
||
switch (c)
|
||
{
|
||
case ' ':
|
||
break;
|
||
|
||
case '0':
|
||
case '1':
|
||
case '2':
|
||
case '3':
|
||
case '4':
|
||
case '5':
|
||
case '6':
|
||
case '7':
|
||
case '8':
|
||
case '9':
|
||
label = label * 10 + ((unsigned char) c - '0');
|
||
label_locus = gfc_current_locus;
|
||
digit_flag = 1;
|
||
break;
|
||
|
||
/* Comments have already been skipped by the time we get
|
||
here, except for GCC attributes and OpenMP directives. */
|
||
|
||
case '*':
|
||
c = gfc_next_char_literal (NONSTRING);
|
||
|
||
if (TOLOWER (c) == 'g')
|
||
{
|
||
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 == '$')
|
||
{
|
||
if ((flag_openmp || flag_openmp_simd)
|
||
&& !flag_openacc)
|
||
{
|
||
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 ();
|
||
}
|
||
}
|
||
gcc_fallthrough ();
|
||
|
||
/* Comments have already been skipped by the time we get
|
||
here so don't bother checking for them. */
|
||
|
||
default:
|
||
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 (0, "Zero is not a valid statement label at %C");
|
||
else
|
||
{
|
||
/* We've found a valid statement label. */
|
||
gfc_statement_label = gfc_get_st_label (label);
|
||
}
|
||
}
|
||
|
||
/* Since this line starts a statement, it cannot be a continuation
|
||
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 (NONSTRING);
|
||
if (c == '\n')
|
||
goto blank_line;
|
||
|
||
if (c != ' ' && c != '0')
|
||
{
|
||
gfc_buffer_error (false);
|
||
gfc_error ("Bad continuation line at %C");
|
||
return ST_NONE;
|
||
}
|
||
|
||
/* Now that we've taken care of the statement label columns, we have
|
||
to make sure that the first nonblank character is not a '!'. If
|
||
it is, the rest of the line is a comment. */
|
||
|
||
do
|
||
{
|
||
loc = gfc_current_locus;
|
||
c = gfc_next_char_literal (NONSTRING);
|
||
}
|
||
while (gfc_is_whitespace (c));
|
||
|
||
if (c == '!')
|
||
goto blank_line;
|
||
gfc_current_locus = loc;
|
||
|
||
if (c == ';')
|
||
{
|
||
if (digit_flag)
|
||
gfc_error_now ("Semicolon at %C needs to be preceded by statement");
|
||
else if (!(gfc_option.allow_std & GFC_STD_F2008))
|
||
gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
|
||
"statement");
|
||
return ST_NONE;
|
||
}
|
||
|
||
if (gfc_match_eos () == MATCH_YES)
|
||
goto blank_line;
|
||
|
||
/* At this point, we've got a nonblank statement to parse. */
|
||
return decode_statement ();
|
||
|
||
blank_line:
|
||
if (digit_flag)
|
||
gfc_error_now ("Statement label without statement at %L", &label_locus);
|
||
|
||
gfc_current_locus.lb->truncated = 0;
|
||
gfc_advance_line ();
|
||
return ST_NONE;
|
||
}
|
||
|
||
|
||
/* Return the next non-ST_NONE statement to the caller. We also worry
|
||
about including files and the ends of include files at this stage. */
|
||
|
||
static gfc_statement
|
||
next_statement (void)
|
||
{
|
||
gfc_statement st;
|
||
locus old_locus;
|
||
|
||
gfc_enforce_clean_symbol_state ();
|
||
|
||
gfc_new_block = NULL;
|
||
|
||
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 (true);
|
||
|
||
if (gfc_at_eol ())
|
||
gfc_advance_line ();
|
||
|
||
gfc_skip_comments ();
|
||
|
||
if (gfc_at_end ())
|
||
{
|
||
st = ST_NONE;
|
||
break;
|
||
}
|
||
|
||
if (gfc_define_undef_line ())
|
||
continue;
|
||
|
||
old_locus = gfc_current_locus;
|
||
|
||
st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
|
||
|
||
if (st != ST_NONE)
|
||
break;
|
||
}
|
||
|
||
gfc_buffer_error (false);
|
||
|
||
if (st == ST_GET_FCN_CHARACTERISTICS)
|
||
{
|
||
if (gfc_statement_label != NULL)
|
||
{
|
||
gfc_free_st_label (gfc_statement_label);
|
||
gfc_statement_label = NULL;
|
||
}
|
||
gfc_current_locus = old_locus;
|
||
}
|
||
|
||
if (st != ST_NONE)
|
||
check_statement_label (st);
|
||
|
||
return st;
|
||
}
|
||
|
||
|
||
/****************************** Parser ***********************************/
|
||
|
||
/* The parser subroutines are of type 'try' that fail if the file ends
|
||
unexpectedly. */
|
||
|
||
/* Macros that expand to case-labels for various classes of
|
||
statements. Start with executable statements that directly do
|
||
things. */
|
||
|
||
#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
|
||
case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
|
||
case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
|
||
case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
|
||
case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
|
||
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_OMP_TASKYIELD: \
|
||
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
|
||
case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
|
||
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
|
||
case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
|
||
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
|
||
case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
|
||
case ST_END_TEAM: case ST_SYNC_TEAM: \
|
||
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
|
||
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. */
|
||
|
||
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
|
||
case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
|
||
case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
|
||
case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
|
||
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
|
||
case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
|
||
case ST_OMP_MASKED_TASKLOOP_SIMD: \
|
||
case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
|
||
case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: 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_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_OMP_TARGET_PARALLEL: \
|
||
case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
|
||
case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
|
||
case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
|
||
case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
|
||
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_SERIAL_LOOP: case ST_OACC_SERIAL: \
|
||
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_PROCEDURE
|
||
|
||
/* OpenMP and OpenACC declaration statements, which may appear anywhere in
|
||
the specification part. */
|
||
|
||
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
|
||
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
|
||
case ST_OMP_DECLARE_VARIANT: \
|
||
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
|
||
|
||
/* Block end statements. Errors associated with interchanging these
|
||
are detected in gfc_match_end(). */
|
||
|
||
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
|
||
case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
|
||
case ST_END_BLOCK: case ST_END_ASSOCIATE
|
||
|
||
|
||
/* Push a new state onto the stack. */
|
||
|
||
static void
|
||
push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
|
||
{
|
||
p->state = new_state;
|
||
p->previous = gfc_state_stack;
|
||
p->sym = sym;
|
||
p->head = p->tail = NULL;
|
||
p->do_variable = NULL;
|
||
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,
|
||
the construct's gfc_code is available as tail of the parent state. */
|
||
gcc_assert (gfc_state_stack);
|
||
p->construct = gfc_state_stack->tail;
|
||
|
||
gfc_state_stack = p;
|
||
}
|
||
|
||
|
||
/* Pop the current state. */
|
||
static void
|
||
pop_state (void)
|
||
{
|
||
gfc_state_stack = gfc_state_stack->previous;
|
||
}
|
||
|
||
|
||
/* Try to find the given state in the state stack. */
|
||
|
||
bool
|
||
gfc_find_state (gfc_compile_state state)
|
||
{
|
||
gfc_state_data *p;
|
||
|
||
for (p = gfc_state_stack; p; p = p->previous)
|
||
if (p->state == state)
|
||
break;
|
||
|
||
return (p == NULL) ? false : true;
|
||
}
|
||
|
||
|
||
/* Starts a new level in the statement list. */
|
||
|
||
static gfc_code *
|
||
new_level (gfc_code *q)
|
||
{
|
||
gfc_code *p;
|
||
|
||
p = q->block = gfc_get_code (EXEC_NOP);
|
||
|
||
gfc_state_stack->head = gfc_state_stack->tail = p;
|
||
|
||
return p;
|
||
}
|
||
|
||
|
||
/* Add the current new_st code structure and adds it to the current
|
||
program unit. As a side-effect, it zeroes the new_st. */
|
||
|
||
static gfc_code *
|
||
add_statement (void)
|
||
{
|
||
gfc_code *p;
|
||
|
||
p = XCNEW (gfc_code);
|
||
*p = new_st;
|
||
|
||
p->loc = gfc_current_locus;
|
||
|
||
if (gfc_state_stack->head == NULL)
|
||
gfc_state_stack->head = p;
|
||
else
|
||
gfc_state_stack->tail->next = p;
|
||
|
||
while (p->next != NULL)
|
||
p = p->next;
|
||
|
||
gfc_state_stack->tail = p;
|
||
|
||
gfc_clear_new_st ();
|
||
|
||
return p;
|
||
}
|
||
|
||
|
||
/* Frees everything associated with the current statement. */
|
||
|
||
static void
|
||
undo_new_statement (void)
|
||
{
|
||
gfc_free_statements (new_st.block);
|
||
gfc_free_statements (new_st.next);
|
||
gfc_free_statement (&new_st);
|
||
gfc_clear_new_st ();
|
||
}
|
||
|
||
|
||
/* If the current statement has a statement label, make sure that it
|
||
is allowed to, or should have one. */
|
||
|
||
static void
|
||
check_statement_label (gfc_statement st)
|
||
{
|
||
gfc_sl_type type;
|
||
|
||
if (gfc_statement_label == NULL)
|
||
{
|
||
if (st == ST_FORMAT)
|
||
gfc_error ("FORMAT statement at %L does not have a statement label",
|
||
&new_st.loc);
|
||
return;
|
||
}
|
||
|
||
switch (st)
|
||
{
|
||
case ST_END_PROGRAM:
|
||
case ST_END_FUNCTION:
|
||
case ST_END_SUBROUTINE:
|
||
case ST_ENDDO:
|
||
case ST_ENDIF:
|
||
case ST_END_SELECT:
|
||
case ST_END_CRITICAL:
|
||
case ST_END_BLOCK:
|
||
case ST_END_ASSOCIATE:
|
||
case_executable:
|
||
case_exec_markers:
|
||
if (st == ST_ENDDO || st == ST_CONTINUE)
|
||
type = ST_LABEL_DO_TARGET;
|
||
else
|
||
type = ST_LABEL_TARGET;
|
||
break;
|
||
|
||
case ST_FORMAT:
|
||
type = ST_LABEL_FORMAT;
|
||
break;
|
||
|
||
/* Statement labels are not restricted from appearing on a
|
||
particular line. However, there are plenty of situations
|
||
where the resulting label can't be referenced. */
|
||
|
||
default:
|
||
type = ST_LABEL_BAD_TARGET;
|
||
break;
|
||
}
|
||
|
||
gfc_define_st_label (gfc_statement_label, type, &label_locus);
|
||
|
||
new_st.here = gfc_statement_label;
|
||
}
|
||
|
||
|
||
/* Figures out what the enclosing program unit is. This will be a
|
||
function, subroutine, program, block data or module. */
|
||
|
||
gfc_state_data *
|
||
gfc_enclosing_unit (gfc_compile_state * result)
|
||
{
|
||
gfc_state_data *p;
|
||
|
||
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_SUBMODULE
|
||
|| p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
|
||
{
|
||
|
||
if (result != NULL)
|
||
*result = p->state;
|
||
return p;
|
||
}
|
||
|
||
if (result != NULL)
|
||
*result = COMP_PROGRAM;
|
||
return NULL;
|
||
}
|
||
|
||
|
||
/* Translate a statement enum to a string. */
|
||
|
||
const char *
|
||
gfc_ascii_statement (gfc_statement st)
|
||
{
|
||
const char *p;
|
||
|
||
switch (st)
|
||
{
|
||
case ST_ARITHMETIC_IF:
|
||
p = _("arithmetic IF");
|
||
break;
|
||
case ST_ALLOCATE:
|
||
p = "ALLOCATE";
|
||
break;
|
||
case ST_ASSOCIATE:
|
||
p = "ASSOCIATE";
|
||
break;
|
||
case ST_ATTR_DECL:
|
||
p = _("attribute declaration");
|
||
break;
|
||
case ST_BACKSPACE:
|
||
p = "BACKSPACE";
|
||
break;
|
||
case ST_BLOCK:
|
||
p = "BLOCK";
|
||
break;
|
||
case ST_BLOCK_DATA:
|
||
p = "BLOCK DATA";
|
||
break;
|
||
case ST_CALL:
|
||
p = "CALL";
|
||
break;
|
||
case ST_CASE:
|
||
p = "CASE";
|
||
break;
|
||
case ST_CLOSE:
|
||
p = "CLOSE";
|
||
break;
|
||
case ST_COMMON:
|
||
p = "COMMON";
|
||
break;
|
||
case ST_CONTINUE:
|
||
p = "CONTINUE";
|
||
break;
|
||
case ST_CONTAINS:
|
||
p = "CONTAINS";
|
||
break;
|
||
case ST_CRITICAL:
|
||
p = "CRITICAL";
|
||
break;
|
||
case ST_CYCLE:
|
||
p = "CYCLE";
|
||
break;
|
||
case ST_DATA_DECL:
|
||
p = _("data declaration");
|
||
break;
|
||
case ST_DATA:
|
||
p = "DATA";
|
||
break;
|
||
case ST_DEALLOCATE:
|
||
p = "DEALLOCATE";
|
||
break;
|
||
case ST_MAP:
|
||
p = "MAP";
|
||
break;
|
||
case ST_UNION:
|
||
p = "UNION";
|
||
break;
|
||
case ST_STRUCTURE_DECL:
|
||
p = "STRUCTURE";
|
||
break;
|
||
case ST_DERIVED_DECL:
|
||
p = _("derived type declaration");
|
||
break;
|
||
case ST_DO:
|
||
p = "DO";
|
||
break;
|
||
case ST_ELSE:
|
||
p = "ELSE";
|
||
break;
|
||
case ST_ELSEIF:
|
||
p = "ELSE IF";
|
||
break;
|
||
case ST_ELSEWHERE:
|
||
p = "ELSEWHERE";
|
||
break;
|
||
case ST_EVENT_POST:
|
||
p = "EVENT POST";
|
||
break;
|
||
case ST_EVENT_WAIT:
|
||
p = "EVENT WAIT";
|
||
break;
|
||
case ST_FAIL_IMAGE:
|
||
p = "FAIL IMAGE";
|
||
break;
|
||
case ST_CHANGE_TEAM:
|
||
p = "CHANGE TEAM";
|
||
break;
|
||
case ST_END_TEAM:
|
||
p = "END TEAM";
|
||
break;
|
||
case ST_FORM_TEAM:
|
||
p = "FORM TEAM";
|
||
break;
|
||
case ST_SYNC_TEAM:
|
||
p = "SYNC TEAM";
|
||
break;
|
||
case ST_END_ASSOCIATE:
|
||
p = "END ASSOCIATE";
|
||
break;
|
||
case ST_END_BLOCK:
|
||
p = "END BLOCK";
|
||
break;
|
||
case ST_END_BLOCK_DATA:
|
||
p = "END BLOCK DATA";
|
||
break;
|
||
case ST_END_CRITICAL:
|
||
p = "END CRITICAL";
|
||
break;
|
||
case ST_ENDDO:
|
||
p = "END DO";
|
||
break;
|
||
case ST_END_FILE:
|
||
p = "END FILE";
|
||
break;
|
||
case ST_END_FORALL:
|
||
p = "END FORALL";
|
||
break;
|
||
case ST_END_FUNCTION:
|
||
p = "END FUNCTION";
|
||
break;
|
||
case ST_ENDIF:
|
||
p = "END IF";
|
||
break;
|
||
case ST_END_INTERFACE:
|
||
p = "END INTERFACE";
|
||
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_END_SELECT:
|
||
p = "END SELECT";
|
||
break;
|
||
case ST_END_SUBROUTINE:
|
||
p = "END SUBROUTINE";
|
||
break;
|
||
case ST_END_WHERE:
|
||
p = "END WHERE";
|
||
break;
|
||
case ST_END_STRUCTURE:
|
||
p = "END STRUCTURE";
|
||
break;
|
||
case ST_END_UNION:
|
||
p = "END UNION";
|
||
break;
|
||
case ST_END_MAP:
|
||
p = "END MAP";
|
||
break;
|
||
case ST_END_TYPE:
|
||
p = "END TYPE";
|
||
break;
|
||
case ST_ENTRY:
|
||
p = "ENTRY";
|
||
break;
|
||
case ST_EQUIVALENCE:
|
||
p = "EQUIVALENCE";
|
||
break;
|
||
case ST_ERROR_STOP:
|
||
p = "ERROR STOP";
|
||
break;
|
||
case ST_EXIT:
|
||
p = "EXIT";
|
||
break;
|
||
case ST_FLUSH:
|
||
p = "FLUSH";
|
||
break;
|
||
case ST_FORALL_BLOCK: /* Fall through */
|
||
case ST_FORALL:
|
||
p = "FORALL";
|
||
break;
|
||
case ST_FORMAT:
|
||
p = "FORMAT";
|
||
break;
|
||
case ST_FUNCTION:
|
||
p = "FUNCTION";
|
||
break;
|
||
case ST_GENERIC:
|
||
p = "GENERIC";
|
||
break;
|
||
case ST_GOTO:
|
||
p = "GOTO";
|
||
break;
|
||
case ST_IF_BLOCK:
|
||
p = _("block IF");
|
||
break;
|
||
case ST_IMPLICIT:
|
||
p = "IMPLICIT";
|
||
break;
|
||
case ST_IMPLICIT_NONE:
|
||
p = "IMPLICIT NONE";
|
||
break;
|
||
case ST_IMPLIED_ENDDO:
|
||
p = _("implied END DO");
|
||
break;
|
||
case ST_IMPORT:
|
||
p = "IMPORT";
|
||
break;
|
||
case ST_INQUIRE:
|
||
p = "INQUIRE";
|
||
break;
|
||
case ST_INTERFACE:
|
||
p = "INTERFACE";
|
||
break;
|
||
case ST_LOCK:
|
||
p = "LOCK";
|
||
break;
|
||
case ST_PARAMETER:
|
||
p = "PARAMETER";
|
||
break;
|
||
case ST_PRIVATE:
|
||
p = "PRIVATE";
|
||
break;
|
||
case ST_PUBLIC:
|
||
p = "PUBLIC";
|
||
break;
|
||
case ST_MODULE:
|
||
p = "MODULE";
|
||
break;
|
||
case ST_SUBMODULE:
|
||
p = "SUBMODULE";
|
||
break;
|
||
case ST_PAUSE:
|
||
p = "PAUSE";
|
||
break;
|
||
case ST_MODULE_PROC:
|
||
p = "MODULE PROCEDURE";
|
||
break;
|
||
case ST_NAMELIST:
|
||
p = "NAMELIST";
|
||
break;
|
||
case ST_NULLIFY:
|
||
p = "NULLIFY";
|
||
break;
|
||
case ST_OPEN:
|
||
p = "OPEN";
|
||
break;
|
||
case ST_PROGRAM:
|
||
p = "PROGRAM";
|
||
break;
|
||
case ST_PROCEDURE:
|
||
p = "PROCEDURE";
|
||
break;
|
||
case ST_READ:
|
||
p = "READ";
|
||
break;
|
||
case ST_RETURN:
|
||
p = "RETURN";
|
||
break;
|
||
case ST_REWIND:
|
||
p = "REWIND";
|
||
break;
|
||
case ST_STOP:
|
||
p = "STOP";
|
||
break;
|
||
case ST_SYNC_ALL:
|
||
p = "SYNC ALL";
|
||
break;
|
||
case ST_SYNC_IMAGES:
|
||
p = "SYNC IMAGES";
|
||
break;
|
||
case ST_SYNC_MEMORY:
|
||
p = "SYNC MEMORY";
|
||
break;
|
||
case ST_SUBROUTINE:
|
||
p = "SUBROUTINE";
|
||
break;
|
||
case ST_TYPE:
|
||
p = "TYPE";
|
||
break;
|
||
case ST_UNLOCK:
|
||
p = "UNLOCK";
|
||
break;
|
||
case ST_USE:
|
||
p = "USE";
|
||
break;
|
||
case ST_WHERE_BLOCK: /* Fall through */
|
||
case ST_WHERE:
|
||
p = "WHERE";
|
||
break;
|
||
case ST_WAIT:
|
||
p = "WAIT";
|
||
break;
|
||
case ST_WRITE:
|
||
p = "WRITE";
|
||
break;
|
||
case ST_ASSIGNMENT:
|
||
p = _("assignment");
|
||
break;
|
||
case ST_POINTER_ASSIGNMENT:
|
||
p = _("pointer assignment");
|
||
break;
|
||
case ST_SELECT_CASE:
|
||
p = "SELECT CASE";
|
||
break;
|
||
case ST_SELECT_TYPE:
|
||
p = "SELECT TYPE";
|
||
break;
|
||
case ST_SELECT_RANK:
|
||
p = "SELECT RANK";
|
||
break;
|
||
case ST_TYPE_IS:
|
||
p = "TYPE IS";
|
||
break;
|
||
case ST_CLASS_IS:
|
||
p = "CLASS IS";
|
||
break;
|
||
case ST_RANK:
|
||
p = "RANK";
|
||
break;
|
||
case ST_SEQUENCE:
|
||
p = "SEQUENCE";
|
||
break;
|
||
case ST_SIMPLE_IF:
|
||
p = _("simple IF");
|
||
break;
|
||
case ST_STATEMENT_FUNCTION:
|
||
p = "STATEMENT FUNCTION";
|
||
break;
|
||
case ST_LABEL_ASSIGNMENT:
|
||
p = "LABEL ASSIGNMENT";
|
||
break;
|
||
case ST_ENUM:
|
||
p = "ENUM DEFINITION";
|
||
break;
|
||
case ST_ENUMERATOR:
|
||
p = "ENUMERATOR DEFINITION";
|
||
break;
|
||
case ST_END_ENUM:
|
||
p = "END ENUM";
|
||
break;
|
||
case ST_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_SERIAL_LOOP:
|
||
p = "!$ACC SERIAL LOOP";
|
||
break;
|
||
case ST_OACC_END_SERIAL_LOOP:
|
||
p = "!$ACC END SERIAL LOOP";
|
||
break;
|
||
case ST_OACC_SERIAL:
|
||
p = "!$ACC SERIAL";
|
||
break;
|
||
case ST_OACC_END_SERIAL:
|
||
p = "!$ACC END SERIAL";
|
||
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_DECLARE_VARIANT:
|
||
p = "!$OMP DECLARE VARIANT";
|
||
break;
|
||
case ST_OMP_DEPOBJ:
|
||
p = "!$OMP DEPOBJ";
|
||
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_SCOPE:
|
||
p = "!$OMP END SCOPE";
|
||
break;
|
||
case ST_OMP_END_SIMD:
|
||
p = "!$OMP END SIMD";
|
||
break;
|
||
case ST_OMP_END_LOOP:
|
||
p = "!$OMP END LOOP";
|
||
break;
|
||
case ST_OMP_END_MASKED:
|
||
p = "!$OMP END MASKED";
|
||
break;
|
||
case ST_OMP_END_MASKED_TASKLOOP:
|
||
p = "!$OMP END MASKED TASKLOOP";
|
||
break;
|
||
case ST_OMP_END_MASKED_TASKLOOP_SIMD:
|
||
p = "!$OMP END MASKED TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_END_MASTER:
|
||
p = "!$OMP END MASTER";
|
||
break;
|
||
case ST_OMP_END_MASTER_TASKLOOP:
|
||
p = "!$OMP END MASTER TASKLOOP";
|
||
break;
|
||
case ST_OMP_END_MASTER_TASKLOOP_SIMD:
|
||
p = "!$OMP END MASTER TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_END_ORDERED:
|
||
p = "!$OMP END ORDERED";
|
||
break;
|
||
case ST_OMP_END_PARALLEL:
|
||
p = "!$OMP END PARALLEL";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_DO:
|
||
p = "!$OMP END PARALLEL DO";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_DO_SIMD:
|
||
p = "!$OMP END PARALLEL DO SIMD";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_LOOP:
|
||
p = "!$OMP END PARALLEL LOOP";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASKED:
|
||
p = "!$OMP END PARALLEL MASKED";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASKED_TASKLOOP:
|
||
p = "!$OMP END PARALLEL MASKED TASKLOOP";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASTER:
|
||
p = "!$OMP END PARALLEL MASTER";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASTER_TASKLOOP:
|
||
p = "!$OMP END PARALLEL MASTER TASKLOOP";
|
||
break;
|
||
case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
|
||
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_TASK:
|
||
p = "!$OMP END TASK";
|
||
break;
|
||
case ST_OMP_END_TARGET:
|
||
p = "!$OMP END TARGET";
|
||
break;
|
||
case ST_OMP_END_TARGET_DATA:
|
||
p = "!$OMP END TARGET DATA";
|
||
break;
|
||
case ST_OMP_END_TARGET_PARALLEL:
|
||
p = "!$OMP END TARGET PARALLEL";
|
||
break;
|
||
case ST_OMP_END_TARGET_PARALLEL_DO:
|
||
p = "!$OMP END TARGET PARALLEL DO";
|
||
break;
|
||
case ST_OMP_END_TARGET_PARALLEL_DO_SIMD:
|
||
p = "!$OMP END TARGET PARALLEL DO SIMD";
|
||
break;
|
||
case ST_OMP_END_TARGET_PARALLEL_LOOP:
|
||
p = "!$OMP END TARGET PARALLEL LOOP";
|
||
break;
|
||
case ST_OMP_END_TARGET_SIMD:
|
||
p = "!$OMP END TARGET SIMD";
|
||
break;
|
||
case ST_OMP_END_TARGET_TEAMS:
|
||
p = "!$OMP END TARGET TEAMS";
|
||
break;
|
||
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_TARGET_TEAMS_LOOP:
|
||
p = "!$OMP END TARGET TEAMS LOOP";
|
||
break;
|
||
case ST_OMP_END_TASKGROUP:
|
||
p = "!$OMP END TASKGROUP";
|
||
break;
|
||
case ST_OMP_END_TASKLOOP:
|
||
p = "!$OMP END TASKLOOP";
|
||
break;
|
||
case ST_OMP_END_TASKLOOP_SIMD:
|
||
p = "!$OMP END TASKLOOP SIMD";
|
||
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_TEAMS_LOOP:
|
||
p = "!$OMP END TEAMS LOOP";
|
||
break;
|
||
case ST_OMP_END_WORKSHARE:
|
||
p = "!$OMP END WORKSHARE";
|
||
break;
|
||
case ST_OMP_ERROR:
|
||
p = "!$OMP ERROR";
|
||
break;
|
||
case ST_OMP_FLUSH:
|
||
p = "!$OMP FLUSH";
|
||
break;
|
||
case ST_OMP_LOOP:
|
||
p = "!$OMP LOOP";
|
||
break;
|
||
case ST_OMP_MASKED:
|
||
p = "!$OMP MASKED";
|
||
break;
|
||
case ST_OMP_MASKED_TASKLOOP:
|
||
p = "!$OMP MASKED TASKLOOP";
|
||
break;
|
||
case ST_OMP_MASKED_TASKLOOP_SIMD:
|
||
p = "!$OMP MASKED TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_MASTER:
|
||
p = "!$OMP MASTER";
|
||
break;
|
||
case ST_OMP_MASTER_TASKLOOP:
|
||
p = "!$OMP MASTER TASKLOOP";
|
||
break;
|
||
case ST_OMP_MASTER_TASKLOOP_SIMD:
|
||
p = "!$OMP MASTER TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_ORDERED:
|
||
case ST_OMP_ORDERED_DEPEND:
|
||
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_LOOP:
|
||
p = "!$OMP PARALLEL LOOP";
|
||
break;
|
||
case ST_OMP_PARALLEL_DO_SIMD:
|
||
p = "!$OMP PARALLEL DO SIMD";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASKED:
|
||
p = "!$OMP PARALLEL MASKED";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
p = "!$OMP PARALLEL MASKED TASKLOOP";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
p = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER:
|
||
p = "!$OMP PARALLEL MASTER";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
p = "!$OMP PARALLEL MASTER TASKLOOP";
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
p = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
|
||
break;
|
||
case ST_OMP_PARALLEL_SECTIONS:
|
||
p = "!$OMP PARALLEL SECTIONS";
|
||
break;
|
||
case ST_OMP_PARALLEL_WORKSHARE:
|
||
p = "!$OMP PARALLEL WORKSHARE";
|
||
break;
|
||
case ST_OMP_REQUIRES:
|
||
p = "!$OMP REQUIRES";
|
||
break;
|
||
case ST_OMP_SCAN:
|
||
p = "!$OMP SCAN";
|
||
break;
|
||
case ST_OMP_SCOPE:
|
||
p = "!$OMP SCOPE";
|
||
break;
|
||
case ST_OMP_SECTIONS:
|
||
p = "!$OMP 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_ENTER_DATA:
|
||
p = "!$OMP TARGET ENTER DATA";
|
||
break;
|
||
case ST_OMP_TARGET_EXIT_DATA:
|
||
p = "!$OMP TARGET EXIT DATA";
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL:
|
||
p = "!$OMP TARGET PARALLEL";
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL_DO:
|
||
p = "!$OMP TARGET PARALLEL DO";
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
p = "!$OMP TARGET PARALLEL DO SIMD";
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL_LOOP:
|
||
p = "!$OMP TARGET PARALLEL LOOP";
|
||
break;
|
||
case ST_OMP_TARGET_SIMD:
|
||
p = "!$OMP TARGET SIMD";
|
||
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_TEAMS_LOOP:
|
||
p = "!$OMP TARGET TEAMS LOOP";
|
||
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_TASKLOOP:
|
||
p = "!$OMP TASKLOOP";
|
||
break;
|
||
case ST_OMP_TASKLOOP_SIMD:
|
||
p = "!$OMP TASKLOOP SIMD";
|
||
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_TEAMS_LOOP:
|
||
p = "!$OMP TEAMS LOOP";
|
||
break;
|
||
case ST_OMP_THREADPRIVATE:
|
||
p = "!$OMP THREADPRIVATE";
|
||
break;
|
||
case ST_OMP_WORKSHARE:
|
||
p = "!$OMP WORKSHARE";
|
||
break;
|
||
default:
|
||
gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
|
||
}
|
||
|
||
return p;
|
||
}
|
||
|
||
|
||
/* Create a symbol for the main program and assign it to ns->proc_name. */
|
||
|
||
static void
|
||
main_program_symbol (gfc_namespace *ns, const char *name)
|
||
{
|
||
gfc_symbol *main_program;
|
||
symbol_attribute attr;
|
||
|
||
gfc_get_symbol (name, ns, &main_program);
|
||
gfc_clear_attr (&attr);
|
||
attr.flavor = FL_PROGRAM;
|
||
attr.proc = PROC_UNKNOWN;
|
||
attr.subroutine = 1;
|
||
attr.access = ACCESS_PUBLIC;
|
||
attr.is_main_program = 1;
|
||
main_program->attr = attr;
|
||
main_program->declared_at = gfc_current_locus;
|
||
ns->proc_name = main_program;
|
||
gfc_commit_symbols ();
|
||
}
|
||
|
||
|
||
/* Do whatever is necessary to accept the last statement. */
|
||
|
||
static void
|
||
accept_statement (gfc_statement st)
|
||
{
|
||
switch (st)
|
||
{
|
||
case ST_IMPLICIT_NONE:
|
||
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;
|
||
|
||
/* If the statement is the end of a block, lay down a special code
|
||
that allows a branch to the end of the block from within the
|
||
construct. IF and SELECT are treated differently from DO
|
||
(where EXEC_NOP is added inside the loop) for two
|
||
reasons:
|
||
1. END DO has a meaning in the sense that after a GOTO to
|
||
it, the loop counter must be increased.
|
||
2. IF blocks and SELECT blocks can consist of multiple
|
||
parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
|
||
Putting the label before the END IF would make the jump
|
||
from, say, the ELSE IF block to the END IF illegal. */
|
||
|
||
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;
|
||
add_statement ();
|
||
}
|
||
break;
|
||
|
||
/* The end-of-program unit statements do not get the special
|
||
marker and require a statement of some sort if they are a
|
||
branch target. */
|
||
|
||
case ST_END_PROGRAM:
|
||
case ST_END_FUNCTION:
|
||
case ST_END_SUBROUTINE:
|
||
if (gfc_statement_label != NULL)
|
||
{
|
||
new_st.op = EXEC_RETURN;
|
||
add_statement ();
|
||
}
|
||
else
|
||
{
|
||
new_st.op = EXEC_END_PROCEDURE;
|
||
add_statement ();
|
||
}
|
||
|
||
break;
|
||
|
||
case ST_ENTRY:
|
||
case_executable:
|
||
case_exec_markers:
|
||
add_statement ();
|
||
break;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
gfc_commit_symbols ();
|
||
gfc_warning_check ();
|
||
gfc_clear_new_st ();
|
||
}
|
||
|
||
|
||
/* Undo anything tentative that has been built for the current statement,
|
||
except if a gfc_charlen structure has been added to current namespace's
|
||
list of gfc_charlen structure. */
|
||
|
||
static void
|
||
reject_statement (void)
|
||
{
|
||
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 ();
|
||
undo_new_statement ();
|
||
}
|
||
|
||
|
||
/* Generic complaint about an out of order statement. We also do
|
||
whatever is necessary to clean up. */
|
||
|
||
static void
|
||
unexpected_statement (gfc_statement st)
|
||
{
|
||
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
|
||
|
||
reject_statement ();
|
||
}
|
||
|
||
|
||
/* 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 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
|
||
INTERFACE blocks. The following diagram is taken from the standard:
|
||
|
||
+---------------------------------------+
|
||
| program subroutine function module |
|
||
+---------------------------------------+
|
||
| use |
|
||
+---------------------------------------+
|
||
| import |
|
||
+---------------------------------------+
|
||
| | implicit none |
|
||
| +-----------+------------------+
|
||
| | parameter | implicit |
|
||
| +-----------+------------------+
|
||
| format | | derived type |
|
||
| entry | parameter | interface |
|
||
| | data | specification |
|
||
| | | statement func |
|
||
| +-----------+------------------+
|
||
| | data | executable |
|
||
+--------+-----------+------------------+
|
||
| contains |
|
||
+---------------------------------------+
|
||
| internal module/subprogram |
|
||
+---------------------------------------+
|
||
| end |
|
||
+---------------------------------------+
|
||
|
||
*/
|
||
|
||
enum state_order
|
||
{
|
||
ORDER_START,
|
||
ORDER_USE,
|
||
ORDER_IMPORT,
|
||
ORDER_IMPLICIT_NONE,
|
||
ORDER_IMPLICIT,
|
||
ORDER_SPEC,
|
||
ORDER_EXEC
|
||
};
|
||
|
||
typedef struct
|
||
{
|
||
enum state_order state;
|
||
gfc_statement last_statement;
|
||
locus where;
|
||
}
|
||
st_state;
|
||
|
||
static bool
|
||
verify_st_order (st_state *p, gfc_statement st, bool silent)
|
||
{
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
p->state = ORDER_START;
|
||
break;
|
||
|
||
case ST_USE:
|
||
if (p->state > ORDER_USE)
|
||
goto order;
|
||
p->state = ORDER_USE;
|
||
break;
|
||
|
||
case ST_IMPORT:
|
||
if (p->state > ORDER_IMPORT)
|
||
goto order;
|
||
p->state = ORDER_IMPORT;
|
||
break;
|
||
|
||
case ST_IMPLICIT_NONE:
|
||
if (p->state > ORDER_IMPLICIT)
|
||
goto order;
|
||
|
||
/* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
|
||
statement disqualifies a USE but not an IMPLICIT NONE.
|
||
Duplicate IMPLICIT NONEs are caught when the implicit types
|
||
are set. */
|
||
|
||
p->state = ORDER_IMPLICIT_NONE;
|
||
break;
|
||
|
||
case ST_IMPLICIT:
|
||
if (p->state > ORDER_IMPLICIT)
|
||
goto order;
|
||
p->state = ORDER_IMPLICIT;
|
||
break;
|
||
|
||
case ST_FORMAT:
|
||
case ST_ENTRY:
|
||
if (p->state < ORDER_IMPLICIT_NONE)
|
||
p->state = ORDER_IMPLICIT_NONE;
|
||
break;
|
||
|
||
case ST_PARAMETER:
|
||
if (p->state >= ORDER_EXEC)
|
||
goto order;
|
||
if (p->state < ORDER_IMPLICIT)
|
||
p->state = ORDER_IMPLICIT;
|
||
break;
|
||
|
||
case ST_DATA:
|
||
if (p->state < ORDER_SPEC)
|
||
p->state = ORDER_SPEC;
|
||
break;
|
||
|
||
case ST_PUBLIC:
|
||
case ST_PRIVATE:
|
||
case ST_STRUCTURE_DECL:
|
||
case ST_DERIVED_DECL:
|
||
case_decl:
|
||
if (p->state >= ORDER_EXEC)
|
||
goto order;
|
||
if (p->state < ORDER_SPEC)
|
||
p->state = ORDER_SPEC;
|
||
break;
|
||
|
||
case_omp_decl:
|
||
/* The OpenMP/OpenACC directives have to be somewhere in the specification
|
||
part, but there are no further requirements on their ordering.
|
||
Thus don't adjust p->state, just ignore them. */
|
||
if (p->state >= ORDER_EXEC)
|
||
goto order;
|
||
break;
|
||
|
||
case_executable:
|
||
case_exec_markers:
|
||
if (p->state < ORDER_EXEC)
|
||
p->state = ORDER_EXEC;
|
||
break;
|
||
|
||
default:
|
||
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 true;
|
||
|
||
order:
|
||
if (!silent)
|
||
gfc_error ("%s statement at %C cannot follow %s statement at %L",
|
||
gfc_ascii_statement (st),
|
||
gfc_ascii_statement (p->last_statement), &p->where);
|
||
|
||
return false;
|
||
}
|
||
|
||
|
||
/* Handle an unexpected end of file. This is a show-stopper... */
|
||
|
||
static void unexpected_eof (void) ATTRIBUTE_NORETURN;
|
||
|
||
static void
|
||
unexpected_eof (void)
|
||
{
|
||
gfc_state_data *p;
|
||
|
||
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;
|
||
p = p->previous);
|
||
|
||
gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
|
||
gfc_done_2 ();
|
||
|
||
longjmp (eof_buf, 1);
|
||
|
||
/* Avoids build error on systems where longjmp is not declared noreturn. */
|
||
gcc_unreachable ();
|
||
}
|
||
|
||
|
||
/* Parse the CONTAINS section of a derived type definition. */
|
||
|
||
gfc_access gfc_typebound_default_access;
|
||
|
||
static bool
|
||
parse_derived_contains (void)
|
||
{
|
||
gfc_state_data s;
|
||
bool seen_private = false;
|
||
bool seen_comps = false;
|
||
bool error_flag = false;
|
||
bool to_finish;
|
||
|
||
gcc_assert (gfc_current_state () == COMP_DERIVED);
|
||
gcc_assert (gfc_current_block ());
|
||
|
||
/* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
|
||
section. */
|
||
if (gfc_current_block ()->attr.sequence)
|
||
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 %qs with BIND(C) must not have a CONTAINS"
|
||
" section at %C", gfc_current_block ()->name);
|
||
|
||
accept_statement (ST_CONTAINS);
|
||
push_state (&s, COMP_DERIVED_CONTAINS, NULL);
|
||
|
||
gfc_typebound_default_access = ACCESS_PUBLIC;
|
||
|
||
to_finish = false;
|
||
while (!to_finish)
|
||
{
|
||
gfc_statement st;
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
break;
|
||
|
||
case ST_DATA_DECL:
|
||
gfc_error ("Components in TYPE at %C must precede CONTAINS");
|
||
goto error;
|
||
|
||
case ST_PROCEDURE:
|
||
if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
|
||
goto error;
|
||
|
||
accept_statement (ST_PROCEDURE);
|
||
seen_comps = true;
|
||
break;
|
||
|
||
case ST_GENERIC:
|
||
if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
|
||
goto error;
|
||
|
||
accept_statement (ST_GENERIC);
|
||
seen_comps = true;
|
||
break;
|
||
|
||
case ST_FINAL:
|
||
if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
|
||
" at %C"))
|
||
goto error;
|
||
|
||
accept_statement (ST_FINAL);
|
||
seen_comps = true;
|
||
break;
|
||
|
||
case ST_END_TYPE:
|
||
to_finish = true;
|
||
|
||
if (!seen_comps
|
||
&& (!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))
|
||
{
|
||
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
|
||
"a MODULE");
|
||
goto error;
|
||
}
|
||
|
||
if (seen_comps)
|
||
{
|
||
gfc_error ("PRIVATE statement at %C must precede procedure"
|
||
" bindings");
|
||
goto error;
|
||
}
|
||
|
||
if (seen_private)
|
||
{
|
||
gfc_error ("Duplicate PRIVATE statement at %C");
|
||
goto error;
|
||
}
|
||
|
||
accept_statement (ST_PRIVATE);
|
||
gfc_typebound_default_access = ACCESS_PRIVATE;
|
||
seen_private = true;
|
||
break;
|
||
|
||
case ST_SEQUENCE:
|
||
gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
|
||
goto error;
|
||
|
||
case ST_CONTAINS:
|
||
gfc_error ("Already inside a CONTAINS block at %C");
|
||
goto error;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
|
||
continue;
|
||
|
||
error:
|
||
error_flag = true;
|
||
reject_statement ();
|
||
}
|
||
|
||
pop_state ();
|
||
gcc_assert (gfc_current_state () == COMP_DERIVED);
|
||
|
||
return error_flag;
|
||
}
|
||
|
||
|
||
/* Set attributes for the parent symbol based on the attributes of a component
|
||
and raise errors if conflicting attributes are found for the component. */
|
||
|
||
static void
|
||
check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
|
||
gfc_component **eventp)
|
||
{
|
||
bool coarray, lock_type, event_type, allocatable, pointer;
|
||
coarray = lock_type = event_type = allocatable = pointer = false;
|
||
gfc_component *lock_comp = NULL, *event_comp = NULL;
|
||
|
||
if (lockp) lock_comp = *lockp;
|
||
if (eventp) event_comp = *eventp;
|
||
|
||
/* Look for allocatable components. */
|
||
if (c->attr.allocatable
|
||
|| (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 && c->attr.class_ok
|
||
&& CLASS_DATA (c)->attr.class_pointer)
|
||
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
|
||
{
|
||
pointer = true;
|
||
sym->attr.pointer_comp = 1;
|
||
}
|
||
|
||
/* Look for procedure pointer components. */
|
||
if (c->attr.proc_pointer
|
||
|| (c->ts.type == BT_DERIVED
|
||
&& c->ts.u.derived->attr.proc_pointer_comp))
|
||
sym->attr.proc_pointer_comp = 1;
|
||
|
||
/* Looking for coarray components. */
|
||
if (c->attr.codimension
|
||
|| (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
|
||
|| c->attr.access == ACCESS_PRIVATE
|
||
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
|
||
sym->attr.private_comp = 1;
|
||
|
||
if (lockp) *lockp = lock_comp;
|
||
if (eventp) *eventp = event_comp;
|
||
}
|
||
|
||
|
||
static void parse_struct_map (gfc_statement);
|
||
|
||
/* Parse a union component definition within a structure definition. */
|
||
|
||
static void
|
||
parse_union (void)
|
||
{
|
||
int compiling;
|
||
gfc_statement st;
|
||
gfc_state_data s;
|
||
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
|
||
gfc_symbol *un;
|
||
|
||
accept_statement(ST_UNION);
|
||
push_state (&s, COMP_UNION, gfc_new_block);
|
||
un = gfc_new_block;
|
||
|
||
compiling = 1;
|
||
|
||
while (compiling)
|
||
{
|
||
st = next_statement ();
|
||
/* Only MAP declarations valid within a union. */
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_MAP:
|
||
accept_statement (ST_MAP);
|
||
parse_struct_map (ST_MAP);
|
||
/* Add a component to the union for each map. */
|
||
if (!gfc_add_component (un, gfc_new_block->name, &c))
|
||
{
|
||
gfc_internal_error ("failed to create map component '%s'",
|
||
gfc_new_block->name);
|
||
reject_statement ();
|
||
return;
|
||
}
|
||
c->ts.type = BT_DERIVED;
|
||
c->ts.u.derived = gfc_new_block;
|
||
/* Normally components get their initialization expressions when they
|
||
are created in decl.cc (build_struct) so we can look through the
|
||
flat component list for initializers during resolution. Unions and
|
||
maps create components along with their type definitions so we
|
||
have to generate initializers here. */
|
||
c->initializer = gfc_default_initializer (&c->ts);
|
||
break;
|
||
|
||
case ST_END_UNION:
|
||
compiling = 0;
|
||
accept_statement (ST_END_UNION);
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
|
||
for (c = un->components; c; c = c->next)
|
||
check_component (un, c, &lock_comp, &event_comp);
|
||
|
||
/* Add the union as a component in its parent structure. */
|
||
pop_state ();
|
||
if (!gfc_add_component (gfc_current_block (), un->name, &c))
|
||
{
|
||
gfc_internal_error ("failed to create union component '%s'", un->name);
|
||
reject_statement ();
|
||
return;
|
||
}
|
||
c->ts.type = BT_UNION;
|
||
c->ts.u.derived = un;
|
||
c->initializer = gfc_default_initializer (&c->ts);
|
||
|
||
un->attr.zero_comp = un->components == NULL;
|
||
}
|
||
|
||
|
||
/* Parse a STRUCTURE or MAP. */
|
||
|
||
static void
|
||
parse_struct_map (gfc_statement block)
|
||
{
|
||
int compiling_type;
|
||
gfc_statement st;
|
||
gfc_state_data s;
|
||
gfc_symbol *sym;
|
||
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
|
||
gfc_compile_state comp;
|
||
gfc_statement ends;
|
||
|
||
if (block == ST_STRUCTURE_DECL)
|
||
{
|
||
comp = COMP_STRUCTURE;
|
||
ends = ST_END_STRUCTURE;
|
||
}
|
||
else
|
||
{
|
||
gcc_assert (block == ST_MAP);
|
||
comp = COMP_MAP;
|
||
ends = ST_END_MAP;
|
||
}
|
||
|
||
accept_statement(block);
|
||
push_state (&s, comp, gfc_new_block);
|
||
|
||
gfc_new_block->component_access = ACCESS_PUBLIC;
|
||
compiling_type = 1;
|
||
|
||
while (compiling_type)
|
||
{
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
/* Nested structure declarations will be captured as ST_DATA_DECL. */
|
||
case ST_STRUCTURE_DECL:
|
||
/* Let a more specific error make it to decode_statement(). */
|
||
if (gfc_error_check () == 0)
|
||
gfc_error ("Syntax error in nested structure declaration at %C");
|
||
reject_statement ();
|
||
/* Skip the rest of this statement. */
|
||
gfc_error_recovery ();
|
||
break;
|
||
|
||
case ST_UNION:
|
||
accept_statement (ST_UNION);
|
||
parse_union ();
|
||
break;
|
||
|
||
case ST_DATA_DECL:
|
||
/* The data declaration was a nested/ad-hoc STRUCTURE field. */
|
||
accept_statement (ST_DATA_DECL);
|
||
if (gfc_new_block && gfc_new_block != gfc_current_block ()
|
||
&& gfc_new_block->attr.flavor == FL_STRUCT)
|
||
parse_struct_map (ST_STRUCTURE_DECL);
|
||
break;
|
||
|
||
case ST_END_STRUCTURE:
|
||
case ST_END_MAP:
|
||
if (st == ends)
|
||
{
|
||
accept_statement (st);
|
||
compiling_type = 0;
|
||
}
|
||
else
|
||
unexpected_statement (st);
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
|
||
/* Validate each component. */
|
||
sym = gfc_current_block ();
|
||
for (c = sym->components; c; c = c->next)
|
||
check_component (sym, c, &lock_comp, &event_comp);
|
||
|
||
sym->attr.zero_comp = (sym->components == NULL);
|
||
|
||
/* Allow parse_union to find this structure to add to its list of maps. */
|
||
if (block == ST_MAP)
|
||
gfc_new_block = gfc_current_block ();
|
||
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
/* Parse a derived type. */
|
||
|
||
static void
|
||
parse_derived (void)
|
||
{
|
||
int compiling_type, seen_private, seen_sequence, seen_component;
|
||
gfc_statement st;
|
||
gfc_state_data s;
|
||
gfc_symbol *sym;
|
||
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
|
||
|
||
accept_statement (ST_DERIVED_DECL);
|
||
push_state (&s, COMP_DERIVED, gfc_new_block);
|
||
|
||
gfc_new_block->component_access = ACCESS_PUBLIC;
|
||
seen_private = 0;
|
||
seen_sequence = 0;
|
||
seen_component = 0;
|
||
|
||
compiling_type = 1;
|
||
|
||
while (compiling_type)
|
||
{
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_DATA_DECL:
|
||
case ST_PROCEDURE:
|
||
accept_statement (st);
|
||
seen_component = 1;
|
||
break;
|
||
|
||
case ST_FINAL:
|
||
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
|
||
break;
|
||
|
||
case ST_END_TYPE:
|
||
endType:
|
||
compiling_type = 0;
|
||
|
||
if (!seen_component)
|
||
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))
|
||
{
|
||
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
|
||
"a MODULE");
|
||
break;
|
||
}
|
||
|
||
if (seen_component)
|
||
{
|
||
gfc_error ("PRIVATE statement at %C must precede "
|
||
"structure components");
|
||
break;
|
||
}
|
||
|
||
if (seen_private)
|
||
gfc_error ("Duplicate PRIVATE statement at %C");
|
||
|
||
s.sym->component_access = ACCESS_PRIVATE;
|
||
|
||
accept_statement (ST_PRIVATE);
|
||
seen_private = 1;
|
||
break;
|
||
|
||
case ST_SEQUENCE:
|
||
if (seen_component)
|
||
{
|
||
gfc_error ("SEQUENCE statement at %C must precede "
|
||
"structure components");
|
||
break;
|
||
}
|
||
|
||
if (gfc_current_block ()->attr.sequence)
|
||
gfc_warning (0, "SEQUENCE attribute at %C already specified in "
|
||
"TYPE statement");
|
||
|
||
if (seen_sequence)
|
||
{
|
||
gfc_error ("Duplicate SEQUENCE statement at %C");
|
||
}
|
||
|
||
seen_sequence = 1;
|
||
gfc_add_sequence (&gfc_current_block ()->attr,
|
||
gfc_current_block ()->name, NULL);
|
||
break;
|
||
|
||
case ST_CONTAINS:
|
||
gfc_notify_std (GFC_STD_F2003,
|
||
"CONTAINS block in derived type"
|
||
" definition at %C");
|
||
|
||
accept_statement (ST_CONTAINS);
|
||
parse_derived_contains ();
|
||
goto endType;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
|
||
/* need to verify that all fields of the derived type are
|
||
* interoperable with C if the type is declared to be bind(c)
|
||
*/
|
||
sym = gfc_current_block ();
|
||
for (c = sym->components; c; c = c->next)
|
||
check_component (sym, c, &lock_comp, &event_comp);
|
||
|
||
if (!seen_component)
|
||
sym->attr.zero_comp = 1;
|
||
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
/* Parse an ENUM. */
|
||
|
||
static void
|
||
parse_enum (void)
|
||
{
|
||
gfc_statement st;
|
||
int compiling_enum;
|
||
gfc_state_data s;
|
||
int seen_enumerator = 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");
|
||
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(). */
|
||
|
||
static gfc_statement parse_spec (gfc_statement);
|
||
|
||
static void
|
||
parse_interface (void)
|
||
{
|
||
gfc_compile_state new_state = COMP_NONE, current_state;
|
||
gfc_symbol *prog_unit, *sym;
|
||
gfc_interface_info save;
|
||
gfc_state_data s1, s2;
|
||
gfc_statement st;
|
||
|
||
accept_statement (ST_INTERFACE);
|
||
|
||
current_interface.ns = gfc_current_ns;
|
||
save = current_interface;
|
||
|
||
sym = (current_interface.type == INTERFACE_GENERIC
|
||
|| current_interface.type == INTERFACE_USER_OP)
|
||
? gfc_new_block : NULL;
|
||
|
||
push_state (&s1, COMP_INTERFACE, sym);
|
||
current_state = COMP_NONE;
|
||
|
||
loop:
|
||
gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
|
||
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_SUBROUTINE:
|
||
case ST_FUNCTION:
|
||
if (st == ST_SUBROUTINE)
|
||
new_state = COMP_SUBROUTINE;
|
||
else if (st == ST_FUNCTION)
|
||
new_state = COMP_FUNCTION;
|
||
if (gfc_new_block->attr.pointer)
|
||
{
|
||
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))
|
||
{
|
||
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:
|
||
case ST_MODULE_PROC: /* The module procedure matcher makes
|
||
sure the context is correct. */
|
||
accept_statement (st);
|
||
gfc_free_namespace (gfc_current_ns);
|
||
goto loop;
|
||
|
||
case ST_END_INTERFACE:
|
||
gfc_free_namespace (gfc_current_ns);
|
||
gfc_current_ns = current_interface.ns;
|
||
goto done;
|
||
|
||
default:
|
||
gfc_error ("Unexpected %s statement in INTERFACE block at %C",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
gfc_free_namespace (gfc_current_ns);
|
||
goto loop;
|
||
}
|
||
|
||
|
||
/* Make sure that the generic name has the right attribute. */
|
||
if (current_interface.type == INTERFACE_GENERIC
|
||
&& 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;
|
||
}
|
||
|
||
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 %qs of ABSTRACT INTERFACE at %C "
|
||
"cannot be the same as an intrinsic type",
|
||
gfc_new_block->name);
|
||
}
|
||
|
||
push_state (&s2, new_state, gfc_new_block);
|
||
accept_statement (st);
|
||
prog_unit = gfc_new_block;
|
||
prog_unit->formal_ns = gfc_current_ns;
|
||
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
|
||
from the formal namespace. */
|
||
if (new_state == COMP_FUNCTION)
|
||
{
|
||
if (prog_unit->result == prog_unit
|
||
&& prog_unit->ts.type == BT_UNKNOWN)
|
||
gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
|
||
else if (prog_unit->result != prog_unit
|
||
&& prog_unit->result->ts.type == BT_UNKNOWN)
|
||
gfc_set_default_type (prog_unit->result, 1,
|
||
prog_unit->formal_ns);
|
||
}
|
||
|
||
if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
|
||
{
|
||
gfc_error ("Unexpected %s statement at %C in INTERFACE body",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
goto decl;
|
||
}
|
||
|
||
/* Add EXTERNAL attribute to function or subroutine. */
|
||
if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
|
||
gfc_add_external (&prog_unit->attr, &gfc_current_locus);
|
||
|
||
current_interface = save;
|
||
gfc_add_interface (prog_unit);
|
||
pop_state ();
|
||
|
||
if (current_interface.ns
|
||
&& current_interface.ns->proc_name
|
||
&& strcmp (current_interface.ns->proc_name->name,
|
||
prog_unit->name) == 0)
|
||
gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
|
||
"enclosing procedure", prog_unit->name,
|
||
¤t_interface.ns->proc_name->declared_at);
|
||
|
||
goto loop;
|
||
|
||
done:
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
/* Associate function characteristics by going back to the function
|
||
declaration and rematching the prefix. */
|
||
|
||
static match
|
||
match_deferred_characteristics (gfc_typespec * ts)
|
||
{
|
||
locus loc;
|
||
match m = MATCH_ERROR;
|
||
char name[GFC_MAX_SYMBOL_LEN + 1];
|
||
|
||
loc = gfc_current_locus;
|
||
|
||
gfc_current_locus = gfc_current_block ()->declared_at;
|
||
|
||
gfc_clear_error ();
|
||
gfc_buffer_error (true);
|
||
m = gfc_match_prefix (ts);
|
||
gfc_buffer_error (false);
|
||
|
||
if (ts->type == BT_DERIVED)
|
||
{
|
||
ts->kind = 0;
|
||
|
||
if (!ts->u.derived)
|
||
m = MATCH_ERROR;
|
||
}
|
||
|
||
/* Only permit one go at the characteristic association. */
|
||
if (ts->kind == -1)
|
||
ts->kind = 0;
|
||
|
||
/* Set the function locus correctly. If we have not found the
|
||
function name, there is an error. */
|
||
if (m == MATCH_YES
|
||
&& gfc_match ("function% %n", name) == MATCH_YES
|
||
&& strcmp (name, gfc_current_block ()->name) == 0)
|
||
{
|
||
gfc_current_block ()->declared_at = gfc_current_locus;
|
||
gfc_commit_symbols ();
|
||
}
|
||
else
|
||
{
|
||
gfc_error_check ();
|
||
gfc_undo_symbols ();
|
||
}
|
||
|
||
gfc_current_locus =loc;
|
||
return m;
|
||
}
|
||
|
||
|
||
/* Check specification-expressions in the function result of the currently
|
||
parsed block and ensure they are typed (give an IMPLICIT type if necessary).
|
||
For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
|
||
scope are not yet parsed so this has to be delayed up to parse_spec. */
|
||
|
||
static void
|
||
check_function_result_typed (void)
|
||
{
|
||
gfc_typespec ts;
|
||
|
||
gcc_assert (gfc_current_state () == COMP_FUNCTION);
|
||
|
||
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);
|
||
}
|
||
|
||
|
||
/* Parse a set of specification statements. Returns the statement
|
||
that doesn't fit. */
|
||
|
||
static gfc_statement
|
||
parse_spec (gfc_statement st)
|
||
{
|
||
st_state ss;
|
||
bool function_result_typed = false;
|
||
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 ();
|
||
|
||
/* If we are not inside a function or don't have a result specified so far,
|
||
do nothing special about it. */
|
||
if (gfc_current_state () != COMP_FUNCTION)
|
||
function_result_typed = true;
|
||
else
|
||
{
|
||
gfc_symbol* proc = gfc_current_ns->proc_name;
|
||
gcc_assert (proc);
|
||
|
||
if (proc->result->ts.type == BT_UNKNOWN)
|
||
function_result_typed = true;
|
||
}
|
||
|
||
loop:
|
||
|
||
/* If we're inside a BLOCK construct, some statements are disallowed.
|
||
Check this here. Attribute declaration statements like INTENT, OPTIONAL
|
||
or VALUE are also disallowed, but they don't have a particular ST_*
|
||
key so we have to check for them individually in their matcher routine. */
|
||
if (gfc_current_state () == COMP_BLOCK)
|
||
switch (st)
|
||
{
|
||
case ST_IMPLICIT:
|
||
case ST_IMPLICIT_NONE:
|
||
case ST_NAMELIST:
|
||
case ST_COMMON:
|
||
case ST_EQUIVALENCE:
|
||
case ST_STATEMENT_FUNCTION:
|
||
gfc_error ("%s statement is not allowed inside of BLOCK at %C",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
break;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
else if (gfc_current_state () == COMP_BLOCK_DATA)
|
||
/* Fortran 2008, C1116. */
|
||
switch (st)
|
||
{
|
||
case ST_ATTR_DECL:
|
||
case ST_COMMON:
|
||
case ST_DATA:
|
||
case ST_DATA_DECL:
|
||
case ST_DERIVED_DECL:
|
||
case ST_END_BLOCK_DATA:
|
||
case ST_EQUIVALENCE:
|
||
case ST_IMPLICIT:
|
||
case ST_IMPLICIT_NONE:
|
||
case ST_OMP_THREADPRIVATE:
|
||
case ST_PARAMETER:
|
||
case ST_STRUCTURE_DECL:
|
||
case ST_TYPE:
|
||
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 cannot 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
|
||
to verify_st_order! */
|
||
if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
|
||
{
|
||
bool verify_now = false;
|
||
|
||
if (st == ST_END_FUNCTION || st == ST_CONTAINS)
|
||
verify_now = true;
|
||
else
|
||
{
|
||
st_state dummyss;
|
||
verify_st_order (&dummyss, ST_NONE, false);
|
||
verify_st_order (&dummyss, st, false);
|
||
|
||
if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
|
||
verify_now = true;
|
||
}
|
||
|
||
if (verify_now)
|
||
{
|
||
check_function_result_typed ();
|
||
function_result_typed = true;
|
||
}
|
||
}
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_IMPLICIT_NONE:
|
||
case ST_IMPLICIT:
|
||
if (!function_result_typed)
|
||
{
|
||
check_function_result_typed ();
|
||
function_result_typed = true;
|
||
}
|
||
goto declSt;
|
||
|
||
case ST_FORMAT:
|
||
case ST_ENTRY:
|
||
case ST_DATA: /* Not allowed in interfaces */
|
||
if (gfc_current_state () == COMP_INTERFACE)
|
||
break;
|
||
|
||
/* Fall through */
|
||
|
||
case ST_USE:
|
||
case ST_IMPORT:
|
||
case ST_PARAMETER:
|
||
case ST_PUBLIC:
|
||
case ST_PRIVATE:
|
||
case ST_STRUCTURE_DECL:
|
||
case ST_DERIVED_DECL:
|
||
case_decl:
|
||
case_omp_decl:
|
||
declSt:
|
||
if (!verify_st_order (&ss, st, false))
|
||
{
|
||
reject_statement ();
|
||
st = next_statement ();
|
||
goto loop;
|
||
}
|
||
|
||
switch (st)
|
||
{
|
||
case ST_INTERFACE:
|
||
parse_interface ();
|
||
break;
|
||
|
||
case ST_STRUCTURE_DECL:
|
||
parse_struct_map (ST_STRUCTURE_DECL);
|
||
break;
|
||
|
||
case ST_DERIVED_DECL:
|
||
parse_derived ();
|
||
break;
|
||
|
||
case ST_PUBLIC:
|
||
case ST_PRIVATE:
|
||
if (gfc_current_state () != COMP_MODULE)
|
||
{
|
||
gfc_error ("%s statement must appear in a MODULE",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
|
||
if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
|
||
{
|
||
gfc_error ("%s statement at %C follows another accessibility "
|
||
"specification", gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
|
||
gfc_current_ns->default_access = (st == ST_PUBLIC)
|
||
? ACCESS_PUBLIC : ACCESS_PRIVATE;
|
||
|
||
break;
|
||
|
||
case ST_STATEMENT_FUNCTION:
|
||
if (gfc_current_state () == COMP_MODULE
|
||
|| gfc_current_state () == COMP_SUBMODULE)
|
||
{
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
accept_statement (st);
|
||
st = next_statement ();
|
||
goto loop;
|
||
|
||
case ST_ENUM:
|
||
accept_statement (st);
|
||
parse_enum();
|
||
st = next_statement ();
|
||
goto loop;
|
||
|
||
case ST_GET_FCN_CHARACTERISTICS:
|
||
/* This statement triggers the association of a function's result
|
||
characteristics. */
|
||
ts = &gfc_current_block ()->result->ts;
|
||
if (match_deferred_characteristics (ts) != MATCH_YES)
|
||
bad_characteristic = true;
|
||
|
||
st = next_statement ();
|
||
goto loop;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
/* 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 %qs at %L",
|
||
gfc_current_block ()->name,
|
||
&gfc_current_block ()->declared_at);
|
||
else
|
||
gfc_error ("The type for function %qs at %L is not accessible",
|
||
gfc_current_block ()->name,
|
||
&gfc_current_block ()->declared_at);
|
||
|
||
gfc_current_block ()->ts.kind = 0;
|
||
/* Keep the derived type; if it's bad, it will be discovered later. */
|
||
if (!(ts->type == BT_DERIVED && ts->u.derived))
|
||
ts->type = BT_UNKNOWN;
|
||
}
|
||
|
||
in_specification_block = false;
|
||
|
||
return st;
|
||
}
|
||
|
||
|
||
/* Parse a WHERE block, (not a simple WHERE statement). */
|
||
|
||
static void
|
||
parse_where_block (void)
|
||
{
|
||
int seen_empty_else;
|
||
gfc_code *top, *d;
|
||
gfc_state_data s;
|
||
gfc_statement st;
|
||
|
||
accept_statement (ST_WHERE_BLOCK);
|
||
top = gfc_state_stack->tail;
|
||
|
||
push_state (&s, COMP_WHERE, gfc_new_block);
|
||
|
||
d = add_statement ();
|
||
d->expr1 = top->expr1;
|
||
d->op = EXEC_WHERE;
|
||
|
||
top->expr1 = NULL;
|
||
top->block = d;
|
||
|
||
seen_empty_else = 0;
|
||
|
||
do
|
||
{
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_WHERE_BLOCK:
|
||
parse_where_block ();
|
||
break;
|
||
|
||
case ST_ASSIGNMENT:
|
||
case ST_WHERE:
|
||
accept_statement (st);
|
||
break;
|
||
|
||
case ST_ELSEWHERE:
|
||
if (seen_empty_else)
|
||
{
|
||
gfc_error ("ELSEWHERE statement at %C follows previous "
|
||
"unmasked ELSEWHERE");
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
|
||
if (new_st.expr1 == NULL)
|
||
seen_empty_else = 1;
|
||
|
||
d = new_level (gfc_state_stack->head);
|
||
d->op = EXEC_WHERE;
|
||
d->expr1 = new_st.expr1;
|
||
|
||
accept_statement (st);
|
||
|
||
break;
|
||
|
||
case ST_END_WHERE:
|
||
accept_statement (st);
|
||
break;
|
||
|
||
default:
|
||
gfc_error ("Unexpected %s statement in WHERE block at %C",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_WHERE);
|
||
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
/* Parse a FORALL block (not a simple FORALL statement). */
|
||
|
||
static void
|
||
parse_forall_block (void)
|
||
{
|
||
gfc_code *top, *d;
|
||
gfc_state_data s;
|
||
gfc_statement st;
|
||
|
||
accept_statement (ST_FORALL_BLOCK);
|
||
top = gfc_state_stack->tail;
|
||
|
||
push_state (&s, COMP_FORALL, gfc_new_block);
|
||
|
||
d = add_statement ();
|
||
d->op = EXEC_FORALL;
|
||
top->block = d;
|
||
|
||
do
|
||
{
|
||
st = next_statement ();
|
||
switch (st)
|
||
{
|
||
|
||
case ST_ASSIGNMENT:
|
||
case ST_POINTER_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_END_FORALL:
|
||
accept_statement (st);
|
||
break;
|
||
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
default:
|
||
gfc_error ("Unexpected %s statement in FORALL block at %C",
|
||
gfc_ascii_statement (st));
|
||
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_FORALL);
|
||
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
static gfc_statement parse_executable (gfc_statement);
|
||
|
||
/* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
|
||
|
||
static void
|
||
parse_if_block (void)
|
||
{
|
||
gfc_code *top, *d;
|
||
gfc_statement st;
|
||
locus else_locus;
|
||
gfc_state_data s;
|
||
int seen_else;
|
||
|
||
seen_else = 0;
|
||
accept_statement (ST_IF_BLOCK);
|
||
|
||
top = gfc_state_stack->tail;
|
||
push_state (&s, COMP_IF, gfc_new_block);
|
||
|
||
new_st.op = EXEC_IF;
|
||
d = add_statement ();
|
||
|
||
d->expr1 = top->expr1;
|
||
top->expr1 = NULL;
|
||
top->block = d;
|
||
|
||
do
|
||
{
|
||
st = parse_executable (ST_NONE);
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_ELSEIF:
|
||
if (seen_else)
|
||
{
|
||
gfc_error ("ELSE IF statement at %C cannot follow ELSE "
|
||
"statement at %L", &else_locus);
|
||
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
|
||
d = new_level (gfc_state_stack->head);
|
||
d->op = EXEC_IF;
|
||
d->expr1 = new_st.expr1;
|
||
|
||
accept_statement (st);
|
||
|
||
break;
|
||
|
||
case ST_ELSE:
|
||
if (seen_else)
|
||
{
|
||
gfc_error ("Duplicate ELSE statements at %L and %C",
|
||
&else_locus);
|
||
reject_statement ();
|
||
break;
|
||
}
|
||
|
||
seen_else = 1;
|
||
else_locus = gfc_current_locus;
|
||
|
||
d = new_level (gfc_state_stack->head);
|
||
d->op = EXEC_IF;
|
||
|
||
accept_statement (st);
|
||
|
||
break;
|
||
|
||
case ST_ENDIF:
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_ENDIF);
|
||
|
||
pop_state ();
|
||
accept_statement (st);
|
||
}
|
||
|
||
|
||
/* Parse a SELECT block. */
|
||
|
||
static void
|
||
parse_select_block (void)
|
||
{
|
||
gfc_statement st;
|
||
gfc_code *cp;
|
||
gfc_state_data s;
|
||
|
||
accept_statement (ST_SELECT_CASE);
|
||
|
||
cp = gfc_state_stack->tail;
|
||
push_state (&s, COMP_SELECT, gfc_new_block);
|
||
|
||
/* Make sure that the next statement is a CASE or END SELECT. */
|
||
for (;;)
|
||
{
|
||
st = next_statement ();
|
||
if (st == ST_NONE)
|
||
unexpected_eof ();
|
||
if (st == ST_END_SELECT)
|
||
{
|
||
/* Empty SELECT CASE is OK. */
|
||
accept_statement (st);
|
||
pop_state ();
|
||
return;
|
||
}
|
||
if (st == ST_CASE)
|
||
break;
|
||
|
||
gfc_error ("Expected a CASE or END SELECT statement following SELECT "
|
||
"CASE at %C");
|
||
|
||
reject_statement ();
|
||
}
|
||
|
||
/* At this point, we've got a nonempty select block. */
|
||
cp = new_level (cp);
|
||
*cp = new_st;
|
||
|
||
accept_statement (st);
|
||
|
||
do
|
||
{
|
||
st = parse_executable (ST_NONE);
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_CASE:
|
||
cp = new_level (gfc_state_stack->head);
|
||
*cp = new_st;
|
||
gfc_clear_new_st ();
|
||
|
||
accept_statement (st);
|
||
/* Fall through */
|
||
|
||
case ST_END_SELECT:
|
||
break;
|
||
|
||
/* Can't have an executable statement because of
|
||
parse_executable(). */
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_SELECT);
|
||
|
||
pop_state ();
|
||
accept_statement (st);
|
||
}
|
||
|
||
|
||
/* Pop the current selector from the SELECT TYPE stack. */
|
||
|
||
static void
|
||
select_type_pop (void)
|
||
{
|
||
gfc_select_type_stack *old = select_type_stack;
|
||
select_type_stack = old->prev;
|
||
free (old);
|
||
}
|
||
|
||
|
||
/* Parse a SELECT TYPE construct (F03:R821). */
|
||
|
||
static void
|
||
parse_select_type_block (void)
|
||
{
|
||
gfc_statement st;
|
||
gfc_code *cp;
|
||
gfc_state_data s;
|
||
|
||
gfc_current_ns = new_st.ext.block.ns;
|
||
accept_statement (ST_SELECT_TYPE);
|
||
|
||
cp = gfc_state_stack->tail;
|
||
push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
|
||
|
||
/* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
|
||
or END SELECT. */
|
||
for (;;)
|
||
{
|
||
st = next_statement ();
|
||
if (st == ST_NONE)
|
||
unexpected_eof ();
|
||
if (st == ST_END_SELECT)
|
||
/* Empty SELECT CASE is OK. */
|
||
goto done;
|
||
if (st == ST_TYPE_IS || st == ST_CLASS_IS)
|
||
break;
|
||
|
||
gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
|
||
"following SELECT TYPE at %C");
|
||
|
||
reject_statement ();
|
||
}
|
||
|
||
/* At this point, we've got a nonempty select block. */
|
||
cp = new_level (cp);
|
||
*cp = new_st;
|
||
|
||
accept_statement (st);
|
||
|
||
do
|
||
{
|
||
st = parse_executable (ST_NONE);
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_TYPE_IS:
|
||
case ST_CLASS_IS:
|
||
cp = new_level (gfc_state_stack->head);
|
||
*cp = new_st;
|
||
gfc_clear_new_st ();
|
||
|
||
accept_statement (st);
|
||
/* Fall through */
|
||
|
||
case ST_END_SELECT:
|
||
break;
|
||
|
||
/* Can't have an executable statement because of
|
||
parse_executable(). */
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_SELECT);
|
||
|
||
done:
|
||
pop_state ();
|
||
accept_statement (st);
|
||
gfc_current_ns = gfc_current_ns->parent;
|
||
select_type_pop ();
|
||
}
|
||
|
||
|
||
/* Parse a SELECT RANK construct. */
|
||
|
||
static void
|
||
parse_select_rank_block (void)
|
||
{
|
||
gfc_statement st;
|
||
gfc_code *cp;
|
||
gfc_state_data s;
|
||
|
||
gfc_current_ns = new_st.ext.block.ns;
|
||
accept_statement (ST_SELECT_RANK);
|
||
|
||
cp = gfc_state_stack->tail;
|
||
push_state (&s, COMP_SELECT_RANK, gfc_new_block);
|
||
|
||
/* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
|
||
for (;;)
|
||
{
|
||
st = next_statement ();
|
||
if (st == ST_NONE)
|
||
unexpected_eof ();
|
||
if (st == ST_END_SELECT)
|
||
/* Empty SELECT CASE is OK. */
|
||
goto done;
|
||
if (st == ST_RANK)
|
||
break;
|
||
|
||
gfc_error ("Expected RANK or RANK DEFAULT "
|
||
"following SELECT RANK at %C");
|
||
|
||
reject_statement ();
|
||
}
|
||
|
||
/* At this point, we've got a nonempty select block. */
|
||
cp = new_level (cp);
|
||
*cp = new_st;
|
||
|
||
accept_statement (st);
|
||
|
||
do
|
||
{
|
||
st = parse_executable (ST_NONE);
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_RANK:
|
||
cp = new_level (gfc_state_stack->head);
|
||
*cp = new_st;
|
||
gfc_clear_new_st ();
|
||
|
||
accept_statement (st);
|
||
/* Fall through */
|
||
|
||
case ST_END_SELECT:
|
||
break;
|
||
|
||
/* Can't have an executable statement because of
|
||
parse_executable(). */
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_SELECT);
|
||
|
||
done:
|
||
pop_state ();
|
||
accept_statement (st);
|
||
gfc_current_ns = gfc_current_ns->parent;
|
||
select_type_pop ();
|
||
}
|
||
|
||
|
||
/* Given a symbol, make sure it is not an iteration variable for a DO
|
||
statement. This subroutine is called when the symbol is seen in a
|
||
context that causes it to become redefined. If the symbol is an
|
||
iterator, we generate an error message and return nonzero. */
|
||
|
||
int
|
||
gfc_check_do_variable (gfc_symtree *st)
|
||
{
|
||
gfc_state_data *s;
|
||
|
||
if (!st)
|
||
return 0;
|
||
|
||
for (s=gfc_state_stack; s; s = s->previous)
|
||
if (s->do_variable == st)
|
||
{
|
||
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
|
||
an error) if it incorrectly closes an ENDDO. */
|
||
|
||
static int
|
||
check_do_closure (void)
|
||
{
|
||
gfc_state_data *p;
|
||
|
||
if (gfc_statement_label == NULL)
|
||
return 0;
|
||
|
||
for (p = gfc_state_stack; p; p = p->previous)
|
||
if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
|
||
break;
|
||
|
||
if (p == NULL)
|
||
return 0; /* No loops to close */
|
||
|
||
if (p->ext.end_do_label == gfc_statement_label)
|
||
{
|
||
if (p == gfc_state_stack)
|
||
return 1;
|
||
|
||
gfc_error ("End of nonblock DO statement at %C is within another block");
|
||
return 2;
|
||
}
|
||
|
||
/* 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->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");
|
||
return 2;
|
||
}
|
||
|
||
return 0;
|
||
}
|
||
|
||
|
||
/* Parse a series of contained program units. */
|
||
|
||
static void parse_progunit (gfc_statement);
|
||
|
||
|
||
/* Parse a CRITICAL block. */
|
||
|
||
static void
|
||
parse_critical_block (void)
|
||
{
|
||
gfc_code *top, *d;
|
||
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)
|
||
? G_("CRITICAL block inside of OpenACC region at %C")
|
||
: G_("CRITICAL block inside of OpenMP region at %C"));
|
||
|
||
s.ext.end_do_label = new_st.label1;
|
||
|
||
accept_statement (ST_CRITICAL);
|
||
top = gfc_state_stack->tail;
|
||
|
||
push_state (&s, COMP_CRITICAL, gfc_new_block);
|
||
|
||
d = add_statement ();
|
||
d->op = EXEC_CRITICAL;
|
||
top->block = d;
|
||
|
||
do
|
||
{
|
||
st = parse_executable (ST_NONE);
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
break;
|
||
|
||
case ST_END_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 CRITICAL label");
|
||
|
||
if (gfc_statement_label != NULL)
|
||
{
|
||
new_st.op = EXEC_NOP;
|
||
add_statement ();
|
||
}
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_CRITICAL);
|
||
|
||
pop_state ();
|
||
accept_statement (st);
|
||
}
|
||
|
||
|
||
/* Set up the local namespace for a BLOCK construct. */
|
||
|
||
gfc_namespace*
|
||
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;
|
||
|
||
/* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
|
||
code generation (so it must not be NULL).
|
||
We set its recursive argument if our container procedure is recursive, so
|
||
that local variables are accordingly placed on the stack when it
|
||
will be necessary. */
|
||
if (gfc_new_block)
|
||
my_ns->proc_name = gfc_new_block;
|
||
else
|
||
{
|
||
bool t;
|
||
char buffer[20]; /* Enough to hold "block@2147483648\n". */
|
||
|
||
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);
|
||
gfc_commit_symbol (my_ns->proc_name);
|
||
}
|
||
|
||
if (parent_ns->proc_name)
|
||
my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
|
||
|
||
return my_ns;
|
||
}
|
||
|
||
|
||
/* Parse a BLOCK construct. */
|
||
|
||
static void
|
||
parse_block_construct (void)
|
||
{
|
||
gfc_namespace* my_ns;
|
||
gfc_namespace* my_parent;
|
||
gfc_state_data s;
|
||
|
||
gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
|
||
|
||
my_ns = gfc_build_block_ns (gfc_current_ns);
|
||
|
||
new_st.op = EXEC_BLOCK;
|
||
new_st.ext.block.ns = my_ns;
|
||
new_st.ext.block.assoc = NULL;
|
||
accept_statement (ST_BLOCK);
|
||
|
||
push_state (&s, COMP_BLOCK, my_ns->proc_name);
|
||
gfc_current_ns = my_ns;
|
||
my_parent = my_ns->parent;
|
||
|
||
parse_progunit (ST_NONE);
|
||
|
||
/* 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 ();
|
||
}
|
||
|
||
|
||
/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
|
||
behind the scenes with compiler-generated variables. */
|
||
|
||
static void
|
||
parse_associate (void)
|
||
{
|
||
gfc_namespace* my_ns;
|
||
gfc_state_data s;
|
||
gfc_statement st;
|
||
gfc_association_list* a;
|
||
|
||
gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
|
||
|
||
my_ns = gfc_build_block_ns (gfc_current_ns);
|
||
|
||
new_st.op = EXEC_BLOCK;
|
||
new_st.ext.block.ns = my_ns;
|
||
gcc_assert (new_st.ext.block.assoc);
|
||
|
||
/* Add all associate-names as BLOCK variables. Creating them is enough
|
||
for now, they'll get their values during trans-* phase. */
|
||
gfc_current_ns = my_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 ();
|
||
|
||
sym = a->st->n.sym;
|
||
sym->attr.flavor = FL_VARIABLE;
|
||
sym->assoc = a;
|
||
sym->declared_at = a->where;
|
||
gfc_set_sym_referenced (sym);
|
||
|
||
/* Initialize the typespec. It is not available in all cases,
|
||
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 association to a derived-type. */
|
||
sym->ts = a->target->ts;
|
||
|
||
/* Don’t share the character length information between associate
|
||
variable and target if the length is not a compile-time constant,
|
||
as we don’t want to touch some other character length variable when
|
||
we try to initialize the associate variable’s character length
|
||
variable.
|
||
We do it here rather than later so that expressions referencing the
|
||
associate variable will automatically have the correctly setup length
|
||
information. If we did it at resolution stage the expressions would
|
||
use the original length information, and the variable a new different
|
||
one, but only the latter one would be correctly initialized at
|
||
translation stage, and the former one would need some additional setup
|
||
there. */
|
||
if (sym->ts.type == BT_CHARACTER
|
||
&& sym->ts.u.cl
|
||
&& !(sym->ts.u.cl->length
|
||
&& sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
|
||
sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
|
||
|
||
/* Check if the target expression is array valued. This cannot 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)
|
||
{
|
||
a->rankguessed = 1;
|
||
/* 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 && CLASS_DATA (sym))
|
||
{
|
||
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);
|
||
push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
|
||
|
||
loop:
|
||
st = parse_executable (ST_NONE);
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case_end:
|
||
accept_statement (st);
|
||
my_ns->code = gfc_state_stack->head;
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
goto loop;
|
||
}
|
||
|
||
gfc_current_ns = gfc_current_ns->parent;
|
||
pop_state ();
|
||
}
|
||
|
||
|
||
/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
|
||
handled inside of parse_executable(), because they aren't really
|
||
loop statements. */
|
||
|
||
static void
|
||
parse_do_block (void)
|
||
{
|
||
gfc_statement st;
|
||
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)
|
||
{
|
||
stree = new_st.ext.iterator->var->symtree;
|
||
if (directive_unroll != -1)
|
||
{
|
||
new_st.ext.iterator->unroll = directive_unroll;
|
||
directive_unroll = -1;
|
||
}
|
||
if (directive_ivdep)
|
||
{
|
||
new_st.ext.iterator->ivdep = directive_ivdep;
|
||
directive_ivdep = false;
|
||
}
|
||
if (directive_vector)
|
||
{
|
||
new_st.ext.iterator->vector = directive_vector;
|
||
directive_vector = false;
|
||
}
|
||
if (directive_novector)
|
||
{
|
||
new_st.ext.iterator->novector = directive_novector;
|
||
directive_novector = false;
|
||
}
|
||
}
|
||
else
|
||
stree = NULL;
|
||
|
||
accept_statement (ST_DO);
|
||
|
||
top = gfc_state_stack->tail;
|
||
push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
|
||
gfc_new_block);
|
||
|
||
s.do_variable = stree;
|
||
|
||
top->block = new_level (top);
|
||
top->block->op = EXEC_DO;
|
||
|
||
loop:
|
||
st = parse_executable (ST_NONE);
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_ENDDO:
|
||
if (s.ext.end_do_label != NULL
|
||
&& s.ext.end_do_label != gfc_statement_label)
|
||
gfc_error_now ("Statement label in ENDDO at %C doesn't match "
|
||
"DO label");
|
||
|
||
if (gfc_statement_label != NULL)
|
||
{
|
||
new_st.op = EXEC_NOP;
|
||
add_statement ();
|
||
}
|
||
break;
|
||
|
||
case ST_IMPLIED_ENDDO:
|
||
/* If the do-stmt of this DO construct has a do-construct-name,
|
||
the corresponding end-do must be an end-do-stmt (with a matching
|
||
name, but in that case we must have seen ST_ENDDO first).
|
||
We only complain about this in pedantic mode. */
|
||
if (gfc_current_block () != NULL)
|
||
gfc_error_now ("Named block DO at %L requires matching ENDDO name",
|
||
&gfc_current_block()->declared_at);
|
||
|
||
break;
|
||
|
||
default:
|
||
unexpected_statement (st);
|
||
goto loop;
|
||
}
|
||
|
||
pop_state ();
|
||
accept_statement (st);
|
||
}
|
||
|
||
|
||
/* 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 ();
|
||
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_LOOP: omp_end_st = ST_OMP_END_LOOP; 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_PARALLEL_LOOP:
|
||
omp_end_st = ST_OMP_END_PARALLEL_LOOP;
|
||
break;
|
||
case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
|
||
case ST_OMP_TARGET_PARALLEL_DO:
|
||
omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
|
||
break;
|
||
case ST_OMP_TARGET_PARALLEL_LOOP:
|
||
omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP;
|
||
break;
|
||
case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_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_TARGET_TEAMS_LOOP:
|
||
omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP;
|
||
break;
|
||
case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
|
||
case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
|
||
case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break;
|
||
case ST_OMP_MASKED_TASKLOOP_SIMD:
|
||
omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD;
|
||
break;
|
||
case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break;
|
||
case ST_OMP_MASTER_TASKLOOP_SIMD:
|
||
omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD;
|
||
break;
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
|
||
break;
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_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;
|
||
case ST_OMP_TEAMS_LOOP:
|
||
omp_end_st = ST_OMP_END_TEAMS_LOOP;
|
||
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;
|
||
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 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;
|
||
np->ext.omp_clauses = cp->ext.omp_clauses;
|
||
cp->ext.omp_clauses = NULL;
|
||
count = 1 + np->ext.omp_clauses->capture;
|
||
|
||
while (count)
|
||
{
|
||
st = next_statement ();
|
||
if (st == ST_NONE)
|
||
unexpected_eof ();
|
||
else if (np->ext.omp_clauses->compare
|
||
&& (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
|
||
{
|
||
count--;
|
||
if (st == ST_IF_BLOCK)
|
||
{
|
||
parse_if_block ();
|
||
/* With else (or elseif). */
|
||
if (gfc_state_stack->tail->block->block)
|
||
count--;
|
||
}
|
||
accept_statement (st);
|
||
}
|
||
else if (st == ST_ASSIGNMENT
|
||
&& (!np->ext.omp_clauses->compare
|
||
|| np->ext.omp_clauses->capture))
|
||
{
|
||
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 ();
|
||
}
|
||
return st;
|
||
}
|
||
|
||
|
||
/* Parse the statements of an OpenACC structured block. */
|
||
|
||
static 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_SERIAL:
|
||
acc_end_st = ST_OACC_END_SERIAL;
|
||
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', or combined compute 'loop'. */
|
||
|
||
static gfc_statement
|
||
parse_oacc_loop (gfc_statement acc_st)
|
||
{
|
||
gfc_statement 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;
|
||
|
||
for (;;)
|
||
{
|
||
st = next_statement ();
|
||
if (st == ST_NONE)
|
||
unexpected_eof ();
|
||
else if (st == ST_DO)
|
||
break;
|
||
else
|
||
{
|
||
gfc_error ("Expected DO loop at %C");
|
||
reject_statement ();
|
||
}
|
||
}
|
||
|
||
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_SERIAL_LOOP && st == ST_OACC_END_SERIAL_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;
|
||
}
|
||
|
||
|
||
/* Parse the statements of an OpenMP structured block. */
|
||
|
||
static gfc_statement
|
||
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_MASKED:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASKED;
|
||
break;
|
||
case ST_OMP_PARALLEL_MASTER:
|
||
omp_end_st = ST_OMP_END_PARALLEL_MASTER;
|
||
break;
|
||
case ST_OMP_PARALLEL_SECTIONS:
|
||
omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
|
||
break;
|
||
case ST_OMP_SCOPE:
|
||
omp_end_st = ST_OMP_END_SCOPE;
|
||
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_MASKED:
|
||
omp_end_st = ST_OMP_END_MASKED;
|
||
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_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_PARALLEL:
|
||
omp_end_st = ST_OMP_END_TARGET_PARALLEL;
|
||
break;
|
||
case ST_OMP_TARGET_TEAMS:
|
||
omp_end_st = ST_OMP_END_TARGET_TEAMS;
|
||
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_DISTRIBUTE:
|
||
omp_end_st = ST_OMP_END_DISTRIBUTE;
|
||
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 ();
|
||
}
|
||
|
||
bool block_construct = false;
|
||
gfc_namespace *my_ns = NULL;
|
||
gfc_namespace *my_parent = NULL;
|
||
|
||
st = next_statement ();
|
||
|
||
if (st == ST_BLOCK)
|
||
{
|
||
/* Adjust state to a strictly-structured block, now that we found that
|
||
the body starts with a BLOCK construct. */
|
||
s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
|
||
|
||
block_construct = true;
|
||
gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
|
||
|
||
my_ns = gfc_build_block_ns (gfc_current_ns);
|
||
gfc_current_ns = my_ns;
|
||
my_parent = my_ns->parent;
|
||
|
||
new_st.op = EXEC_BLOCK;
|
||
new_st.ext.block.ns = my_ns;
|
||
new_st.ext.block.assoc = NULL;
|
||
accept_statement (ST_BLOCK);
|
||
st = parse_spec (ST_NONE);
|
||
}
|
||
|
||
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;
|
||
|
||
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_MASKED:
|
||
case ST_OMP_PARALLEL_MASTER:
|
||
case ST_OMP_PARALLEL_SECTIONS:
|
||
st = parse_omp_structured_block (st, false);
|
||
continue;
|
||
|
||
case ST_OMP_PARALLEL_WORKSHARE:
|
||
case ST_OMP_CRITICAL:
|
||
st = parse_omp_structured_block (st, true);
|
||
continue;
|
||
|
||
case ST_OMP_PARALLEL_DO:
|
||
case ST_OMP_PARALLEL_DO_SIMD:
|
||
st = parse_omp_do (st);
|
||
continue;
|
||
|
||
case ST_OMP_ATOMIC:
|
||
st = parse_omp_oacc_atomic (true);
|
||
continue;
|
||
|
||
default:
|
||
cycle = false;
|
||
break;
|
||
}
|
||
|
||
if (!cycle)
|
||
break;
|
||
|
||
st = next_statement ();
|
||
}
|
||
}
|
||
else
|
||
st = parse_executable (st);
|
||
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;
|
||
st = next_statement ();
|
||
}
|
||
else if (block_construct && st == ST_END_BLOCK)
|
||
{
|
||
accept_statement (st);
|
||
gfc_current_ns = my_parent;
|
||
pop_state ();
|
||
|
||
st = next_statement ();
|
||
if (st == omp_end_st)
|
||
{
|
||
accept_statement (st);
|
||
st = next_statement ();
|
||
}
|
||
return st;
|
||
}
|
||
else if (st != omp_end_st)
|
||
{
|
||
unexpected_statement (st);
|
||
st = next_statement ();
|
||
}
|
||
}
|
||
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_END_CRITICAL:
|
||
if (((cp->ext.omp_clauses->critical_name == NULL)
|
||
^ (new_st.ext.omp_name == NULL))
|
||
|| (new_st.ext.omp_name != NULL
|
||
&& strcmp (cp->ext.omp_clauses->critical_name,
|
||
new_st.ext.omp_name) != 0))
|
||
gfc_error ("Name after !$omp critical and !$omp end critical does "
|
||
"not match at %C");
|
||
free (CONST_CAST (char *, new_st.ext.omp_name));
|
||
new_st.ext.omp_name = NULL;
|
||
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 ();
|
||
st = next_statement ();
|
||
return st;
|
||
}
|
||
|
||
|
||
/* 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
|
||
right back here. */
|
||
|
||
static gfc_statement
|
||
parse_executable (gfc_statement st)
|
||
{
|
||
int close_flag;
|
||
|
||
if (st == ST_NONE)
|
||
st = next_statement ();
|
||
|
||
for (;;)
|
||
{
|
||
close_flag = check_do_closure ();
|
||
if (close_flag)
|
||
switch (st)
|
||
{
|
||
case ST_GOTO:
|
||
case ST_END_PROGRAM:
|
||
case ST_RETURN:
|
||
case ST_EXIT:
|
||
case ST_END_FUNCTION:
|
||
case ST_CYCLE:
|
||
case ST_PAUSE:
|
||
case ST_STOP:
|
||
case ST_ERROR_STOP:
|
||
case ST_END_SUBROUTINE:
|
||
|
||
case ST_DO:
|
||
case ST_FORALL:
|
||
case ST_WHERE:
|
||
case ST_SELECT_CASE:
|
||
gfc_error ("%s statement at %C cannot terminate a non-block "
|
||
"DO loop", gfc_ascii_statement (st));
|
||
break;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
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);
|
||
if (close_flag == 1)
|
||
return ST_IMPLIED_ENDDO;
|
||
break;
|
||
|
||
case ST_BLOCK:
|
||
parse_block_construct ();
|
||
break;
|
||
|
||
case ST_ASSOCIATE:
|
||
parse_associate ();
|
||
break;
|
||
|
||
case ST_IF_BLOCK:
|
||
parse_if_block ();
|
||
break;
|
||
|
||
case ST_SELECT_CASE:
|
||
parse_select_block ();
|
||
break;
|
||
|
||
case ST_SELECT_TYPE:
|
||
parse_select_type_block ();
|
||
break;
|
||
|
||
case ST_SELECT_RANK:
|
||
parse_select_rank_block ();
|
||
break;
|
||
|
||
case ST_DO:
|
||
parse_do_block ();
|
||
if (check_do_closure () == 1)
|
||
return ST_IMPLIED_ENDDO;
|
||
break;
|
||
|
||
case ST_CRITICAL:
|
||
parse_critical_block ();
|
||
break;
|
||
|
||
case ST_WHERE_BLOCK:
|
||
parse_where_block ();
|
||
break;
|
||
|
||
case ST_FORALL_BLOCK:
|
||
parse_forall_block ();
|
||
break;
|
||
|
||
case ST_OACC_PARALLEL_LOOP:
|
||
case ST_OACC_KERNELS_LOOP:
|
||
case ST_OACC_SERIAL_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_SERIAL:
|
||
case ST_OACC_DATA:
|
||
case ST_OACC_HOST_DATA:
|
||
parse_oacc_structured_block (st);
|
||
break;
|
||
|
||
case ST_OMP_PARALLEL:
|
||
case ST_OMP_PARALLEL_MASKED:
|
||
case ST_OMP_PARALLEL_MASTER:
|
||
case ST_OMP_PARALLEL_SECTIONS:
|
||
case ST_OMP_ORDERED:
|
||
case ST_OMP_CRITICAL:
|
||
case ST_OMP_MASKED:
|
||
case ST_OMP_MASTER:
|
||
case ST_OMP_SCOPE:
|
||
case ST_OMP_SECTIONS:
|
||
case ST_OMP_SINGLE:
|
||
case ST_OMP_TARGET:
|
||
case ST_OMP_TARGET_DATA:
|
||
case ST_OMP_TARGET_PARALLEL:
|
||
case ST_OMP_TARGET_TEAMS:
|
||
case ST_OMP_TEAMS:
|
||
case ST_OMP_TASK:
|
||
case ST_OMP_TASKGROUP:
|
||
st = parse_omp_structured_block (st, false);
|
||
continue;
|
||
|
||
case ST_OMP_WORKSHARE:
|
||
case ST_OMP_PARALLEL_WORKSHARE:
|
||
st = parse_omp_structured_block (st, true);
|
||
continue;
|
||
|
||
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_LOOP:
|
||
case ST_OMP_PARALLEL_DO:
|
||
case ST_OMP_PARALLEL_DO_SIMD:
|
||
case ST_OMP_PARALLEL_LOOP:
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP:
|
||
case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP:
|
||
case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
|
||
case ST_OMP_MASKED_TASKLOOP:
|
||
case ST_OMP_MASKED_TASKLOOP_SIMD:
|
||
case ST_OMP_MASTER_TASKLOOP:
|
||
case ST_OMP_MASTER_TASKLOOP_SIMD:
|
||
case ST_OMP_SIMD:
|
||
case ST_OMP_TARGET_PARALLEL_DO:
|
||
case ST_OMP_TARGET_PARALLEL_DO_SIMD:
|
||
case ST_OMP_TARGET_PARALLEL_LOOP:
|
||
case ST_OMP_TARGET_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_TARGET_TEAMS_LOOP:
|
||
case ST_OMP_TASKLOOP:
|
||
case ST_OMP_TASKLOOP_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:
|
||
case ST_OMP_TEAMS_LOOP:
|
||
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:
|
||
st = parse_omp_oacc_atomic (true);
|
||
continue;
|
||
|
||
default:
|
||
return st;
|
||
}
|
||
|
||
if (directive_unroll != -1)
|
||
gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
|
||
|
||
if (directive_ivdep)
|
||
gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
|
||
|
||
if (directive_vector)
|
||
gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
|
||
|
||
if (directive_novector)
|
||
gfc_error ("%<GCC novector%> "
|
||
"directive not at the start of a loop at %C");
|
||
|
||
st = next_statement ();
|
||
}
|
||
}
|
||
|
||
|
||
/* Fix the symbols for sibling functions. These are incorrectly added to
|
||
the child namespace as the parser didn't know about this procedure. */
|
||
|
||
static void
|
||
gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
|
||
{
|
||
gfc_namespace *ns;
|
||
gfc_symtree *st;
|
||
gfc_symbol *old_sym;
|
||
|
||
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
|
||
|
||
/* By 14.6.1.3, host association should be excluded
|
||
for the following. */
|
||
&& !(old_sym->attr.external
|
||
|| (old_sym->ts.type != BT_UNKNOWN
|
||
&& !old_sym->attr.implicit_type)
|
||
|| old_sym->attr.flavor == FL_PARAMETER
|
||
|| old_sym->attr.use_assoc
|
||
|| old_sym->attr.in_common
|
||
|| old_sym->attr.in_equivalence
|
||
|| old_sym->attr.data
|
||
|| old_sym->attr.dummy
|
||
|| old_sym->attr.result
|
||
|| old_sym->attr.dimension
|
||
|| old_sym->attr.allocatable
|
||
|| 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. */
|
||
st->n.sym = sym;
|
||
sym->refs++;
|
||
|
||
gfc_release_symbol (old_sym);
|
||
}
|
||
|
||
fixup_contained:
|
||
/* Do the same for any contained procedures. */
|
||
gfc_fixup_sibling_symbols (sym, ns->contained);
|
||
}
|
||
}
|
||
|
||
static void
|
||
parse_contained (int module)
|
||
{
|
||
gfc_namespace *ns, *parent_ns, *tmp;
|
||
gfc_state_data s1, s2;
|
||
gfc_statement st;
|
||
gfc_symbol *sym;
|
||
gfc_entry_list *el;
|
||
locus old_loc;
|
||
int contains_statements = 0;
|
||
int seen_error = 0;
|
||
|
||
push_state (&s1, COMP_CONTAINS, NULL);
|
||
parent_ns = gfc_current_ns;
|
||
|
||
do
|
||
{
|
||
gfc_current_ns = gfc_get_namespace (parent_ns, 1);
|
||
|
||
gfc_current_ns->sibling = parent_ns->contained;
|
||
parent_ns->contained = gfc_current_ns;
|
||
|
||
next:
|
||
/* Process the next available statement. We come here if we got an error
|
||
and rejected the last statement. */
|
||
old_loc = gfc_current_locus;
|
||
st = next_statement ();
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_FUNCTION:
|
||
case ST_SUBROUTINE:
|
||
contains_statements = 1;
|
||
accept_statement (st);
|
||
|
||
push_state (&s2,
|
||
(st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
|
||
gfc_new_block);
|
||
|
||
/* For internal procedures, create/update the symbol in the
|
||
parent namespace. */
|
||
|
||
if (!module)
|
||
{
|
||
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
|
||
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))
|
||
{
|
||
if (st == ST_FUNCTION)
|
||
gfc_add_function (&sym->attr, sym->name,
|
||
&gfc_new_block->declared_at);
|
||
else
|
||
gfc_add_subroutine (&sym->attr, sym->name,
|
||
&gfc_new_block->declared_at);
|
||
}
|
||
}
|
||
|
||
gfc_commit_symbols ();
|
||
}
|
||
else
|
||
sym = gfc_new_block;
|
||
|
||
/* Mark this as a contained function, so it isn't replaced
|
||
by other module functions. */
|
||
sym->attr.contained = 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);
|
||
|
||
/* Fix up any sibling functions that refer to this one. */
|
||
gfc_fixup_sibling_symbols (sym, gfc_current_ns);
|
||
/* Or refer to any of its alternate entry points. */
|
||
for (el = gfc_current_ns->entries; el; el = el->next)
|
||
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
|
||
|
||
gfc_current_ns->code = s2.head;
|
||
gfc_current_ns = parent_ns;
|
||
|
||
pop_state ();
|
||
break;
|
||
|
||
/* 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:
|
||
gfc_error ("Unexpected %s statement in CONTAINS section at %C",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
seen_error = 1;
|
||
goto next;
|
||
break;
|
||
}
|
||
}
|
||
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
|
||
&& 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. */
|
||
tmp = gfc_current_ns;
|
||
gfc_current_ns = parent_ns;
|
||
if (seen_error && tmp->refs > 1)
|
||
gfc_free_namespace (tmp);
|
||
|
||
ns = gfc_current_ns->contained;
|
||
gfc_current_ns->contained = ns->sibling;
|
||
gfc_free_namespace (ns);
|
||
|
||
pop_state ();
|
||
if (!contains_statements)
|
||
gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
|
||
"FUNCTION or SUBROUTINE statement at %L", &old_loc);
|
||
}
|
||
|
||
|
||
/* 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->tlink
|
||
&& proc->tlink->result
|
||
&& proc->tlink->result != proc->tlink)
|
||
{
|
||
gfc_copy_dummy_sym (&proc->result, proc->tlink->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
|
||
parse_progunit (gfc_statement st)
|
||
{
|
||
gfc_state_data *p;
|
||
int n;
|
||
|
||
gfc_adjust_builtins ();
|
||
|
||
if (gfc_new_block
|
||
&& gfc_new_block->abr_modproc_decl
|
||
&& gfc_new_block->attr.function)
|
||
get_modproc_result ();
|
||
|
||
st = parse_spec (st);
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_CONTAINS:
|
||
/* This is not allowed within BLOCK! */
|
||
if (gfc_current_state () != COMP_BLOCK)
|
||
goto contains;
|
||
break;
|
||
|
||
case_end:
|
||
accept_statement (st);
|
||
goto done;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
if (gfc_current_state () == COMP_FUNCTION)
|
||
gfc_check_function_type (gfc_current_ns);
|
||
|
||
loop:
|
||
for (;;)
|
||
{
|
||
st = parse_executable (st);
|
||
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_CONTAINS:
|
||
/* This is not allowed within BLOCK! */
|
||
if (gfc_current_state () != COMP_BLOCK)
|
||
goto contains;
|
||
break;
|
||
|
||
case_end:
|
||
accept_statement (st);
|
||
goto done;
|
||
|
||
default:
|
||
break;
|
||
}
|
||
|
||
unexpected_statement (st);
|
||
reject_statement ();
|
||
st = next_statement ();
|
||
}
|
||
|
||
contains:
|
||
n = 0;
|
||
|
||
for (p = gfc_state_stack; p; p = p->previous)
|
||
if (p->state == COMP_CONTAINS)
|
||
n++;
|
||
|
||
if (gfc_find_state (COMP_MODULE) == true
|
||
|| gfc_find_state (COMP_SUBMODULE) == true)
|
||
n--;
|
||
|
||
if (n > 0)
|
||
{
|
||
gfc_error ("CONTAINS statement at %C is already in a contained "
|
||
"program unit");
|
||
reject_statement ();
|
||
st = next_statement ();
|
||
goto loop;
|
||
}
|
||
|
||
parse_contained (0);
|
||
|
||
done:
|
||
gfc_current_ns->code = gfc_state_stack->head;
|
||
}
|
||
|
||
|
||
/* Come here to complain about a global symbol already in use as
|
||
something else. */
|
||
|
||
void
|
||
gfc_global_used (gfc_gsymbol *sym, locus *where)
|
||
{
|
||
const char *name;
|
||
|
||
if (where == NULL)
|
||
where = &gfc_current_locus;
|
||
|
||
switch(sym->type)
|
||
{
|
||
case GSYM_PROGRAM:
|
||
name = "PROGRAM";
|
||
break;
|
||
case GSYM_FUNCTION:
|
||
name = "FUNCTION";
|
||
break;
|
||
case GSYM_SUBROUTINE:
|
||
name = "SUBROUTINE";
|
||
break;
|
||
case GSYM_COMMON:
|
||
name = "COMMON";
|
||
break;
|
||
case GSYM_BLOCK_DATA:
|
||
name = "BLOCK DATA";
|
||
break;
|
||
case GSYM_MODULE:
|
||
name = "MODULE";
|
||
break;
|
||
default:
|
||
name = NULL;
|
||
}
|
||
|
||
if (name)
|
||
{
|
||
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);
|
||
}
|
||
else
|
||
{
|
||
if (sym->binding_label)
|
||
gfc_error ("Global binding name %qs at %L is already being used "
|
||
"at %L", sym->binding_label, where, &sym->where);
|
||
else
|
||
gfc_error ("Global name %qs at %L is already being used at %L",
|
||
sym->name, where, &sym->where);
|
||
}
|
||
}
|
||
|
||
|
||
/* Parse a block data program unit. */
|
||
|
||
static void
|
||
parse_block_data (void)
|
||
{
|
||
gfc_statement st;
|
||
static locus blank_locus;
|
||
static int blank_block=0;
|
||
gfc_gsymbol *s;
|
||
|
||
gfc_current_ns->proc_name = gfc_new_block;
|
||
gfc_current_ns->is_block_data = 1;
|
||
|
||
if (gfc_new_block == NULL)
|
||
{
|
||
if (blank_block)
|
||
gfc_error ("Blank BLOCK DATA at %C conflicts with "
|
||
"prior BLOCK DATA at %L", &blank_locus);
|
||
else
|
||
{
|
||
blank_block = 1;
|
||
blank_locus = gfc_current_locus;
|
||
}
|
||
}
|
||
else
|
||
{
|
||
s = gfc_get_gsymbol (gfc_new_block->name, false);
|
||
if (s->defined
|
||
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
|
||
gfc_global_used (s, &gfc_new_block->declared_at);
|
||
else
|
||
{
|
||
s->type = GSYM_BLOCK_DATA;
|
||
s->where = gfc_new_block->declared_at;
|
||
s->defined = 1;
|
||
}
|
||
}
|
||
|
||
st = parse_spec (ST_NONE);
|
||
|
||
while (st != ST_END_BLOCK_DATA)
|
||
{
|
||
gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
|
||
gfc_ascii_statement (st));
|
||
reject_statement ();
|
||
st = next_statement ();
|
||
}
|
||
}
|
||
|
||
|
||
/* 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;
|
||
const char dot[2] = ".";
|
||
/* Symbols take the form module.submodule_ or module.name_. */
|
||
char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
|
||
char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
|
||
|
||
if (sym == NULL)
|
||
return;
|
||
|
||
if (sym->attr.module_procedure)
|
||
sym->attr.external = 0;
|
||
|
||
sym->attr.use_assoc = 0;
|
||
sym->attr.host_assoc = 1;
|
||
sym->attr.used_in_submodule =1;
|
||
|
||
if (sym->attr.flavor == FL_DERIVED)
|
||
{
|
||
/* Derived types with PRIVATE components that are declared in
|
||
modules other than the parent module must not be changed to be
|
||
PUBLIC. The 'use-assoc' attribute must be reset so that the
|
||
test in symbol.cc(gfc_find_component) works correctly. This is
|
||
not necessary for PRIVATE symbols since they are not read from
|
||
the module. */
|
||
memset(parent1, '\0', sizeof(parent1));
|
||
memset(parent2, '\0', sizeof(parent2));
|
||
strcpy (parent1, gfc_new_block->name);
|
||
strcpy (parent2, sym->module);
|
||
if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
|
||
{
|
||
for (c = sym->components; c; c = c->next)
|
||
c->attr.access = ACCESS_PUBLIC;
|
||
}
|
||
else
|
||
{
|
||
sym->attr.use_assoc = 1;
|
||
sym->attr.host_assoc = 0;
|
||
}
|
||
}
|
||
}
|
||
|
||
/* Parse a module subprogram. */
|
||
|
||
static void
|
||
parse_module (void)
|
||
{
|
||
gfc_statement st;
|
||
gfc_gsymbol *s;
|
||
bool error;
|
||
|
||
s = gfc_get_gsymbol (gfc_new_block->name, false);
|
||
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
|
||
gfc_global_used (s, &gfc_new_block->declared_at);
|
||
else
|
||
{
|
||
s->type = GSYM_MODULE;
|
||
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)
|
||
{
|
||
case ST_NONE:
|
||
unexpected_eof ();
|
||
|
||
case ST_CONTAINS:
|
||
parse_contained (1);
|
||
break;
|
||
|
||
case ST_END_MODULE:
|
||
case ST_END_SUBMODULE:
|
||
accept_statement (st);
|
||
break;
|
||
|
||
default:
|
||
gfc_error ("Unexpected %s statement in MODULE at %C",
|
||
gfc_ascii_statement (st));
|
||
|
||
error = true;
|
||
reject_statement ();
|
||
st = next_statement ();
|
||
goto loop;
|
||
}
|
||
|
||
/* 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 (bool sub)
|
||
{
|
||
gfc_gsymbol *s;
|
||
|
||
/* 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, false);
|
||
|
||
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 = gfc_get_gsymbol (gfc_new_block->binding_label, true);
|
||
|
||
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;
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
/* Add a program to the global symbol table. */
|
||
|
||
static void
|
||
add_global_program (void)
|
||
{
|
||
gfc_gsymbol *s;
|
||
|
||
if (gfc_new_block == NULL)
|
||
return;
|
||
s = gfc_get_gsymbol (gfc_new_block->name, false);
|
||
|
||
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
|
||
gfc_global_used (s, &gfc_new_block->declared_at);
|
||
else
|
||
{
|
||
s->type = GSYM_PROGRAM;
|
||
s->where = gfc_new_block->declared_at;
|
||
s->defined = 1;
|
||
s->ns = gfc_current_ns;
|
||
}
|
||
}
|
||
|
||
|
||
/* Resolve all the program units. */
|
||
static void
|
||
resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
|
||
{
|
||
gfc_derived_types = NULL;
|
||
gfc_current_ns = gfc_global_ns_list;
|
||
for (; 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; /* 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;
|
||
}
|
||
}
|
||
|
||
|
||
static void
|
||
clean_up_modules (gfc_gsymbol *&gsym)
|
||
{
|
||
if (gsym == NULL)
|
||
return;
|
||
|
||
clean_up_modules (gsym->left);
|
||
clean_up_modules (gsym->right);
|
||
|
||
if (gsym->type != GSYM_MODULE)
|
||
return;
|
||
|
||
if (gsym->ns)
|
||
{
|
||
gfc_current_ns = gsym->ns;
|
||
gfc_derived_types = gfc_current_ns->derived_types;
|
||
gfc_done_2 ();
|
||
gsym->ns = NULL;
|
||
}
|
||
free (gsym);
|
||
gsym = NULL;
|
||
}
|
||
|
||
|
||
/* 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)
|
||
{
|
||
int errors;
|
||
|
||
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->translated = 1;
|
||
}
|
||
|
||
/* Clean up all the namespaces after translation. */
|
||
gfc_current_ns = gfc_global_ns_list;
|
||
for (;gfc_current_ns;)
|
||
{
|
||
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;
|
||
}
|
||
|
||
clean_up_modules (gfc_gsym_root);
|
||
}
|
||
|
||
|
||
/* Top level parser. */
|
||
|
||
bool
|
||
gfc_parse_file (void)
|
||
{
|
||
int seen_program, errors_before, errors;
|
||
gfc_state_data top, s;
|
||
gfc_statement st;
|
||
locus prog_locus;
|
||
gfc_namespace *next;
|
||
|
||
gfc_start_source_files ();
|
||
|
||
top.state = COMP_NONE;
|
||
top.sym = NULL;
|
||
top.previous = NULL;
|
||
top.head = top.tail = NULL;
|
||
top.do_variable = NULL;
|
||
|
||
gfc_state_stack = ⊤
|
||
|
||
gfc_clear_new_st ();
|
||
|
||
gfc_statement_label = NULL;
|
||
|
||
if (setjmp (eof_buf))
|
||
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 ();
|
||
switch (st)
|
||
{
|
||
case ST_NONE:
|
||
gfc_done_2 ();
|
||
goto done;
|
||
|
||
case ST_PROGRAM:
|
||
if (seen_program)
|
||
goto duplicate_main;
|
||
seen_program = 1;
|
||
prog_locus = gfc_current_locus;
|
||
|
||
push_state (&s, COMP_PROGRAM, gfc_new_block);
|
||
main_program_symbol (gfc_current_ns, gfc_new_block->name);
|
||
accept_statement (st);
|
||
add_global_program ();
|
||
parse_progunit (ST_NONE);
|
||
goto prog_units;
|
||
|
||
case ST_SUBROUTINE:
|
||
add_global_procedure (true);
|
||
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
|
||
accept_statement (st);
|
||
parse_progunit (ST_NONE);
|
||
goto prog_units;
|
||
|
||
case ST_FUNCTION:
|
||
add_global_procedure (false);
|
||
push_state (&s, COMP_FUNCTION, gfc_new_block);
|
||
accept_statement (st);
|
||
parse_progunit (ST_NONE);
|
||
goto prog_units;
|
||
|
||
case ST_BLOCK_DATA:
|
||
push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
|
||
accept_statement (st);
|
||
parse_block_data ();
|
||
break;
|
||
|
||
case ST_MODULE:
|
||
push_state (&s, COMP_MODULE, gfc_new_block);
|
||
accept_statement (st);
|
||
|
||
gfc_get_errors (NULL, &errors_before);
|
||
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)
|
||
goto duplicate_main;
|
||
seen_program = 1;
|
||
prog_locus = gfc_current_locus;
|
||
|
||
push_state (&s, COMP_PROGRAM, gfc_new_block);
|
||
main_program_symbol (gfc_current_ns, "MAIN__");
|
||
parse_progunit (st);
|
||
goto prog_units;
|
||
}
|
||
|
||
/* Handle the non-program units. */
|
||
gfc_current_ns->code = s.head;
|
||
|
||
gfc_resolve (gfc_current_ns);
|
||
|
||
/* Fix the implicit_pure attribute for those procedures who should
|
||
not have it. */
|
||
while (gfc_fix_implicit_pure (gfc_current_ns))
|
||
;
|
||
|
||
/* Dump the parse tree if requested. */
|
||
if (flag_dump_fortran_original)
|
||
gfc_dump_parse_tree (gfc_current_ns, stdout);
|
||
|
||
gfc_get_errors (NULL, &errors);
|
||
if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
|
||
{
|
||
gfc_dump_module (s.sym->name, errors_before == errors);
|
||
gfc_current_ns->derived_types = gfc_derived_types;
|
||
gfc_derived_types = NULL;
|
||
goto prog_units;
|
||
}
|
||
else
|
||
{
|
||
if (errors == 0)
|
||
gfc_generate_code (gfc_current_ns);
|
||
pop_state ();
|
||
gfc_done_2 ();
|
||
}
|
||
|
||
goto loop;
|
||
|
||
prog_units:
|
||
/* The main program and non-contained procedures are put
|
||
in the global namespace list, so that they can be processed
|
||
later and all their interfaces resolved. */
|
||
gfc_current_ns->code = s.head;
|
||
if (next)
|
||
{
|
||
for (; next->sibling; next = next->sibling)
|
||
;
|
||
next->sibling = gfc_current_ns;
|
||
}
|
||
else
|
||
gfc_global_ns_list = gfc_current_ns;
|
||
|
||
next = gfc_current_ns;
|
||
|
||
pop_state ();
|
||
goto loop;
|
||
|
||
done:
|
||
/* Do the resolution. */
|
||
resolve_all_program_units (gfc_global_ns_list);
|
||
|
||
/* Go through all top-level namespaces and unset the implicit_pure
|
||
attribute for any procedures that call something not pure or
|
||
implicit_pure. Because the a procedure marked as not implicit_pure
|
||
in one sweep may be called by another routine, we repeat this
|
||
process until there are no more changes. */
|
||
bool changed;
|
||
do
|
||
{
|
||
changed = false;
|
||
for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
|
||
gfc_current_ns = gfc_current_ns->sibling)
|
||
{
|
||
if (gfc_fix_implicit_pure (gfc_current_ns))
|
||
changed = true;
|
||
}
|
||
}
|
||
while (changed);
|
||
|
||
/* Fixup for external procedures and resolve 'omp requires'. */
|
||
int omp_requires;
|
||
omp_requires = 0;
|
||
for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
|
||
gfc_current_ns = gfc_current_ns->sibling)
|
||
{
|
||
omp_requires |= gfc_current_ns->omp_requires;
|
||
gfc_check_externals (gfc_current_ns);
|
||
}
|
||
for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
|
||
gfc_current_ns = gfc_current_ns->sibling)
|
||
gfc_check_omp_requires (gfc_current_ns, omp_requires);
|
||
|
||
/* Populate omp_requires_mask (needed for resolving OpenMP
|
||
metadirectives and declare variant). */
|
||
switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
|
||
{
|
||
case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
|
||
omp_requires_mask
|
||
= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
|
||
break;
|
||
case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
|
||
omp_requires_mask
|
||
= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
|
||
break;
|
||
case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
|
||
omp_requires_mask
|
||
= (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
|
||
break;
|
||
}
|
||
|
||
/* Do the parse tree dump. */
|
||
gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
|
||
|
||
for (; 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)
|
||
{
|
||
gfc_dump_parse_tree (gfc_current_ns, stdout);
|
||
fputs ("------------------------------------------\n\n", stdout);
|
||
}
|
||
|
||
/* Dump C prototypes. */
|
||
if (flag_c_prototypes || flag_c_prototypes_external)
|
||
{
|
||
fprintf (stdout,
|
||
"#include <stddef.h>\n"
|
||
"#ifdef __cplusplus\n"
|
||
"#include <complex>\n"
|
||
"#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
|
||
"#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
|
||
"#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
|
||
"extern \"C\" {\n"
|
||
"#else\n"
|
||
"#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
|
||
"#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
|
||
"#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
|
||
"#endif\n\n");
|
||
}
|
||
|
||
/* First dump BIND(C) prototypes. */
|
||
if (flag_c_prototypes)
|
||
{
|
||
for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
|
||
gfc_current_ns = gfc_current_ns->sibling)
|
||
gfc_dump_c_prototypes (gfc_current_ns, stdout);
|
||
}
|
||
|
||
/* Dump external prototypes. */
|
||
if (flag_c_prototypes_external)
|
||
gfc_dump_external_c_prototypes (stdout);
|
||
|
||
if (flag_c_prototypes || flag_c_prototypes_external)
|
||
fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
|
||
|
||
/* Do the translation. */
|
||
translate_all_program_units (gfc_global_ns_list);
|
||
|
||
/* Dump the global symbol ist. We only do this here because part
|
||
of it is generated after mangling the identifiers in
|
||
trans-decl.cc. */
|
||
|
||
if (flag_dump_fortran_global)
|
||
gfc_dump_global_symbols (stdout);
|
||
|
||
gfc_end_source_files ();
|
||
return true;
|
||
|
||
duplicate_main:
|
||
/* If we see a duplicate main program, shut down. If the second
|
||
instance is an implied main program, i.e. data decls or executable
|
||
statements, we're in for lots of errors. */
|
||
gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
|
||
reject_statement ();
|
||
gfc_done_2 ();
|
||
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_SERIAL_LOOP:
|
||
case EXEC_OACC_SERIAL:
|
||
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;
|
||
}
|
||
}
|