/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
+ Inc.
Contributed by Andy Vaught
This file is part of GCC.
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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
-#include <string.h>
+#include "system.h"
#include <setjmp.h>
-
#include "gfortran.h"
#include "match.h"
#include "parse.h"
gfc_st_label *gfc_statement_label;
static locus label_locus;
-static jmp_buf eof;
+static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack;
/* Figure out what the next statement is, (mostly) regardless of
- proper ordering. */
+ proper ordering. The do...while(0) is there to prevent if/else
+ ambiguity. */
#define match(keyword, subr, st) \
- if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
- return st; \
- else \
- undo_new_statement ();
+ do { \
+ if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
+ return st; \
+ else \
+ undo_new_statement (); \
+ } while (0);
static gfc_statement
decode_statement (void)
case 'b':
match ("backspace", gfc_match_backspace, ST_BACKSPACE);
- match ("block data% ", gfc_match_block_data, ST_BLOCK_DATA);
+ match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
break;
case 'c':
break;
case 'f':
+ match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
break;
break;
/* Comments have already been skipped by the time we get
- here so don't bother checking for them. */
+ here so don't bother checking for them. */
default:
gfc_buffer_error (0);
gfc_buffer_error (1);
if (gfc_at_eol ())
- gfc_advance_line ();
+ {
+ if (gfc_option.warn_line_truncation
+ && gfc_current_locus.lb->truncated)
+ gfc_warning_now ("Line truncated at %C");
+
+ gfc_advance_line ();
+ }
gfc_skip_comments ();
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_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
- case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
+ case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
+ case ST_LABEL_ASSIGNMENT: case ST_FLUSH
/* Statements that mark other executable statements. */
p->previous = gfc_state_stack;
p->sym = sym;
p->head = p->tail = NULL;
+ p->do_variable = NULL;
gfc_state_stack = p;
}
switch (st)
{
case ST_ARITHMETIC_IF:
- p = "arithmetic IF";
+ p = _("arithmetic IF");
break;
case ST_ALLOCATE:
p = "ALLOCATE";
break;
case ST_ATTR_DECL:
- p = "attribute declaration";
+ p = _("attribute declaration");
break;
case ST_BACKSPACE:
p = "BACKSPACE";
p = "CYCLE";
break;
case ST_DATA_DECL:
- p = "data declaration";
+ p = _("data declaration");
break;
case ST_DATA:
p = "DATA";
p = "DEALLOCATE";
break;
case ST_DERIVED_DECL:
- p = "Derived type declaration";
+ p = _("derived type declaration");
break;
case ST_DO:
p = "DO";
case ST_EXIT:
p = "EXIT";
break;
+ case ST_FLUSH:
+ p = "FLUSH";
+ break;
case ST_FORALL_BLOCK: /* Fall through */
case ST_FORALL:
p = "FORALL";
p = "GOTO";
break;
case ST_IF_BLOCK:
- p = "block IF";
+ p = _("block IF");
break;
case ST_IMPLICIT:
p = "IMPLICIT";
p = "IMPLICIT NONE";
break;
case ST_IMPLIED_ENDDO:
- p = "implied END DO";
+ p = _("implied END DO");
break;
case ST_INQUIRE:
p = "INQUIRE";
p = "WRITE";
break;
case ST_ASSIGNMENT:
- p = "assignment";
+ p = _("assignment");
break;
case ST_POINTER_ASSIGNMENT:
- p = "pointer assignment";
+ p = _("pointer assignment");
break;
case ST_SELECT_CASE:
p = "SELECT CASE";
p = "SEQUENCE";
break;
case ST_SIMPLE_IF:
- p = "Simple IF";
+ p = _("simple IF");
break;
case ST_STATEMENT_FUNCTION:
p = "STATEMENT FUNCTION";
}
-/* Return the name of a compile state. */
-
-const char *
-gfc_state_name (gfc_compile_state state)
-{
- const char *p;
-
- switch (state)
- {
- case COMP_PROGRAM:
- p = "a PROGRAM";
- break;
- case COMP_MODULE:
- p = "a MODULE";
- break;
- case COMP_SUBROUTINE:
- p = "a SUBROUTINE";
- break;
- case COMP_FUNCTION:
- p = "a FUNCTION";
- break;
- case COMP_BLOCK_DATA:
- p = "a BLOCK DATA";
- break;
- case COMP_INTERFACE:
- p = "an INTERFACE";
- break;
- case COMP_DERIVED:
- p = "a DERIVED TYPE block";
- break;
- case COMP_IF:
- p = "an IF-THEN block";
- break;
- case COMP_DO:
- p = "a DO block";
- break;
- case COMP_SELECT:
- p = "a SELECT block";
- break;
- case COMP_FORALL:
- p = "a FORALL block";
- break;
- case COMP_WHERE:
- p = "a WHERE block";
- break;
- case COMP_CONTAINS:
- p = "a contained subprogram";
- break;
-
- default:
- gfc_internal_error ("gfc_state_name(): Bad state");
- }
-
- return p;
-}
-
-
/* Do whatever is necessary to accept the last statement. */
static void
break;
case ST_IMPLICIT:
- gfc_set_implicit ();
break;
case ST_FUNCTION:
construct. */
case ST_ENDIF:
- case ST_ENDDO:
case ST_END_SELECT:
if (gfc_statement_label != NULL)
{
break;
- case ST_BLOCK_DATA:
- {
- gfc_symbol *block_data = NULL;
- symbol_attribute attr;
-
- gfc_get_symbol ("_BLOCK_DATA__", gfc_current_ns, &block_data);
- gfc_clear_attr (&attr);
- attr.flavor = FL_PROCEDURE;
- attr.proc = PROC_UNKNOWN;
- attr.subroutine = 1;
- attr.access = ACCESS_PUBLIC;
- block_data->attr = attr;
- gfc_current_ns->proc_name = block_data;
- gfc_commit_symbols ();
- }
-
- break;
-
+ case ST_ENTRY:
case_executable:
case_exec_markers:
add_statement ();
gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
gfc_done_2 ();
- longjmp (eof, 1);
+ longjmp (eof_buf, 1);
}
}
seen_sequence = 1;
- gfc_add_sequence (&gfc_current_block ()->attr, NULL);
+ gfc_add_sequence (&gfc_current_block ()->attr,
+ gfc_current_block ()->name, NULL);
break;
default:
current_state = COMP_NONE;
loop:
- gfc_current_ns = gfc_get_namespace (current_interface.ns);
+ gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
st = next_statement ();
switch (st)
if (current_state == COMP_NONE)
{
if (new_state == COMP_FUNCTION)
- gfc_add_function (&sym->attr, NULL);
- if (new_state == COMP_SUBROUTINE)
- gfc_add_subroutine (&sym->attr, NULL);
+ gfc_add_function (&sym->attr, sym->name, NULL);
+ else if (new_state == COMP_SUBROUTINE)
+ gfc_add_subroutine (&sym->attr, sym->name, NULL);
current_state = new_state;
}
}
+/* Given a symbol, make sure it is not an iteration variable for a DO
+ statement. This subroutine is called when the symbol is seen in a
+ context that causes it to become redefined. If the symbol is an
+ iterator, we generate an error message and return nonzero. */
+
+int
+gfc_check_do_variable (gfc_symtree *st)
+{
+ gfc_state_data *s;
+
+ for (s=gfc_state_stack; s; s = s->previous)
+ if (s->do_variable == st)
+ {
+ gfc_error_now("Variable '%s' at %C cannot be redefined inside "
+ "loop beginning at %L", st->name, &s->head->loc);
+ return 1;
+ }
+
+ return 0;
+}
+
+
/* Checks to see if the current statement label closes an enddo.
Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
an error) if it incorrectly closes an ENDDO. */
gfc_statement st;
gfc_code *top;
gfc_state_data s;
+ gfc_symtree *stree;
s.ext.end_do_label = new_st.label;
+ if (new_st.ext.iterator != NULL)
+ stree = new_st.ext.iterator->var->symtree;
+ else
+ stree = NULL;
+
accept_statement (ST_DO);
top = gfc_state_stack->tail;
push_state (&s, COMP_DO, gfc_new_block);
+ s.do_variable = stree;
+
top->block = new_level (top);
top->block->op = EXEC_DO;
&& s.ext.end_do_label != gfc_statement_label)
gfc_error_now
("Statement label in ENDDO at %C doesn't match DO label");
- /* Fall through */
+
+ if (gfc_statement_label != NULL)
+ {
+ new_st.op = EXEC_NOP;
+ add_statement ();
+ }
+ break;
case ST_IMPLIED_ENDDO:
break;
gfc_symtree *st;
gfc_symbol *old_sym;
+ sym->attr.referenced = 1;
for (ns = siblings; ns; ns = ns->sibling)
{
gfc_find_sym_tree (sym->name, ns, 0, &st);
continue;
old_sym = st->n.sym;
- if (old_sym->attr.flavor == FL_PROCEDURE && old_sym->ns == ns
+ 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. */
gfc_free_symbol (old_sym);
}
- /* Do the same for any contined procedures. */
+ /* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
}
}
gfc_state_data s1, s2;
gfc_statement st;
gfc_symbol *sym;
+ gfc_entry_list *el;
push_state (&s1, COMP_CONTAINS, NULL);
parent_ns = gfc_current_ns;
do
{
- gfc_current_ns = gfc_get_namespace (parent_ns);
+ gfc_current_ns = gfc_get_namespace (parent_ns, 1);
gfc_current_ns->sibling = parent_ns->contained;
parent_ns->contained = gfc_current_ns;
gfc_new_block);
/* For internal procedures, create/update the symbol in the
- * parent namespace */
+ parent namespace. */
if (!module)
{
gfc_new_block->name);
else
{
- if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
+ if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
&gfc_new_block->declared_at) ==
SUCCESS)
{
if (st == ST_FUNCTION)
- gfc_add_function (&sym->attr,
+ gfc_add_function (&sym->attr, sym->name,
&gfc_new_block->declared_at);
else
- gfc_add_subroutine (&sym->attr,
+ gfc_add_subroutine (&sym->attr, sym->name,
&gfc_new_block->declared_at);
}
}
/* 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);
-
- parse_progunit (ST_NONE);
+ /* Or refer to any of its alternate entry points. */
+ for (el = gfc_current_ns->entries; el; el = el->next)
+ gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
gfc_current_ns->code = s2.head;
gfc_current_ns = parent_ns;
}
+/* Come here to complain about a global symbol already in use as
+ something else. */
+
+static void
+global_used (gfc_gsymbol *sym, locus *where)
+{
+ const char *name;
+
+ if (where == NULL)
+ where = &gfc_current_locus;
+
+ switch(sym->type)
+ {
+ case GSYM_PROGRAM:
+ name = "PROGRAM";
+ break;
+ case GSYM_FUNCTION:
+ name = "FUNCTION";
+ break;
+ case GSYM_SUBROUTINE:
+ name = "SUBROUTINE";
+ break;
+ case GSYM_COMMON:
+ name = "COMMON";
+ break;
+ case GSYM_BLOCK_DATA:
+ name = "BLOCK DATA";
+ break;
+ case GSYM_MODULE:
+ name = "MODULE";
+ break;
+ default:
+ gfc_internal_error ("gfc_gsymbol_type(): Bad type");
+ name = NULL;
+ }
+
+ gfc_error("Global name '%s' at %L is already being used as a %s at %L",
+ gfc_new_block->name, where, name, &sym->where);
+}
+
+
/* Parse a block data program unit. */
static void
parse_block_data (void)
{
gfc_statement st;
+ static locus blank_locus;
+ static int blank_block=0;
+ gfc_gsymbol *s;
+
+ gfc_current_ns->proc_name = gfc_new_block;
+ gfc_current_ns->is_block_data = 1;
+
+ if (gfc_new_block == NULL)
+ {
+ if (blank_block)
+ gfc_error ("Blank BLOCK DATA at %C conflicts with "
+ "prior BLOCK DATA at %L", &blank_locus);
+ else
+ {
+ blank_block = 1;
+ blank_locus = gfc_current_locus;
+ }
+ }
+ else
+ {
+ s = gfc_get_gsymbol (gfc_new_block->name);
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_BLOCK_DATA;
+ s->where = gfc_current_locus;
+ }
+ }
st = parse_spec (ST_NONE);
parse_module (void)
{
gfc_statement st;
+ gfc_gsymbol *s;
+
+ s = gfc_get_gsymbol (gfc_new_block->name);
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_MODULE;
+ s->where = gfc_current_locus;
+ }
st = parse_spec (ST_NONE);
}
+/* Add a procedure name to the global symbol table. */
+
+static void
+add_global_procedure (int sub)
+{
+ gfc_gsymbol *s;
+
+ s = gfc_get_gsymbol(gfc_new_block->name);
+
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
+ s->where = gfc_current_locus;
+ }
+}
+
+
+/* Add a program to the global symbol table. */
+
+static void
+add_global_program (void)
+{
+ gfc_gsymbol *s;
+
+ if (gfc_new_block == NULL)
+ return;
+ s = gfc_get_gsymbol (gfc_new_block->name);
+
+ if (s->type != GSYM_UNKNOWN)
+ global_used(s, NULL);
+ else
+ {
+ s->type = GSYM_PROGRAM;
+ s->where = gfc_current_locus;
+ }
+}
+
+
/* Top level parser. */
try
top.sym = NULL;
top.previous = NULL;
top.head = top.tail = NULL;
+ top.do_variable = NULL;
gfc_state_stack = ⊤
gfc_statement_label = NULL;
- if (setjmp (eof))
+ if (setjmp (eof_buf))
return FAILURE; /* Come here on unexpected EOF */
seen_program = 0;
+ /* Exit early for empty files. */
+ if (gfc_at_eof ())
+ goto done;
+
loop:
gfc_init_2 ();
st = next_statement ();
push_state (&s, COMP_PROGRAM, gfc_new_block);
accept_statement (st);
+ add_global_program ();
parse_progunit (ST_NONE);
break;
case ST_SUBROUTINE:
+ add_global_procedure (1);
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
break;
case ST_FUNCTION:
+ add_global_procedure (0);
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
OSDN Git Service
