/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
+#include "debug.h"
/* Current statement label. Zero means no statement label. Because new_st
can get wiped during statement matching, we have to keep it separate. */
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;
+
+ match ("import", gfc_match_import, ST_IMPORT);
+ match ("use", gfc_match_use, ST_USE);
+
+ if (gfc_current_block ()->result->ts.type != BT_DERIVED)
+ goto end_of_block;
+
+ 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_asynchronous, ST_ATTR_DECL);
+ match ("asynchronous", gfc_match_asynchronous, 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);
+ 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 (0);
+ gfc_current_locus = old_locus;
+
+ return ST_GET_FCN_CHARACTERISTICS;
+}
+
+
+/* This is the primary 'decode_statement'. */
static gfc_statement
decode_statement (void)
{
gfc_statement st;
locus old_locus;
match m;
- int c;
+ char c;
#ifdef GFC_DEBUG
gfc_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;
/* Try matching a data declaration or function declaration. The
|| 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;
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
+ gfc_matching_function = false;
+
/* Match statements whose error messages are meant to be overwritten
by something better. */
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
- might begin with a block label. The match functions for these
- statements are unusual in that their keyword is not seen before
+ /* 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)
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);
/* General statement matching: Instead of testing every possible
statement, we eliminate most possibilities by peeking at the
first character. */
- c = gfc_peek_char ();
+ c = gfc_peek_ascii_char ();
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);
break;
case 'b':
match ("call", gfc_match_call, ST_CALL);
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 ("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)
break;
case 'f':
+ match ("final", gfc_match_final_decl, ST_FINAL);
match ("flush", gfc_match_flush, ST_FLUSH);
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;
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 ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
+ match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
+ match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+ match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
break;
case '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':
break;
case 'w':
+ match ("wait", gfc_match_wait, ST_WAIT);
match ("write", gfc_match_write, ST_WRITE);
break;
}
decode_omp_directive (void)
{
locus old_locus;
- int c;
+ char c;
#ifdef GFC_DEBUG
gfc_symbol_state ();
statement, we eliminate most possibilities by peeking at the
first character. */
- c = gfc_peek_char ();
+ c = gfc_peek_ascii_char ();
switch (c)
{
match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
+ match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
match ("end workshare", gfc_match_omp_end_nowait,
ST_OMP_END_WORKSHARE);
break;
match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
break;
case 't':
+ match ("task", gfc_match_omp_task, ST_OMP_TASK);
+ match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
match ("threadprivate", gfc_match_omp_threadprivate,
ST_OMP_THREADPRIVATE);
case 'w':
return ST_NONE;
}
+static gfc_statement
+decode_gcc_attribute (void)
+{
+ locus old_locus;
+
+#ifdef GFC_DEBUG
+ gfc_symbol_state ();
+#endif
+
+ 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);
+
+ /* All else has failed, so give up. See if any of the matchers has
+ stored an error message of some sort. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable GCC directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
#undef match
next_free (void)
{
match m;
- int c, d, cnt, at_bol;
+ int i, cnt, at_bol;
+ char c;
at_bol = gfc_at_bol ();
gfc_gobble_whitespace ();
- c = gfc_peek_char ();
+ 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_char ();
+ d = gfc_peek_ascii_char ();
if (m != MATCH_YES || !gfc_is_whitespace (d))
{
- gfc_match_small_literal_int (&c, &cnt);
+ gfc_match_small_literal_int (&i, &cnt);
if (cnt > 5)
gfc_error_now ("Too many digits in statement label at %C");
- if (c == 0)
+ if (i == 0)
gfc_error_now ("Zero is not a valid statement label at %C");
do
- c = gfc_next_char ();
+ c = gfc_next_ascii_char ();
while (ISDIGIT(c));
if (!gfc_is_whitespace (c))
gfc_gobble_whitespace ();
- if (at_bol && gfc_peek_char () == ';')
+ if (at_bol && gfc_peek_ascii_char () == ';')
{
gfc_error_now ("Semicolon at %C needs to be preceded by "
"statement");
- gfc_next_char (); /* Eat up the semicolon. */
+ gfc_next_ascii_char (); /* Eat up the semicolon. */
return ST_NONE;
}
if (gfc_match_eos () == MATCH_YES)
{
gfc_warning_now ("Ignoring statement label in empty statement "
- "at %C");
+ "at %L", &label_locus);
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
else if (c == '!')
{
/* Comments have already been skipped by the time we get here,
- except for OpenMP directives. */
- if (gfc_option.flag_openmp)
+ except for GCC attributes and OpenMP directives. */
+
+ gfc_next_ascii_char (); /* Eat up the exclamation sign. */
+ c = gfc_peek_ascii_char ();
+
+ if (c == 'g')
{
int i;
- c = gfc_next_char ();
- for (i = 0; i < 5; i++, c = gfc_next_char ())
- gcc_assert (c == "!$omp"[i]);
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "gcc$"[i]);
- gcc_assert (c == ' ');
+ gfc_gobble_whitespace ();
+ return decode_gcc_attribute ();
+
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
+ {
+ int i;
+
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "$omp"[i]);
+
+ gcc_assert (c == ' ' || c == '\t');
gfc_gobble_whitespace ();
return decode_omp_directive ();
}
- }
+ gcc_unreachable ();
+ }
+
if (at_bol && c == ';')
{
- gfc_error_now ("Semicolon at %C needs to be preceded by statement");
- gfc_next_char (); /* Eat up the semicolon. */
+ 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;
}
{
int label, digit_flag, i;
locus loc;
- char c;
+ gfc_char_t c;
if (!gfc_at_bol ())
return decode_statement ();
case '7':
case '8':
case '9':
- label = label * 10 + c - '0';
+ 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 OpenMP directives. */
+ here, except for GCC attributes and OpenMP directives. */
+
case '*':
- if (gfc_option.flag_openmp)
+ c = gfc_next_char_literal (0);
+
+ if (TOLOWER (c) == 'g')
{
- for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
- gcc_assert (TOLOWER (c) == "*$omp"[i]);
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert (TOLOWER (c) == "gcc$"[i]);
+
+ return decode_gcc_attribute ();
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
+ {
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
{
if (c == ';')
{
- gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ 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;
}
blank_line:
if (digit_flag)
- gfc_warning ("Ignoring statement label in empty statement at %C");
+ gfc_warning_now ("Ignoring statement label in empty statement at %L",
+ &label_locus);
+
+ gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
}
next_statement (void)
{
gfc_statement st;
+ locus old_locus;
gfc_new_block = NULL;
+ gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
for (;;)
{
gfc_statement_label = NULL;
gfc_buffer_error (1);
if (gfc_at_eol ())
- {
- if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
- && gfc_current_locus.lb
- && gfc_current_locus.lb->truncated)
- gfc_warning_now ("Line truncated at %C");
-
- gfc_advance_line ();
- }
+ gfc_advance_line ();
gfc_skip_comments ();
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)
gfc_buffer_error (0);
+ if (st == ST_GET_FCN_CHARACTERISTICS && 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);
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_WRITE: case ST_ASSIGNMENT: \
+ case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
- case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
+ 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_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
+ case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
/* Statements that mark other executable statements. */
-#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
- case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+#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_OMP_PARALLEL: \
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
- case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
+ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
+ case ST_OMP_TASK: case ST_CRITICAL
/* Declaration statements */
#define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
- case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
+ case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
+ case ST_PROCEDURE
/* Block end statements. Errors associated with interchanging these
are detected in gfc_match_end(). */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
- case ST_END_PROGRAM: case ST_END_SUBROUTINE
+ case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
+ case ST_END_BLOCK: case ST_END_ASSOCIATE
/* Push a new state onto the stack. */
/* Try to find the given state in the state stack. */
-try
+gfc_try
gfc_find_state (gfc_compile_state state)
{
gfc_state_data *p;
case ST_ENDDO:
case ST_ENDIF:
case ST_END_SELECT:
+ case ST_END_CRITICAL:
case_executable:
case_exec_markers:
type = ST_LABEL_TARGET;
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_CONTAINS:
p = "CONTAINS";
break;
+ case ST_CRITICAL:
+ p = "CRITICAL";
+ break;
case ST_CYCLE:
p = "CYCLE";
break;
case ST_ELSEWHERE:
p = "ELSEWHERE";
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_EQUIVALENCE:
p = "EQUIVALENCE";
break;
+ case ST_ERROR_STOP:
+ p = "ERROR STOP";
+ break;
case ST_EXIT:
p = "EXIT";
break;
case ST_FUNCTION:
p = "FUNCTION";
break;
+ case ST_GENERIC:
+ p = "GENERIC";
+ break;
case ST_GOTO:
p = "GOTO";
break;
case ST_PROGRAM:
p = "PROGRAM";
break;
+ case ST_PROCEDURE:
+ p = "PROCEDURE";
+ break;
case ST_READ:
p = "READ";
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_WHERE:
p = "WHERE";
break;
+ case ST_WAIT:
+ p = "WAIT";
+ break;
case ST_WRITE:
p = "WRITE";
break;
case ST_SELECT_CASE:
p = "SELECT CASE";
break;
+ case ST_SELECT_TYPE:
+ p = "SELECT TYPE";
+ break;
+ case ST_TYPE_IS:
+ p = "TYPE IS";
+ break;
+ case ST_CLASS_IS:
+ p = "CLASS IS";
+ break;
case ST_SEQUENCE:
p = "SEQUENCE";
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_WORKSHARE:
p = "!$OMP END WORKSHARE";
break;
case ST_OMP_SINGLE:
p = "!$OMP SINGLE";
break;
+ case ST_OMP_TASK:
+ p = "!$OMP TASK";
+ break;
+ case ST_OMP_TASKWAIT:
+ p = "!$OMP TASKWAIT";
+ break;
case ST_OMP_THREADPRIVATE:
p = "!$OMP THREADPRIVATE";
break;
/* Create a symbol for the main program and assign it to ns->proc_name. */
static void
-main_program_symbol (gfc_namespace *ns)
+main_program_symbol (gfc_namespace *ns, const char *name)
{
gfc_symbol *main_program;
symbol_attribute attr;
- gfc_get_symbol ("MAIN__", ns, &main_program);
+ gfc_get_symbol (name, ns, &main_program);
gfc_clear_attr (&attr);
- attr.flavor = FL_PROCEDURE;
+ attr.flavor = FL_PROGRAM;
attr.proc = PROC_UNKNOWN;
attr.subroutine = 1;
attr.access = ACCESS_PUBLIC;
/* 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. */
+ 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_NOP;
+ new_st.op = EXEC_END_BLOCK;
add_statement ();
}
-
break;
/* The end-of-program unit statements do not get the special
new_st.op = EXEC_RETURN;
add_statement ();
}
+ else
+ {
+ new_st.op = EXEC_END_PROCEDURE;
+ add_statement ();
+ }
break;
static void
reject_statement (void)
{
+ /* Revert to the previous charlen chain. */
+ gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
+ gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
+
gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
issue an error and return FAILURE. Otherwise we return SUCCESS.
Individual parsers need to verify that the statements seen are
- valid before calling here, ie ENTRY statements are not allowed in
+ valid before calling here, i.e., ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
+---------------------------------------+
*/
+enum state_order
+{
+ ORDER_START,
+ ORDER_USE,
+ ORDER_IMPORT,
+ ORDER_IMPLICIT_NONE,
+ ORDER_IMPLICIT,
+ ORDER_SPEC,
+ ORDER_EXEC
+};
+
typedef struct
{
- enum
- { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
- ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
- }
- state;
+ enum state_order state;
gfc_statement last_statement;
locus where;
}
st_state;
-static try
-verify_st_order (st_state *p, gfc_statement st)
+static gfc_try
+verify_st_order (st_state *p, gfc_statement st, bool silent)
{
switch (st)
return SUCCESS;
order:
- gfc_error ("%s statement at %C cannot follow %s statement at %L",
- gfc_ascii_statement (st),
- gfc_ascii_statement (p->last_statement), &p->where);
+ 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 FAILURE;
}
}
+/* 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 '%s' with SEQUENCE must not have a CONTAINS"
+ " section at %C", gfc_current_block ()->name);
+ if (gfc_current_block ()->attr.is_bind_c)
+ gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
+ " 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");
+ error_flag = true;
+ break;
+
+ case ST_PROCEDURE:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
+ " procedure at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_PROCEDURE);
+ seen_comps = true;
+ break;
+
+ case ST_GENERIC:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_GENERIC);
+ seen_comps = true;
+ break;
+
+ case ST_FINAL:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_FINAL);
+ seen_comps = true;
+ break;
+
+ case ST_END_TYPE:
+ to_finish = true;
+
+ if (!seen_comps
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = true;
+
+ /* ST_END_TYPE is accepted by parse_derived after return. */
+ break;
+
+ case ST_PRIVATE:
+ if (gfc_find_state (COMP_MODULE) == FAILURE)
+ {
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_comps)
+ {
+ gfc_error ("PRIVATE statement at %C must precede procedure"
+ " bindings");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_private)
+ {
+ gfc_error ("Duplicate PRIVATE statement at %C");
+ error_flag = true;
+ }
+
+ 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");
+ error_flag = true;
+ break;
+
+ case ST_CONTAINS:
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = true;
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+
+ pop_state ();
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+ return error_flag;
+}
+
+
/* Parse a derived type. */
static void
parse_derived (void)
{
- int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
+ int compiling_type, seen_private, seen_sequence, seen_component;
gfc_statement st;
gfc_state_data s;
- gfc_symbol *derived_sym = NULL;
gfc_symbol *sym;
gfc_component *c;
- error_flag = 0;
-
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
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_error ("Derived type definition at %C has no components");
- error_flag = 1;
- }
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+ "definition at %C without components");
accept_statement (ST_END_TYPE);
break;
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
- error_flag = 1;
break;
}
{
gfc_error ("PRIVATE statement at %C must precede "
"structure components");
- error_flag = 1;
break;
}
if (seen_private)
- {
- gfc_error ("Duplicate PRIVATE statement at %C");
- error_flag = 1;
- }
+ gfc_error ("Duplicate PRIVATE statement at %C");
s.sym->component_access = ACCESS_PRIVATE;
+
accept_statement (ST_PRIVATE);
seen_private = 1;
break;
{
gfc_error ("SEQUENCE statement at %C must precede "
"structure components");
- error_flag = 1;
break;
}
if (seen_sequence)
{
gfc_error ("Duplicate SEQUENCE statement at %C");
- error_flag = 1;
}
seen_sequence = 1;
gfc_current_block ()->name, NULL);
break;
+ case ST_CONTAINS:
+ gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: 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)
*/
- derived_sym = gfc_current_block();
-
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
/* Look for allocatable components. */
- if (c->allocatable
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
- {
- sym->attr.alloc_comp = 1;
- break;
- }
+ if (c->attr.allocatable
+ || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
+ sym->attr.alloc_comp = 1;
/* Look for pointer components. */
- if (c->pointer
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
- {
- sym->attr.pointer_comp = 1;
- break;
- }
+ if (c->attr.pointer
+ || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.pointer)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
+ 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->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
+ sym->attr.coarray_comp = 1;
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
- || c->access == ACCESS_PRIVATE
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
- {
- sym->attr.private_comp = 1;
- break;
- }
+ || c->attr.access == ACCESS_PRIVATE
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
+ sym->attr.private_comp = 1;
}
+ if (!seen_component)
+ sym->attr.zero_comp = 1;
+
pop_state ();
}
static void
parse_enum (void)
{
- int error_flag;
gfc_statement st;
int compiling_enum;
gfc_state_data s;
int seen_enumerator = 0;
- error_flag = 0;
-
push_state (&s, COMP_ENUM, gfc_new_block);
compiling_enum = 1;
case ST_END_ENUM:
compiling_enum = 0;
if (!seen_enumerator)
- {
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
- error_flag = 1;
- }
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
accept_statement (st);
break;
static void
parse_interface (void)
{
- gfc_compile_state new_state, current_state;
+ gfc_compile_state new_state = COMP_NONE, current_state;
gfc_symbol *prog_unit, *sym;
gfc_interface_info save;
gfc_state_data s1, s2;
unexpected_eof ();
case ST_SUBROUTINE:
- new_state = COMP_SUBROUTINE;
- gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
- gfc_new_block->formal, NULL);
- break;
-
case ST_FUNCTION:
- new_state = COMP_FUNCTION;
- gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
- gfc_new_block->formal, NULL);
+ 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) == FAILURE)
+ {
+ reject_statement ();
+ gfc_free_namespace (gfc_current_ns);
+ goto loop;
+ }
break;
+ case ST_PROCEDURE:
case ST_MODULE_PROC: /* The module procedure matcher makes
sure the context is correct. */
accept_statement (st);
{
if (current_state == COMP_NONE)
{
- if (new_state == COMP_FUNCTION)
+ if (new_state == COMP_FUNCTION && sym)
gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE)
+ 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 '%s' 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;
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 ();
}
+/* 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 (1);
+ m = gfc_match_prefix (ts);
+ gfc_buffer_error (0);
+
+ 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_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 = &gfc_current_ns->proc_name->result->ts;
+
+ gcc_assert (gfc_current_state () == COMP_FUNCTION);
+ gcc_assert (ts->type != BT_UNKNOWN);
+
+ /* 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. */
parse_spec (gfc_statement st)
{
st_state ss;
+ bool function_result_typed = false;
+ bool bad_characteristic = false;
+ gfc_typespec *ts;
- verify_st_order (&ss, ST_NONE);
+ 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));
+ break;
+
+ default:
+ break;
+ }
+
+ /* If we find a statement that can not be followed by an IMPLICIT statement
+ (and thus we can expect to see none any further), type the function result
+ if it has not yet been typed. Be careful not to give the END statement
+ 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) == FAILURE)
+ 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 */
case ST_USE:
case ST_IMPORT:
- case ST_IMPLICIT_NONE:
- case ST_IMPLICIT:
case ST_PARAMETER:
case ST_PUBLIC:
case ST_PRIVATE:
case ST_DERIVED_DECL:
case_decl:
- if (verify_st_order (&ss, st) == FAILURE)
+declSt:
+ if (verify_st_order (&ss, st, false) == FAILURE)
{
reject_statement ();
st = next_statement ();
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 '%s' at %L",
+ gfc_current_block ()->name,
+ &gfc_current_block ()->declared_at);
+ else
+ gfc_error ("The type for function '%s' at %L is not accessible",
+ gfc_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;
+ }
+
return st;
}
push_state (&s, COMP_WHERE, gfc_new_block);
d = add_statement ();
- d->expr = top->expr;
+ d->expr1 = top->expr1;
d->op = EXEC_WHERE;
- top->expr = NULL;
+ top->expr1 = NULL;
top->block = d;
seen_empty_else = 0;
break;
}
- if (new_st.expr == NULL)
+ if (new_st.expr1 == NULL)
seen_empty_else = 1;
d = new_level (gfc_state_stack->head);
d->op = EXEC_WHERE;
- d->expr = new_st.expr;
+ d->expr1 = new_st.expr1;
accept_statement (st);
new_st.op = EXEC_IF;
d = add_statement ();
- d->expr = top->expr;
- top->expr = NULL;
+ d->expr1 = top->expr1;
+ top->expr1 = NULL;
top->block = d;
do
d = new_level (gfc_state_stack->head);
d->op = EXEC_IF;
- d->expr = new_st.expr;
+ d->expr1 = new_st.expr1;
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;
+ gfc_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;
+
+ 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're 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 ();
+}
+
+
/* 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
if (p->ext.end_do_label == gfc_statement_label)
{
-
if (p == gfc_state_stack)
return 1;
}
+/* 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;
+ gfc_statement st;
+
+ 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 CRITIAL 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;
+
+ 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
+ {
+ gfc_try t;
+
+ gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+ t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+ my_ns->proc_name->name, NULL);
+ gcc_assert (t == SUCCESS);
+ }
+
+ 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_state_data s;
+
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: 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;
+
+ parse_progunit (ST_NONE);
+
+ gfc_current_ns = gfc_current_ns->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_code* assignTail;
+
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: 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 associations to expressions as BLOCK variables, and create
+ assignments to them giving their values. */
+ gfc_current_ns = my_ns;
+ assignTail = NULL;
+ for (a = new_st.ext.block.assoc; a; a = a->next)
+ if (!a->variable)
+ {
+ gfc_code* newAssign;
+
+ if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+ gcc_unreachable ();
+
+ /* Note that in certain cases, the target-expression's type is not yet
+ known and so we have to adapt the symbol's ts also during resolution
+ for these cases. */
+ a->st->n.sym->ts = a->target->ts;
+ a->st->n.sym->attr.flavor = FL_VARIABLE;
+ a->st->n.sym->assoc = a;
+ gfc_set_sym_referenced (a->st->n.sym);
+
+ /* Create the assignment to calculate the expression and set it. */
+ newAssign = gfc_get_code ();
+ newAssign->op = EXEC_ASSIGN;
+ newAssign->loc = gfc_current_locus;
+ newAssign->expr1 = gfc_get_variable_expr (a->st);
+ newAssign->expr2 = a->target;
+
+ /* Hang it in. */
+ if (assignTail)
+ assignTail->next = newAssign;
+ else
+ gfc_current_ns->code = newAssign;
+ assignTail = newAssign;
+ }
+ else
+ {
+ gfc_error ("Association to variables is not yet supported at %C");
+ return;
+ }
+ gcc_assert (assignTail);
+
+ 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);
+ assignTail->next = 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. */
gfc_state_data s;
gfc_symtree *stree;
- s.ext.end_do_label = new_st.label;
+ s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL)
stree = new_st.ext.iterator->var->symtree;
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_error_now ("Named block DO at %L requires matching ENDDO name",
&gfc_current_block()->declared_at);
break;
case ST_OMP_SINGLE:
omp_end_st = ST_OMP_END_SINGLE;
break;
+ case ST_OMP_TASK:
+ omp_end_st = ST_OMP_END_TASK;
+ break;
case ST_OMP_WORKSHARE:
omp_end_st = ST_OMP_END_WORKSHARE;
break;
&& strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
gfc_error ("Name after !$omp critical and !$omp end critical does "
"not match at %C");
- gfc_free ((char *) new_st.ext.omp_name);
+ gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
break;
case EXEC_OMP_END_SINGLE:
cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
+ case ST_ERROR_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
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;
parse_select_block ();
break;
+ case ST_SELECT_TYPE:
+ parse_select_type_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_OMP_CRITICAL:
case ST_OMP_MASTER:
case ST_OMP_SINGLE:
+ case ST_OMP_TASK:
parse_omp_structured_block (st, false);
break;
}
-/* Parse a series of contained program units. */
-
-static void parse_progunit (gfc_statement);
-
-
/* Fix the symbols for sibling functions. These are incorrectly added to
the child namespace as the parser didn't know about this procedure. */
sym->attr.referenced = 1;
for (ns = siblings; ns; ns = ns->sibling)
{
- gfc_find_sym_tree (sym->name, ns, 0, &st);
+ st = gfc_find_symtree (ns->sym_root, sym->name);
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
- continue;
+ goto fixup_contained;
old_sym = st->n.sym;
- if ((old_sym->attr.flavor == FL_PROCEDURE
- || old_sym->ts.type == BT_UNKNOWN)
- && old_sym->ns == ns
- && !old_sym->attr.contained
- && old_sym->attr.flavor != FL_NAMELIST)
+ 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.proc == PROC_ST_FUNCTION))
{
/* Replace it with the symbol from the parent namespace. */
st->n.sym = sym;
gfc_free_symbol (old_sym);
}
+fixup_contained:
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
}
pop_state ();
if (!contains_statements)
- /* This is valid in Fortran 2008. */
- gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
"FUNCTION or SUBROUTINE statement at %C");
}
-/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
parse_progunit (gfc_statement st)
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
something else. */
void
-global_used (gfc_gsymbol *sym, locus *where)
+gfc_global_used (gfc_gsymbol *sym, locus *where)
{
const char *name;
name = "MODULE";
break;
default:
- gfc_internal_error ("gfc_gsymbol_type(): Bad type");
+ gfc_internal_error ("gfc_global_used(): Bad type");
name = NULL;
}
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined
|| (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
- global_used(s, NULL);
+ gfc_global_used(s, NULL);
else
{
s->type = GSYM_BLOCK_DATA;
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
- global_used(s, NULL);
+ gfc_global_used(s, NULL);
else
{
s->type = GSYM_MODULE;
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
if (s->defined
|| (s->type != GSYM_UNKNOWN
&& s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
- global_used(s, NULL);
+ gfc_global_used(s, NULL);
else
{
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
s = gfc_get_gsymbol (gfc_new_block->name);
if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
- global_used(s, NULL);
+ gfc_global_used(s, NULL);
else
{
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
+ }
+}
+
+
+/* Resolve all the program units when whole file scope option
+ is active. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+ gfc_free_dt_list ();
+ gfc_current_ns = gfc_global_ns_list;
+ for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ 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 || !gsym->ns)
+ return;
+
+ gfc_current_ns = gsym->ns;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_done_2 ();
+ gsym->ns = NULL;
+ return;
+}
+
+
+/* Translate all the program units when whole file scope option
+ is active. This could be in a different order to resolution if
+ there are forward references in the file. */
+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);
+
+ for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ 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 = 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. */
-try
+gfc_try
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;
if (setjmp (eof_buf))
return FAILURE; /* Come here on unexpected EOF */
+ /* Prepare the global namespace that will contain the
+ program units. */
+ gfc_global_ns_list = next = NULL;
+
seen_program = 0;
/* Exit early for empty files. */
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol(gfc_current_ns);
+ main_program_symbol(gfc_current_ns, gfc_new_block->name);
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_SUBROUTINE:
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_FUNCTION:
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_BLOCK_DATA:
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol (gfc_current_ns);
+ main_program_symbol (gfc_current_ns, "MAIN__");
parse_progunit (st);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
}
+ /* Handle the non-program units. */
gfc_current_ns->code = s.head;
gfc_resolve (gfc_current_ns);
/* Dump the parse tree if requested. */
- if (gfc_option.verbose)
- gfc_show_namespace (gfc_current_ns);
+ if (gfc_option.dump_parse_tree)
+ gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
if (s.state == COMP_MODULE)
gfc_dump_module (s.sym->name, errors_before == errors);
if (errors == 0)
gfc_generate_module_code (gfc_current_ns);
+ pop_state ();
+ if (!gfc_option.flag_whole_file)
+ gfc_done_2 ();
+ else
+ {
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ gfc_current_ns = NULL;
+ }
}
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)
+ next->sibling = gfc_current_ns;
+ else
+ gfc_global_ns_list = gfc_current_ns;
+
+ next = gfc_current_ns;
+
pop_state ();
- gfc_done_2 ();
goto loop;
-done:
+ done:
+
+ if (!gfc_option.flag_whole_file)
+ goto termination;
+
+ /* Do the resolution. */
+ resolve_all_program_units (gfc_global_ns_list);
+
+ /* Do the parse tree dump. */
+ gfc_current_ns
+ = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+
+ for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_dump_parse_tree (gfc_current_ns, stdout);
+ fputs ("------------------------------------------\n\n", stdout);
+ }
+
+ /* Do the translation. */
+ translate_all_program_units (gfc_global_ns_list);
+
+termination:
+
+ gfc_end_source_files ();
return SUCCESS;
duplicate_main:
/* If we see a duplicate main program, shut down. If the second
- instance is an implied main program, ie data decls or executable
+ 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 ();