/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA. */
-
#include "config.h"
#include "system.h"
#include <setjmp.h>
#include "match.h"
#include "parse.h"
-/* Current statement label. Zero means no statement label. Because
- new_st can get wiped during statement matching, we have to keep it
- separate. */
+/* 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;
gfc_match_eos(). */
static match
-match_word (const char *str, match (*subr) (void), locus * old_locus)
+match_word (const char *str, match (*subr) (void), locus *old_locus)
{
match m;
ambiguity. */
#define match(keyword, subr, st) \
- do { \
+ do { \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
+ return st; \
else \
- undo_new_statement (); \
+ undo_new_statement (); \
} while (0);
static gfc_statement
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);
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':
break;
case 'u':
- match ("use% ", gfc_match_use, ST_USE);
+ match ("use", gfc_match_use, ST_USE);
+ break;
+
+ case 'v':
+ match ("value", gfc_match_value, ST_ATTR_DECL);
+ match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
break;
case 'w':
if (gfc_pure (NULL))
{
- gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
+ gfc_error_now ("OpenMP directives at %C may not appear in PURE "
+ "or ELEMENTAL procedures");
gfc_error_recovery ();
return ST_NONE;
}
next_free (void)
{
match m;
- int c, d, cnt;
+ int c, d, cnt, at_bol;
+ at_bol = gfc_at_bol ();
gfc_gobble_whitespace ();
c = gfc_peek_char ();
{
gfc_match_small_literal_int (&c, &cnt);
- if (cnt > 5)
+ if (cnt > 5)
gfc_error_now ("Too many digits in statement label at %C");
-
+
if (c == 0)
- gfc_error_now ("Statement label at %C is zero");
+ gfc_error_now ("Zero is not a valid statement label at %C");
do
c = gfc_next_char ();
if (!gfc_is_whitespace (c))
gfc_error_now ("Non-numeric character in statement label at %C");
+ return ST_NONE;
}
else
{
gfc_gobble_whitespace ();
+ if (at_bol && gfc_peek_char () == ';')
+ {
+ gfc_error_now ("Semicolon at %C needs to be preceded by "
+ "statement");
+ gfc_next_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");
+ gfc_warning_now ("Ignoring statement label in empty statement "
+ "at %C");
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
gcc_assert (c == "!$omp"[i]);
gcc_assert (c == ' ');
+ 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. */
+ return ST_NONE;
+ }
+
return decode_statement ();
}
if (c == '\n')
goto blank_line;
- if (c != ' ' && c!= '0')
+ if (c != ' ' && c != '0')
{
gfc_buffer_error (0);
gfc_error ("Bad continuation line at %C");
goto blank_line;
gfc_current_locus = loc;
+ if (c == ';')
+ {
+ gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ return ST_NONE;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto blank_line;
blank_line:
if (digit_flag)
- gfc_warning ("Statement label in blank line will be ignored at %C");
+ gfc_warning ("Ignoring statement label in empty statement at %C");
gfc_advance_line ();
return ST_NONE;
}
if (gfc_at_eol ())
{
if (gfc_option.warn_line_truncation
+ && gfc_current_locus.lb
&& gfc_current_locus.lb->truncated)
gfc_warning_now ("Line truncated at %C");
break;
}
- st =
- (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
+ st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE)
break;
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
/* Push a new state onto the stack. */
static void
-push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
+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;
-
gfc_state_stack = p;
}
static void
pop_state (void)
{
-
gfc_state_stack = gfc_state_stack->previous;
}
/* Starts a new level in the statement list. */
static gfc_code *
-new_level (gfc_code * q)
+new_level (gfc_code *q)
{
gfc_code *p;
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. */
+ particular line. However, there are plenty of situations
+ where the resulting label can't be referenced. */
default:
type = ST_LABEL_BAD_TARGET;
case ST_IMPLIED_ENDDO:
p = _("implied END DO");
break;
+ case ST_IMPORT:
+ p = "IMPORT";
+ break;
case ST_INQUIRE:
p = "INQUIRE";
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)
{
gfc_symbol *main_program;
symbol_attribute attr;
static void
accept_statement (gfc_statement st)
{
-
switch (st)
{
case ST_USE:
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. */
+ that allows a branch to the end of the block from within the
+ construct. */
case ST_ENDIF:
case ST_END_SELECT:
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. */
+ marker and require a statement of some sort if they are a
+ branch target. */
case ST_END_PROGRAM:
case ST_END_FUNCTION:
static void
reject_statement (void)
{
-
+ gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
undo_new_statement ();
static void
unexpected_statement (gfc_statement st)
{
-
gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
reject_statement ();
valid before calling here, ie ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
- +---------------------------------------+
- | program subroutine function module |
- +---------------------------------------+
- | use |
- |---------------------------------------+
- | | implicit none |
- | +-----------+------------------+
- | | parameter | implicit |
- | +-----------+------------------+
- | format | | derived type |
- | entry | parameter | interface |
- | | data | specification |
- | | | statement func |
- | +-----------+------------------+
- | | data | executable |
- +--------+-----------+------------------+
- | contains |
- +---------------------------------------+
- | internal module/subprogram |
- +---------------------------------------+
- | end |
- +---------------------------------------+
+ +---------------------------------------+
+ | 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 |
+ +---------------------------------------+
*/
typedef struct
{
enum
- { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
- ORDER_SPEC, ORDER_EXEC
+ { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
+ ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
}
state;
gfc_statement last_statement;
st_state;
static try
-verify_st_order (st_state * p, gfc_statement st)
+verify_st_order (st_state *p, gfc_statement st)
{
switch (st)
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_NONE)
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. */
+ /* 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;
break;
default:
- gfc_internal_error
- ("Unexpected %s statement in verify_st_order() at %C",
- gfc_ascii_statement (st));
+ gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
+ gfc_ascii_statement (st));
}
/* All is well, record the statement in case we need it next time. */
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
- gfc_component *c;
gfc_state_data s;
+ gfc_symbol *sym;
+ gfc_component *c;
error_flag = 0;
case ST_PRIVATE:
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
- gfc_error
- ("PRIVATE statement in TYPE at %C must be inside a MODULE");
+ gfc_error ("PRIVATE statement in TYPE at %C must be inside "
+ "a MODULE");
error_flag = 1;
break;
}
}
}
- /* Sanity checks on the structure. If the structure has the
- SEQUENCE attribute, then all component structures must also have
- SEQUENCE. */
- if (error_flag == 0 && gfc_current_block ()->attr.sequence)
- for (c = gfc_current_block ()->components; c; c = c->next)
- {
- if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
- {
- gfc_error
- ("Component %s of SEQUENCE type declared at %C does not "
- "have the SEQUENCE attribute", c->ts.derived->name);
- }
- }
+ /* Look for allocatable components. */
+ sym = gfc_current_block ();
+ for (c = sym->components; c; c = c->next)
+ {
+ if (c->allocatable
+ || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
+ {
+ sym->attr.alloc_comp = 1;
+ break;
+ }
+ }
pop_state ();
}
-
/* Parse an ENUM. */
static void
{
st = next_statement ();
switch (st)
- {
- case ST_NONE:
- unexpected_eof ();
- break;
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
- case ST_ENUMERATOR:
+ case ST_ENUMERATOR:
seen_enumerator = 1;
- accept_statement (st);
- break;
+ accept_statement (st);
+ break;
- case ST_END_ENUM:
- compiling_enum = 0;
+ case ST_END_ENUM:
+ compiling_enum = 0;
if (!seen_enumerator)
- {
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+ {
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
error_flag = 1;
- }
- accept_statement (st);
- break;
-
- default:
- gfc_free_enum_history ();
- unexpected_statement (st);
- break;
- }
+ }
+ 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(). */
gfc_interface_info save;
gfc_state_data s1, s2;
gfc_statement st;
+ locus proc_locus;
accept_statement (ST_INTERFACE);
save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC
- || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
+ || current_interface.type == INTERFACE_USER_OP)
+ ? gfc_new_block : NULL;
push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE;
if (new_state != current_state)
{
if (new_state == COMP_SUBROUTINE)
- gfc_error
- ("SUBROUTINE at %C does not belong in a generic function "
- "interface");
+ gfc_error ("SUBROUTINE at %C does not belong in a "
+ "generic function interface");
if (new_state == COMP_FUNCTION)
- gfc_error
- ("FUNCTION at %C does not belong in a generic subroutine "
- "interface");
+ gfc_error ("FUNCTION at %C does not belong in a "
+ "generic subroutine interface");
}
}
}
accept_statement (st);
prog_unit = gfc_new_block;
prog_unit->formal_ns = gfc_current_ns;
+ proc_locus = gfc_current_locus;
decl:
/* Read data declaration statements. */
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 '%s' at %L has the same name as the "
+ "enclosing procedure", prog_unit->name, &proc_locus);
+
goto loop;
done:
/* Fall through */
case ST_USE:
+ case ST_IMPORT:
case ST_IMPLICIT_NONE:
case ST_IMPLICIT:
case ST_PARAMETER:
case ST_WHERE_BLOCK:
parse_where_block ();
- break;
+ break;
case ST_ASSIGNMENT:
case ST_WHERE:
case ST_ELSEWHERE:
if (seen_empty_else)
{
- gfc_error
- ("ELSEWHERE statement at %C follows previous unmasked "
- "ELSEWHERE");
+ gfc_error ("ELSEWHERE statement at %C follows previous "
+ "unmasked ELSEWHERE");
break;
}
reject_statement ();
break;
}
-
}
while (st != ST_END_WHERE);
case ST_ELSEIF:
if (seen_else)
{
- gfc_error
- ("ELSE IF statement at %C cannot follow ELSE statement at %L",
- &else_locus);
+ gfc_error ("ELSE IF statement at %C cannot follow ELSE "
+ "statement at %L", &else_locus);
reject_statement ();
break;
if (st == ST_CASE)
break;
- gfc_error
- ("Expected a CASE or END SELECT statement following SELECT CASE "
- "at %C");
+ gfc_error ("Expected a CASE or END SELECT statement following SELECT "
+ "CASE at %C");
reject_statement ();
}
case ST_END_SELECT:
break;
- /* Can't have an executable statement because of
- parse_executable(). */
+ /* Can't have an executable statement because of
+ parse_executable(). */
default:
unexpected_statement (st);
break;
if (p == gfc_state_stack)
return 1;
- gfc_error
- ("End of nonblock DO statement at %C is within another block");
+ gfc_error ("End of nonblock DO statement at %C is within another block");
return 2;
}
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");
+ gfc_error_now ("Statement label in ENDDO at %C doesn't match "
+ "DO label");
if (gfc_statement_label != NULL)
{
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:
&& 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. */
+ 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;
}
if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
|| (new_st.ext.omp_name != NULL
&& strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
- gfc_error ("Name after !$omp critical and !$omp end critical does"
- " not match at %C");
+ gfc_error ("Name after !$omp critical and !$omp end critical does "
+ "not match at %C");
gfc_free ((char *) new_st.ext.omp_name);
break;
case EXEC_OMP_END_SINGLE:
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));
+ gfc_error ("%s statement at %C cannot terminate a non-block "
+ "DO loop", gfc_ascii_statement (st));
break;
default:
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_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
{
gfc_namespace *ns;
gfc_symtree *st;
for (ns = siblings; ns; ns = ns->sibling)
{
gfc_find_sym_tree (sym->name, ns, 0, &st);
- if (!st)
- continue;
+
+ if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
+ 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)
- {
- /* Replace it with the symbol from the parent namespace. */
- st->n.sym = sym;
- sym->refs++;
-
- /* Free the old (local) symbol. */
- old_sym->refs--;
- if (old_sym->refs == 0)
- gfc_free_symbol (old_sym);
- }
+ && !old_sym->attr.contained)
+ {
+ /* Replace it with the symbol from the parent namespace. */
+ st->n.sym = sym;
+ sym->refs++;
+
+ /* Free the old (local) symbol. */
+ old_sym->refs--;
+ if (old_sym->refs == 0)
+ gfc_free_symbol (old_sym);
+ }
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
gfc_statement st;
gfc_symbol *sym;
gfc_entry_list *el;
+ int contains_statements = 0;
push_state (&s1, COMP_CONTAINS, NULL);
parent_ns = gfc_current_ns;
case ST_FUNCTION:
case ST_SUBROUTINE:
+ contains_statements = 1;
accept_statement (st);
push_state (&s2,
if (!module)
{
if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
- gfc_error
- ("Contained procedure '%s' at %C is already ambiguous",
- gfc_new_block->name);
+ gfc_error ("Contained procedure '%s' at %C is already "
+ "ambiguous", gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
gfc_commit_symbols ();
}
- else
- sym = gfc_new_block;
+ else
+ sym = gfc_new_block;
- /* Mark this as a contained function, so it isn't replaced
- by other module functions. */
- sym->attr.contained = 1;
+ /* Mark this as a contained function, so it isn't replaced
+ by other module functions. */
+ sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
- /* Fix up any sibling functions that refer to this one. */
- gfc_fixup_sibling_symbols (sym, gfc_current_ns);
+ /* 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);
pop_state ();
break;
- /* These statements are associated with the end of the host
- unit. */
+ /* These statements are associated with the end of the host unit. */
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_PROGRAM:
gfc_free_namespace (ns);
pop_state ();
+ if (!contains_statements)
+ /* This is valid in Fortran 2008. */
+ gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
+ "FUNCTION or SUBROUTINE statement at %C");
}
{
if (blank_block)
gfc_error ("Blank BLOCK DATA at %C conflicts with "
- "prior BLOCK DATA at %L", &blank_locus);
+ "prior BLOCK DATA at %L", &blank_locus);
else
{
- blank_block = 1;
- blank_locus = gfc_current_locus;
+ blank_block = 1;
+ blank_locus = gfc_current_locus;
}
}
else
{
s = gfc_get_gsymbol (gfc_new_block->name);
- if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
+ if (s->defined
+ || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
global_used(s, NULL);
else
{
- s->type = GSYM_BLOCK_DATA;
- s->where = gfc_current_locus;
+ s->type = GSYM_BLOCK_DATA;
+ s->where = gfc_current_locus;
s->defined = 1;
}
}
s = gfc_get_gsymbol(gfc_new_block->name);
if (s->defined
- || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
+ || (s->type != GSYM_UNKNOWN
+ && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
global_used(s, NULL);
else
{
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);
parse_progunit (st);
break;
}
if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
- if (errors == 0 && ! gfc_option.flag_no_backend)
+ if (errors == 0)
gfc_generate_module_code (gfc_current_ns);
}
else
{
- if (errors == 0 && ! gfc_option.flag_no_backend)
+ if (errors == 0)
gfc_generate_code (gfc_current_ns);
}
OSDN Git Service
