#include "config.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_buf;
gfc_state_data *gfc_state_stack;
static void check_statement_label (gfc_statement);
static void undo_new_statement (void);
static void reject_statement (void);
static match
match_word (const char *str, match (*subr) (void), locus * old_locus)
{
match m;
if (str != NULL)
{
m = gfc_match (str);
if (m != MATCH_YES)
return m;
}
m = (*subr) ();
if (m != MATCH_YES)
{
gfc_current_locus = *old_locus;
reject_statement ();
}
return m;
}
#define match(keyword, subr, st) \
if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
return st; \
else \
undo_new_statement ();
static gfc_statement
decode_statement (void)
{
gfc_statement st;
locus old_locus;
match m;
int c;
#ifdef GFC_DEBUG
gfc_symbol_state ();
#endif
gfc_clear_error ();
gfc_clear_warning ();
if (gfc_match_eos () == MATCH_YES)
return ST_NONE;
old_locus = gfc_current_locus;
if (gfc_current_state () == COMP_NONE
|| gfc_current_state () == COMP_INTERFACE
|| gfc_current_state () == COMP_CONTAINS)
{
m = gfc_match_function_decl ();
if (m == MATCH_YES)
return ST_FUNCTION;
else if (m == MATCH_ERROR)
reject_statement ();
gfc_undo_symbols ();
gfc_current_locus = old_locus;
}
match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
match (NULL, gfc_match_data_decl, ST_DATA_DECL);
if (gfc_match_subroutine () == MATCH_YES)
return ST_SUBROUTINE;
gfc_undo_symbols ();
gfc_current_locus = old_locus;
if (gfc_match_if (&st) == MATCH_YES)
return st;
gfc_undo_symbols ();
gfc_current_locus = old_locus;
if (gfc_match_where (&st) == MATCH_YES)
return st;
gfc_undo_symbols ();
gfc_current_locus = old_locus;
if (gfc_match_forall (&st) == MATCH_YES)
return st;
gfc_undo_symbols ();
gfc_current_locus = old_locus;
match (NULL, gfc_match_do, ST_DO);
match (NULL, gfc_match_select, ST_SELECT_CASE);
c = gfc_peek_char ();
switch (c)
{
case 'a':
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 'b':
match ("backspace", gfc_match_backspace, ST_BACKSPACE);
match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
break;
case 'c':
match ("call", gfc_match_call, ST_CALL);
match ("close", gfc_match_close, ST_CLOSE);
match ("continue", gfc_match_continue, ST_CONTINUE);
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);
break;
case 'd':
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
match ("data", gfc_match_data, ST_DATA);
match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
break;
case 'e':
match ("end file", gfc_match_endfile, ST_END_FILE);
match ("exit", gfc_match_exit, ST_EXIT);
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
match ("else if", gfc_match_elseif, ST_ELSEIF);
if (gfc_match_end (&st) == MATCH_YES)
return st;
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
break;
case 'f':
match ("format", gfc_match_format, ST_FORMAT);
break;
case 'g':
match ("go to", gfc_match_goto, ST_GOTO);
break;
case 'i':
match ("inquire", gfc_match_inquire, ST_INQUIRE);
match ("implicit", gfc_match_implicit, ST_IMPLICIT);
match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
match ("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':
match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
match ("module", gfc_match_module, ST_MODULE);
break;
case 'n':
match ("nullify", gfc_match_nullify, ST_NULLIFY);
match ("namelist", gfc_match_namelist, ST_NAMELIST);
break;
case 'o':
match ("open", gfc_match_open, ST_OPEN);
match ("optional", gfc_match_optional, ST_ATTR_DECL);
break;
case 'p':
match ("print", gfc_match_print, ST_WRITE);
match ("parameter", gfc_match_parameter, ST_PARAMETER);
match ("pause", gfc_match_pause, ST_PAUSE);
match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
if (gfc_match_private (&st) == MATCH_YES)
return st;
match ("program", gfc_match_program, ST_PROGRAM);
if (gfc_match_public (&st) == MATCH_YES)
return st;
break;
case 'r':
match ("read", gfc_match_read, ST_READ);
match ("return", gfc_match_return, ST_RETURN);
match ("rewind", gfc_match_rewind, ST_REWIND);
break;
case 's':
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
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':
match ("use% ", gfc_match_use, ST_USE);
break;
case 'w':
match ("write", gfc_match_write, ST_WRITE);
break;
}
if (gfc_error_check () == 0)
gfc_error_now ("Unclassifiable statement at %C");
reject_statement ();
gfc_error_recovery ();
return ST_NONE;
}
#undef match
static gfc_statement
next_free (void)
{
match m;
int c, d;
gfc_gobble_whitespace ();
c = gfc_peek_char ();
if (ISDIGIT (c))
{
m = gfc_match_st_label (&gfc_statement_label, 0);
d = gfc_peek_char ();
if (m != MATCH_YES || !gfc_is_whitespace (d))
{
do
{
gfc_warning_now ("Ignoring bad statement label at %C");
c = gfc_next_char ();
}
while (ISDIGIT (c));
}
else
{
label_locus = gfc_current_locus;
if (gfc_statement_label->value == 0)
{
gfc_warning_now ("Ignoring statement label of zero at %C");
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
}
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
{
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;
}
}
}
return decode_statement ();
}
static gfc_statement
next_fixed (void)
{
int label, digit_flag, i;
locus loc;
char c;
if (!gfc_at_bol ())
return decode_statement ();
label = 0;
digit_flag = 0;
for (i = 0; i < 5; i++)
{
c = gfc_next_char_literal (0);
switch (c)
{
case ' ':
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
label = label * 10 + c - '0';
label_locus = gfc_current_locus;
digit_flag = 1;
break;
default:
gfc_buffer_error (0);
gfc_error ("Non-numeric character in statement label at %C");
return ST_NONE;
}
}
if (digit_flag)
{
if (label == 0)
gfc_warning_now ("Zero is not a valid statement label at %C");
else
{
gfc_statement_label = gfc_get_st_label (label);
}
}
c = gfc_next_char_literal (0);
if (c == '\n')
goto blank_line;
if (c != ' ' && c!= '0')
{
gfc_buffer_error (0);
gfc_error ("Bad continuation line at %C");
return ST_NONE;
}
do
{
loc = gfc_current_locus;
c = gfc_next_char_literal (0);
}
while (gfc_is_whitespace (c));
if (c == '!')
goto blank_line;
gfc_current_locus = loc;
if (gfc_match_eos () == MATCH_YES)
goto blank_line;
return decode_statement ();
blank_line:
if (digit_flag)
gfc_warning ("Statement label in blank line will be " "ignored at %C");
gfc_advance_line ();
return ST_NONE;
}
static gfc_statement
next_statement (void)
{
gfc_statement st;
gfc_new_block = NULL;
for (;;)
{
gfc_statement_label = NULL;
gfc_buffer_error (1);
if (gfc_at_eol ())
gfc_advance_line ();
gfc_skip_comments ();
if (gfc_at_end ())
{
st = ST_NONE;
break;
}
st =
(gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
if (st != ST_NONE)
break;
}
gfc_buffer_error (0);
if (st != ST_NONE)
check_statement_label (st);
return st;
}
#define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
case ST_PAUSE: case ST_STOP: case ST_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
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
case ST_WHERE_BLOCK: case ST_SELECT_CASE
#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
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
case ST_END_PROGRAM: case ST_END_SUBROUTINE
static void
push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym)
{
p->state = new_state;
p->previous = gfc_state_stack;
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
gfc_state_stack = p;
}
static void
pop_state (void)
{
gfc_state_stack = gfc_state_stack->previous;
}
try
gfc_find_state (gfc_compile_state state)
{
gfc_state_data *p;
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == state)
break;
return (p == NULL) ? FAILURE : SUCCESS;
}
static gfc_code *
new_level (gfc_code * q)
{
gfc_code *p;
p = q->block = gfc_get_code ();
gfc_state_stack->head = gfc_state_stack->tail = p;
return p;
}
static gfc_code *
add_statement (void)
{
gfc_code *p;
p = gfc_get_code ();
*p = new_st;
p->loc = gfc_current_locus;
if (gfc_state_stack->head == NULL)
gfc_state_stack->head = p;
else
gfc_state_stack->tail->next = p;
while (p->next != NULL)
p = p->next;
gfc_state_stack->tail = p;
gfc_clear_new_st ();
return p;
}
static void
undo_new_statement (void)
{
gfc_free_statements (new_st.block);
gfc_free_statements (new_st.next);
gfc_free_statement (&new_st);
gfc_clear_new_st ();
}
static void
check_statement_label (gfc_statement st)
{
gfc_sl_type type;
if (gfc_statement_label == NULL)
{
if (st == ST_FORMAT)
gfc_error ("FORMAT statement at %L does not have a statement label",
&new_st.loc);
return;
}
switch (st)
{
case ST_END_PROGRAM:
case ST_END_FUNCTION:
case ST_END_SUBROUTINE:
case ST_ENDDO:
case ST_ENDIF:
case ST_END_SELECT:
case_executable:
case_exec_markers:
type = ST_LABEL_TARGET;
break;
case ST_FORMAT:
type = ST_LABEL_FORMAT;
break;
default:
type = ST_LABEL_BAD_TARGET;
break;
}
gfc_define_st_label (gfc_statement_label, type, &label_locus);
new_st.here = gfc_statement_label;
}
gfc_state_data *
gfc_enclosing_unit (gfc_compile_state * result)
{
gfc_state_data *p;
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
|| p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
|| p->state == COMP_PROGRAM)
{
if (result != NULL)
*result = p->state;
return p;
}
if (result != NULL)
*result = COMP_PROGRAM;
return NULL;
}
const char *
gfc_ascii_statement (gfc_statement st)
{
const char *p;
switch (st)
{
case ST_ARITHMETIC_IF:
p = "arithmetic IF";
break;
case ST_ALLOCATE:
p = "ALLOCATE";
break;
case ST_ATTR_DECL:
p = "attribute declaration";
break;
case ST_BACKSPACE:
p = "BACKSPACE";
break;
case ST_BLOCK_DATA:
p = "BLOCK DATA";
break;
case ST_CALL:
p = "CALL";
break;
case ST_CASE:
p = "CASE";
break;
case ST_CLOSE:
p = "CLOSE";
break;
case ST_COMMON:
p = "COMMON";
break;
case ST_CONTINUE:
p = "CONTINUE";
break;
case ST_CONTAINS:
p = "CONTAINS";
break;
case ST_CYCLE:
p = "CYCLE";
break;
case ST_DATA_DECL:
p = "data declaration";
break;
case ST_DATA:
p = "DATA";
break;
case ST_DEALLOCATE:
p = "DEALLOCATE";
break;
case ST_DERIVED_DECL:
p = "Derived type declaration";
break;
case ST_DO:
p = "DO";
break;
case ST_ELSE:
p = "ELSE";
break;
case ST_ELSEIF:
p = "ELSE IF";
break;
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
case ST_ENDDO:
p = "END DO";
break;
case ST_END_FILE:
p = "END FILE";
break;
case ST_END_FORALL:
p = "END FORALL";
break;
case ST_END_FUNCTION:
p = "END FUNCTION";
break;
case ST_ENDIF:
p = "END IF";
break;
case ST_END_INTERFACE:
p = "END INTERFACE";
break;
case ST_END_MODULE:
p = "END MODULE";
break;
case ST_END_PROGRAM:
p = "END PROGRAM";
break;
case ST_END_SELECT:
p = "END SELECT";
break;
case ST_END_SUBROUTINE:
p = "END SUBROUTINE";
break;
case ST_END_WHERE:
p = "END WHERE";
break;
case ST_END_TYPE:
p = "END TYPE";
break;
case ST_ENTRY:
p = "ENTRY";
break;
case ST_EQUIVALENCE:
p = "EQUIVALENCE";
break;
case ST_EXIT:
p = "EXIT";
break;
case ST_FORALL_BLOCK:
case ST_FORALL:
p = "FORALL";
break;
case ST_FORMAT:
p = "FORMAT";
break;
case ST_FUNCTION:
p = "FUNCTION";
break;
case ST_GOTO:
p = "GOTO";
break;
case ST_IF_BLOCK:
p = "block IF";
break;
case ST_IMPLICIT:
p = "IMPLICIT";
break;
case ST_IMPLICIT_NONE:
p = "IMPLICIT NONE";
break;
case ST_IMPLIED_ENDDO:
p = "implied END DO";
break;
case ST_INQUIRE:
p = "INQUIRE";
break;
case ST_INTERFACE:
p = "INTERFACE";
break;
case ST_PARAMETER:
p = "PARAMETER";
break;
case ST_PRIVATE:
p = "PRIVATE";
break;
case ST_PUBLIC:
p = "PUBLIC";
break;
case ST_MODULE:
p = "MODULE";
break;
case ST_PAUSE:
p = "PAUSE";
break;
case ST_MODULE_PROC:
p = "MODULE PROCEDURE";
break;
case ST_NAMELIST:
p = "NAMELIST";
break;
case ST_NULLIFY:
p = "NULLIFY";
break;
case ST_OPEN:
p = "OPEN";
break;
case ST_PROGRAM:
p = "PROGRAM";
break;
case ST_READ:
p = "READ";
break;
case ST_RETURN:
p = "RETURN";
break;
case ST_REWIND:
p = "REWIND";
break;
case ST_STOP:
p = "STOP";
break;
case ST_SUBROUTINE:
p = "SUBROUTINE";
break;
case ST_TYPE:
p = "TYPE";
break;
case ST_USE:
p = "USE";
break;
case ST_WHERE_BLOCK:
case ST_WHERE:
p = "WHERE";
break;
case ST_WRITE:
p = "WRITE";
break;
case ST_ASSIGNMENT:
p = "assignment";
break;
case ST_POINTER_ASSIGNMENT:
p = "pointer assignment";
break;
case ST_SELECT_CASE:
p = "SELECT CASE";
break;
case ST_SEQUENCE:
p = "SEQUENCE";
break;
case ST_SIMPLE_IF:
p = "Simple IF";
break;
case ST_STATEMENT_FUNCTION:
p = "STATEMENT FUNCTION";
break;
case ST_LABEL_ASSIGNMENT:
p = "LABEL ASSIGNMENT";
break;
default:
gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
}
return p;
}
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;
}
static void
accept_statement (gfc_statement st)
{
switch (st)
{
case ST_USE:
gfc_use_module ();
break;
case ST_IMPLICIT_NONE:
gfc_set_implicit_none ();
break;
case ST_IMPLICIT:
break;
case ST_FUNCTION:
case ST_SUBROUTINE:
case ST_MODULE:
gfc_current_ns->proc_name = gfc_new_block;
break;
case ST_ENDIF:
case ST_END_SELECT:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_NOP;
add_statement ();
}
break;
case ST_END_PROGRAM:
case ST_END_FUNCTION:
case ST_END_SUBROUTINE:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_RETURN;
add_statement ();
}
break;
case ST_ENTRY:
case_executable:
case_exec_markers:
add_statement ();
break;
default:
break;
}
gfc_commit_symbols ();
gfc_warning_check ();
gfc_clear_new_st ();
}
static void
reject_statement (void)
{
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 ();
}
typedef struct
{
enum
{ ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
ORDER_SPEC, ORDER_EXEC
}
state;
gfc_statement last_statement;
locus where;
}
st_state;
static try
verify_st_order (st_state * p, gfc_statement st)
{
switch (st)
{
case ST_NONE:
p->state = ORDER_START;
break;
case ST_USE:
if (p->state > ORDER_USE)
goto order;
p->state = ORDER_USE;
break;
case ST_IMPLICIT_NONE:
if (p->state > ORDER_IMPLICIT_NONE)
goto order;
p->state = ORDER_IMPLICIT_NONE;
break;
case ST_IMPLICIT:
if (p->state > ORDER_IMPLICIT)
goto order;
p->state = ORDER_IMPLICIT;
break;
case ST_FORMAT:
case ST_ENTRY:
if (p->state < ORDER_IMPLICIT_NONE)
p->state = ORDER_IMPLICIT_NONE;
break;
case ST_PARAMETER:
if (p->state >= ORDER_EXEC)
goto order;
if (p->state < ORDER_IMPLICIT)
p->state = ORDER_IMPLICIT;
break;
case ST_DATA:
if (p->state < ORDER_SPEC)
p->state = ORDER_SPEC;
break;
case ST_PUBLIC:
case ST_PRIVATE:
case ST_DERIVED_DECL:
case_decl:
if (p->state >= ORDER_EXEC)
goto order;
if (p->state < ORDER_SPEC)
p->state = ORDER_SPEC;
break;
case_executable:
case_exec_markers:
if (p->state < ORDER_EXEC)
p->state = ORDER_EXEC;
break;
default:
gfc_internal_error
("Unexpected %s statement in verify_st_order() at %C",
gfc_ascii_statement (st));
}
p->where = gfc_current_locus;
p->last_statement = 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);
return FAILURE;
}
static void unexpected_eof (void) ATTRIBUTE_NORETURN;
static void
unexpected_eof (void)
{
gfc_state_data *p;
gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
for (p = gfc_state_stack; p && p->previous && p->previous->previous;
p = p->previous);
gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
gfc_done_2 ();
longjmp (eof_buf, 1);
}
static void
parse_derived (void)
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
gfc_component *c;
gfc_state_data s;
error_flag = 0;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
gfc_new_block->component_access = ACCESS_PUBLIC;
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
compiling_type = 1;
while (compiling_type)
{
st = next_statement ();
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_DATA_DECL:
accept_statement (st);
seen_component = 1;
break;
case ST_END_TYPE:
compiling_type = 0;
if (!seen_component)
{
gfc_error ("Derived type definition at %C has no components");
error_flag = 1;
}
accept_statement (ST_END_TYPE);
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 = 1;
break;
}
if (seen_component)
{
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;
}
s.sym->component_access = ACCESS_PRIVATE;
accept_statement (ST_PRIVATE);
seen_private = 1;
break;
case ST_SEQUENCE:
if (seen_component)
{
gfc_error ("SEQUENCE statement at %C must precede "
"structure components");
error_flag = 1;
break;
}
if (gfc_current_block ()->attr.sequence)
gfc_warning ("SEQUENCE attribute at %C already specified in "
"TYPE statement");
if (seen_sequence)
{
gfc_error ("Duplicate SEQUENCE statement at %C");
error_flag = 1;
}
seen_sequence = 1;
gfc_add_sequence (&gfc_current_block ()->attr,
gfc_current_block ()->name, NULL);
break;
default:
unexpected_statement (st);
break;
}
}
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);
}
}
pop_state ();
}
static gfc_statement parse_spec (gfc_statement);
static void
parse_interface (void)
{
gfc_compile_state new_state, current_state;
gfc_symbol *prog_unit, *sym;
gfc_interface_info save;
gfc_state_data s1, s2;
gfc_statement st;
accept_statement (ST_INTERFACE);
current_interface.ns = gfc_current_ns;
save = current_interface;
sym = (current_interface.type == INTERFACE_GENERIC
|| current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
push_state (&s1, COMP_INTERFACE, sym);
current_state = COMP_NONE;
loop:
gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
st = next_statement ();
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_SUBROUTINE:
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);
break;
case ST_MODULE_PROC:
accept_statement (st);
gfc_free_namespace (gfc_current_ns);
goto loop;
case ST_END_INTERFACE:
gfc_free_namespace (gfc_current_ns);
gfc_current_ns = current_interface.ns;
goto done;
default:
gfc_error ("Unexpected %s statement in INTERFACE block at %C",
gfc_ascii_statement (st));
reject_statement ();
gfc_free_namespace (gfc_current_ns);
goto loop;
}
if (current_interface.type == INTERFACE_GENERIC)
{
if (current_state == COMP_NONE)
{
if (new_state == COMP_FUNCTION)
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;
}
else
{
if (new_state != current_state)
{
if (new_state == COMP_SUBROUTINE)
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");
}
}
}
push_state (&s2, new_state, gfc_new_block);
accept_statement (st);
prog_unit = gfc_new_block;
prog_unit->formal_ns = gfc_current_ns;
decl:
st = parse_spec (ST_NONE);
if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
{
gfc_error ("Unexpected %s statement at %C in INTERFACE body",
gfc_ascii_statement (st));
reject_statement ();
goto decl;
}
current_interface = save;
gfc_add_interface (prog_unit);
pop_state ();
goto loop;
done:
pop_state ();
}
static gfc_statement
parse_spec (gfc_statement st)
{
st_state ss;
verify_st_order (&ss, ST_NONE);
if (st == ST_NONE)
st = next_statement ();
loop:
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_FORMAT:
case ST_ENTRY:
case ST_DATA:
if (gfc_current_state () == COMP_INTERFACE)
break;
case ST_USE:
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)
{
reject_statement ();
st = next_statement ();
goto loop;
}
switch (st)
{
case ST_INTERFACE:
parse_interface ();
break;
case ST_DERIVED_DECL:
parse_derived ();
break;
case ST_PUBLIC:
case ST_PRIVATE:
if (gfc_current_state () != COMP_MODULE)
{
gfc_error ("%s statement must appear in a MODULE",
gfc_ascii_statement (st));
break;
}
if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
{
gfc_error ("%s statement at %C follows another accessibility "
"specification", gfc_ascii_statement (st));
break;
}
gfc_current_ns->default_access = (st == ST_PUBLIC)
? ACCESS_PUBLIC : ACCESS_PRIVATE;
break;
default:
break;
}
accept_statement (st);
st = next_statement ();
goto loop;
default:
break;
}
return st;
}
static void
parse_where_block (void)
{
int seen_empty_else;
gfc_code *top, *d;
gfc_state_data s;
gfc_statement st;
accept_statement (ST_WHERE_BLOCK);
top = gfc_state_stack->tail;
push_state (&s, COMP_WHERE, gfc_new_block);
d = add_statement ();
d->expr = top->expr;
d->op = EXEC_WHERE;
top->expr = NULL;
top->block = d;
seen_empty_else = 0;
do
{
st = next_statement ();
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_WHERE_BLOCK:
parse_where_block ();
case ST_ASSIGNMENT:
case ST_WHERE:
accept_statement (st);
break;
case ST_ELSEWHERE:
if (seen_empty_else)
{
gfc_error
("ELSEWHERE statement at %C follows previous unmasked "
"ELSEWHERE");
break;
}
if (new_st.expr == NULL)
seen_empty_else = 1;
d = new_level (gfc_state_stack->head);
d->op = EXEC_WHERE;
d->expr = new_st.expr;
accept_statement (st);
break;
case ST_END_WHERE:
accept_statement (st);
break;
default:
gfc_error ("Unexpected %s statement in WHERE block at %C",
gfc_ascii_statement (st));
reject_statement ();
break;
}
}
while (st != ST_END_WHERE);
pop_state ();
}
static void
parse_forall_block (void)
{
gfc_code *top, *d;
gfc_state_data s;
gfc_statement st;
accept_statement (ST_FORALL_BLOCK);
top = gfc_state_stack->tail;
push_state (&s, COMP_FORALL, gfc_new_block);
d = add_statement ();
d->op = EXEC_FORALL;
top->block = d;
do
{
st = next_statement ();
switch (st)
{
case ST_ASSIGNMENT:
case ST_POINTER_ASSIGNMENT:
case ST_WHERE:
case ST_FORALL:
accept_statement (st);
break;
case ST_WHERE_BLOCK:
parse_where_block ();
break;
case ST_FORALL_BLOCK:
parse_forall_block ();
break;
case ST_END_FORALL:
accept_statement (st);
break;
case ST_NONE:
unexpected_eof ();
default:
gfc_error ("Unexpected %s statement in FORALL block at %C",
gfc_ascii_statement (st));
reject_statement ();
break;
}
}
while (st != ST_END_FORALL);
pop_state ();
}
static gfc_statement parse_executable (gfc_statement);
static void
parse_if_block (void)
{
gfc_code *top, *d;
gfc_statement st;
locus else_locus;
gfc_state_data s;
int seen_else;
seen_else = 0;
accept_statement (ST_IF_BLOCK);
top = gfc_state_stack->tail;
push_state (&s, COMP_IF, gfc_new_block);
new_st.op = EXEC_IF;
d = add_statement ();
d->expr = top->expr;
top->expr = NULL;
top->block = d;
do
{
st = parse_executable (ST_NONE);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_ELSEIF:
if (seen_else)
{
gfc_error
("ELSE IF statement at %C cannot follow ELSE statement at %L",
&else_locus);
reject_statement ();
break;
}
d = new_level (gfc_state_stack->head);
d->op = EXEC_IF;
d->expr = new_st.expr;
accept_statement (st);
break;
case ST_ELSE:
if (seen_else)
{
gfc_error ("Duplicate ELSE statements at %L and %C",
&else_locus);
reject_statement ();
break;
}
seen_else = 1;
else_locus = gfc_current_locus;
d = new_level (gfc_state_stack->head);
d->op = EXEC_IF;
accept_statement (st);
break;
case ST_ENDIF:
break;
default:
unexpected_statement (st);
break;
}
}
while (st != ST_ENDIF);
pop_state ();
accept_statement (st);
}
static void
parse_select_block (void)
{
gfc_statement st;
gfc_code *cp;
gfc_state_data s;
accept_statement (ST_SELECT_CASE);
cp = gfc_state_stack->tail;
push_state (&s, COMP_SELECT, gfc_new_block);
for (;;)
{
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
if (st == ST_END_SELECT)
{
accept_statement (st);
pop_state ();
return;
}
if (st == ST_CASE)
break;
gfc_error
("Expected a CASE or END SELECT statement following SELECT CASE "
"at %C");
reject_statement ();
}
cp = new_level (cp);
*cp = new_st;
accept_statement (st);
do
{
st = parse_executable (ST_NONE);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_CASE:
cp = new_level (gfc_state_stack->head);
*cp = new_st;
gfc_clear_new_st ();
accept_statement (st);
case ST_END_SELECT:
break;
default:
unexpected_statement (st);
break;
}
}
while (st != ST_END_SELECT);
pop_state ();
accept_statement (st);
}
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;
}
static int
check_do_closure (void)
{
gfc_state_data *p;
if (gfc_statement_label == NULL)
return 0;
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_DO)
break;
if (p == NULL)
return 0;
if (p->ext.end_do_label == gfc_statement_label)
{
if (p == gfc_state_stack)
return 1;
gfc_error
("End of nonblock DO statement at %C is within another block");
return 2;
}
for (; p; p = p->previous)
if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
{
gfc_error ("End of nonblock DO statement at %C is interwoven "
"with another DO loop");
return 2;
}
return 0;
}
static void
parse_do_block (void)
{
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;
loop:
st = parse_executable (ST_NONE);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_ENDDO:
if (s.ext.end_do_label != NULL
&& s.ext.end_do_label != gfc_statement_label)
gfc_error_now
("Statement label in ENDDO at %C doesn't match DO label");
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_NOP;
add_statement ();
}
break;
case ST_IMPLIED_ENDDO:
break;
default:
unexpected_statement (st);
goto loop;
}
pop_state ();
accept_statement (st);
}
static gfc_statement
parse_executable (gfc_statement st)
{
int close_flag;
if (st == ST_NONE)
st = next_statement ();
for (;; st = next_statement ())
{
close_flag = check_do_closure ();
if (close_flag)
switch (st)
{
case ST_GOTO:
case ST_END_PROGRAM:
case ST_RETURN:
case ST_EXIT:
case ST_END_FUNCTION:
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
gfc_error
("%s statement at %C cannot terminate a non-block DO loop",
gfc_ascii_statement (st));
break;
default:
break;
}
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_FORMAT:
case ST_DATA:
case ST_ENTRY:
case_executable:
accept_statement (st);
if (close_flag == 1)
return ST_IMPLIED_ENDDO;
continue;
case ST_IF_BLOCK:
parse_if_block ();
continue;
case ST_SELECT_CASE:
parse_select_block ();
continue;
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
return ST_IMPLIED_ENDDO;
continue;
case ST_WHERE_BLOCK:
parse_where_block ();
continue;
case ST_FORALL_BLOCK:
parse_forall_block ();
continue;
default:
break;
}
break;
}
return st;
}
static void parse_progunit (gfc_statement);
static void
gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
{
gfc_namespace *ns;
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);
if (!st)
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)
{
st->n.sym = sym;
sym->refs++;
old_sym->refs--;
if (old_sym->refs == 0)
gfc_free_symbol (old_sym);
}
gfc_fixup_sibling_symbols (sym, ns->contained);
}
}
static void
parse_contained (int module)
{
gfc_namespace *ns, *parent_ns;
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, 1);
gfc_current_ns->sibling = parent_ns->contained;
parent_ns->contained = gfc_current_ns;
st = next_statement ();
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_FUNCTION:
case ST_SUBROUTINE:
accept_statement (st);
push_state (&s2,
(st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
gfc_new_block);
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);
else
{
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, sym->name,
&gfc_new_block->declared_at);
else
gfc_add_subroutine (&sym->attr, sym->name,
&gfc_new_block->declared_at);
}
}
gfc_commit_symbols ();
}
else
sym = gfc_new_block;
sym->attr.contained = 1;
sym->attr.referenced = 1;
parse_progunit (ST_NONE);
gfc_fixup_sibling_symbols (sym, gfc_current_ns);
for (el = gfc_current_ns->entries; el; el = el->next)
gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
gfc_current_ns->code = s2.head;
gfc_current_ns = parent_ns;
pop_state ();
break;
case ST_END_FUNCTION:
case ST_END_MODULE:
case ST_END_PROGRAM:
case ST_END_SUBROUTINE:
accept_statement (st);
break;
default:
gfc_error ("Unexpected %s statement in CONTAINS section at %C",
gfc_ascii_statement (st));
reject_statement ();
break;
}
}
while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
&& st != ST_END_MODULE && st != ST_END_PROGRAM);
gfc_current_ns = parent_ns;
ns = gfc_current_ns->contained;
gfc_current_ns->contained = ns->sibling;
gfc_free_namespace (ns);
pop_state ();
}
static void
parse_progunit (gfc_statement st)
{
gfc_state_data *p;
int n;
st = parse_spec (st);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_CONTAINS:
goto contains;
case_end:
accept_statement (st);
goto done;
default:
break;
}
loop:
for (;;)
{
st = parse_executable (st);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_CONTAINS:
goto contains;
case_end:
accept_statement (st);
goto done;
default:
break;
}
unexpected_statement (st);
reject_statement ();
st = next_statement ();
}
contains:
n = 0;
for (p = gfc_state_stack; p; p = p->previous)
if (p->state == COMP_CONTAINS)
n++;
if (gfc_find_state (COMP_MODULE) == SUCCESS)
n--;
if (n > 0)
{
gfc_error ("CONTAINS statement at %C is already in a contained "
"program unit");
st = next_statement ();
goto loop;
}
parse_contained (0);
done:
gfc_current_ns->code = gfc_state_stack->head;
}
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);
}
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);
while (st != ST_END_BLOCK_DATA)
{
gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
gfc_ascii_statement (st));
reject_statement ();
st = next_statement ();
}
}
static void
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);
loop:
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_CONTAINS:
parse_contained (1);
break;
case ST_END_MODULE:
accept_statement (st);
break;
default:
gfc_error ("Unexpected %s statement in MODULE at %C",
gfc_ascii_statement (st));
reject_statement ();
st = next_statement ();
goto loop;
}
}
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;
}
}
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;
}
}
try
gfc_parse_file (void)
{
int seen_program, errors_before, errors;
gfc_state_data top, s;
gfc_statement st;
locus prog_locus;
top.state = COMP_NONE;
top.sym = NULL;
top.previous = NULL;
top.head = top.tail = NULL;
top.do_variable = NULL;
gfc_state_stack = ⊤
gfc_clear_new_st ();
gfc_statement_label = NULL;
if (setjmp (eof_buf))
return FAILURE;
seen_program = 0;
loop:
gfc_init_2 ();
st = next_statement ();
switch (st)
{
case ST_NONE:
gfc_done_2 ();
goto done;
case ST_PROGRAM:
if (seen_program)
goto duplicate_main;
seen_program = 1;
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
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);
break;
case ST_BLOCK_DATA:
push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
accept_statement (st);
parse_block_data ();
break;
case ST_MODULE:
push_state (&s, COMP_MODULE, gfc_new_block);
accept_statement (st);
gfc_get_errors (NULL, &errors_before);
parse_module ();
break;
default:
if (seen_program)
goto duplicate_main;
seen_program = 1;
prog_locus = gfc_current_locus;
push_state (&s, COMP_PROGRAM, gfc_new_block);
parse_progunit (st);
break;
}
gfc_current_ns->code = s.head;
gfc_resolve (gfc_current_ns);
if (gfc_option.verbose)
gfc_show_namespace (gfc_current_ns);
gfc_get_errors (NULL, &errors);
if (s.state == COMP_MODULE)
{
gfc_dump_module (s.sym->name, errors_before == errors);
if (errors == 0 && ! gfc_option.flag_no_backend)
gfc_generate_module_code (gfc_current_ns);
}
else
{
if (errors == 0 && ! gfc_option.flag_no_backend)
gfc_generate_code (gfc_current_ns);
}
pop_state ();
gfc_done_2 ();
goto loop;
done:
return SUCCESS;
duplicate_main:
gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
reject_statement ();
gfc_done_2 ();
return SUCCESS;
}