/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 ()->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);
+ break;
+
+ case 'b':
+ match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
+ break;
+
+ case 'c':
+ 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. */
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);
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;
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;
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':
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;
}
{
int i;
- c = gfc_next_char ();
- for (i = 0; i < 5; i++, c = gfc_next_char ())
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
gcc_assert (c == "!$omp"[i]);
- gcc_assert (c == ' ');
+ gcc_assert (c == ' ' || c == '\t');
gfc_gobble_whitespace ();
return decode_omp_directive ();
}
if (at_bol && c == ';')
{
gfc_error_now ("Semicolon at %C needs to be preceded by statement");
- gfc_next_char (); /* Eat up the semicolon. */
+ 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;
if (gfc_option.flag_openmp)
{
for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
- gcc_assert (TOLOWER (c) == "*$omp"[i]);
+ gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
if (c != ' ' && c != '0')
{
next_statement (void)
{
gfc_statement st;
-
+ locus old_locus;
gfc_new_block = NULL;
for (;;)
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
/* Statements that mark other executable statements. */
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
/* 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(). */
case ST_PROGRAM:
p = "PROGRAM";
break;
+ case ST_PROCEDURE:
+ p = "PROCEDURE";
+ break;
case ST_READ:
p = "READ";
break;
case ST_WHERE:
p = "WHERE";
break;
+ case ST_WAIT:
+ p = "WAIT";
+ break;
case ST_WRITE:
p = "WRITE";
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;
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:
+---------------------------------------+
parse_derived (void)
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
+ int seen_contains, seen_contains_comp;
gfc_statement st;
gfc_state_data s;
gfc_symbol *derived_sym = NULL;
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
+ seen_contains = 0;
+ seen_contains_comp = 0;
compiling_type = 1;
unexpected_eof ();
case ST_DATA_DECL:
+ case ST_PROCEDURE:
+ if (seen_contains)
+ {
+ gfc_error ("Components in TYPE at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
accept_statement (st);
seen_component = 1;
break;
- case ST_END_TYPE:
- compiling_type = 0;
-
- if (!seen_component)
+ case ST_FINAL:
+ if (!seen_contains)
{
- gfc_error ("Derived type definition at %C has no components");
+ gfc_error ("FINAL declaration at %C must be inside CONTAINS");
error_flag = 1;
}
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = 1;
+
+ accept_statement (ST_FINAL);
+ seen_contains_comp = 1;
+ break;
+
+ case ST_END_TYPE:
+ compiling_type = 0;
+
+ if (!seen_component
+ && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+ "definition at %C without components")
+ == FAILURE))
+ error_flag = 1;
+
+ if (seen_contains && !seen_contains_comp
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = 1;
+
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
+ if (seen_contains)
+ {
+ gfc_error ("PRIVATE statement at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
break;
case ST_SEQUENCE:
+ if (seen_contains)
+ {
+ gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+ error_flag = 1;
+ }
+
if (seen_component)
{
gfc_error ("SEQUENCE statement at %C must precede "
gfc_current_block ()->name, NULL);
break;
+ case ST_CONTAINS:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: CONTAINS block in derived type"
+ " definition at %C") == FAILURE)
+ error_flag = 1;
+
+ if (seen_contains)
+ {
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = 1;
+ }
+
+ seen_contains = 1;
+ accept_statement (ST_CONTAINS);
+ break;
+
default:
unexpected_statement (st);
break;
*/
derived_sym = gfc_current_block();
- /* Look for allocatable components. */
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;
}
- }
+
+ /* Look for pointer components. */
+ if (c->pointer
+ || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
+ {
+ sym->attr.pointer_comp = 1;
+ break;
+ }
+
+ /* 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;
+ }
+ }
+
+ if (!seen_component)
+ sym->attr.zero_comp = 1;
pop_state ();
}
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;
+ }
+ if (current_interface.type != INTERFACE_ABSTRACT &&
+ !gfc_new_block->attr.dummy &&
+ gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == 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_interface.type == INTERFACE_ABSTRACT)
+ {
+ gfc_new_block->attr.abstract = 1;
+ 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;
}
+/* 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->derived || !ts->derived->components)
+ 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. */
+ gfc_match ("function% %n", name);
+ if (m == 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;
+}
+
+
/* Parse a set of specification statements. Returns the statement
that doesn't fit. */
parse_spec (gfc_statement st)
{
st_state ss;
+ bool bad_characteristic = false;
+ gfc_typespec *ts;
verify_st_order (&ss, ST_NONE);
if (st == ST_NONE)
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->derived))
+ ts->type = BT_UNKNOWN;
+ }
+
return st;
}
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_OMP_CRITICAL:
case ST_OMP_MASTER:
case ST_OMP_SINGLE:
+ case ST_OMP_TASK:
parse_omp_structured_block (st, false);
break;
continue;
old_sym = st->n.sym;
- if ((old_sym->attr.flavor == FL_PROCEDURE
- || old_sym->ts.type == BT_UNKNOWN)
- && old_sym->ns == ns
- && !old_sym->attr.contained)
+ 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.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;
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");
}
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;
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 = 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;
gfc_statement st;
locus prog_locus;
+ gfc_start_source_files ();
+
top.state = COMP_NONE;
top.sym = NULL;
top.previous = NULL;
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);
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);
break;
}
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)
goto loop;
done:
+ 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 ();