/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
match ("import", gfc_match_import, ST_IMPORT);
match ("use", gfc_match_use, ST_USE);
- if (gfc_current_block ()->ts.type != BT_DERIVED)
+ if (gfc_current_block ()->result->ts.type != BT_DERIVED)
goto end_of_block;
match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
case 'a':
match ("abstract% interface", gfc_match_abstract_interface,
ST_INTERFACE);
+ match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
+ match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
break;
case 'b':
break;
case 'c':
+ match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
+ match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
break;
case 'd':
match m;
char c;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
- might begin with a block label. The match functions for these
- statements are unusual in that their keyword is not seen before
+ /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
+ statements, which might begin with a block label. The match functions for
+ these statements are unusual in that their keyword is not seen before
the matcher is called. */
if (gfc_match_if (&st) == MATCH_YES)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_do, ST_DO);
+ match (NULL, gfc_match_block, ST_BLOCK);
+ match (NULL, gfc_match_associate, ST_ASSOCIATE);
+ match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
match ("allocate", gfc_match_allocate, ST_ALLOCATE);
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
+ match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
break;
case 'b':
match ("call", gfc_match_call, ST_CALL);
match ("close", gfc_match_close, ST_CLOSE);
match ("continue", gfc_match_continue, ST_CONTINUE);
+ match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
match ("cycle", gfc_match_cycle, ST_CYCLE);
match ("case", gfc_match_case, ST_CASE);
match ("common", gfc_match_common, ST_COMMON);
match ("contains", gfc_match_eos, ST_CONTAINS);
match ("class", gfc_match_class_is, ST_CLASS_IS);
+ match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
break;
case 'd':
match ("else", gfc_match_else, ST_ELSE);
match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
match ("else if", gfc_match_elseif, ST_ELSEIF);
+ match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
if (gfc_match_end (&st) == MATCH_YES)
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
+ match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
+ match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+ match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
break;
case 't':
locus old_locus;
char c;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
return ST_NONE;
}
+ if (gfc_implicit_pure (NULL))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
old_locus = gfc_current_locus;
/* General OpenMP directive matching: Instead of testing every possible
{
locus old_locus;
-#ifdef GFC_DEBUG
- gfc_symbol_state ();
-#endif
+ gfc_enforce_clean_symbol_state ();
gfc_clear_error (); /* Clear any pending errors. */
gfc_clear_warning (); /* Clear any pending warnings. */
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.flag_openmp)
+ else if (c == '$' && gfc_option.gfc_flag_openmp)
{
int i;
if (at_bol && c == ';')
{
- gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ if (!(gfc_option.allow_std & GFC_STD_F2008))
+ gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
+ "statement");
gfc_next_ascii_char (); /* Eat up the semicolon. */
return ST_NONE;
}
for (i = 0; i < 5; i++)
{
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
switch (c)
{
here, except for GCC attributes and OpenMP directives. */
case '*':
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (TOLOWER (c) == 'g')
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert (TOLOWER (c) == "gcc$"[i]);
return decode_gcc_attribute ();
}
- else if (c == '$' && gfc_option.flag_openmp)
+ else if (c == '$' && gfc_option.gfc_flag_openmp)
{
- for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
of a previous statement. If we see something here besides a
space or zero, it must be a bad continuation line. */
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
if (c == '\n')
goto blank_line;
do
{
loc = gfc_current_locus;
- c = gfc_next_char_literal (0);
+ c = gfc_next_char_literal (NONSTRING);
}
while (gfc_is_whitespace (c));
if (c == ';')
{
- gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ if (digit_flag)
+ gfc_error_now ("Semicolon at %C needs to be preceded by statement");
+ else if (!(gfc_option.allow_std & GFC_STD_F2008))
+ gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
+ "statement");
return ST_NONE;
}
gfc_statement st;
locus old_locus;
+ gfc_enforce_clean_symbol_state ();
+
gfc_new_block = NULL;
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
+ gfc_current_ns->old_equiv = gfc_current_ns->equiv;
for (;;)
{
gfc_statement_label = NULL;
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
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_TASKWAIT
+ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
+ case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
/* Statements that mark other executable statements. */
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
- case ST_IF_BLOCK: case ST_BLOCK: \
+ case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
case ST_OMP_PARALLEL: \
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
- case ST_OMP_TASK
+ case ST_OMP_TASK: case ST_CRITICAL
/* Declaration statements */
#define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
- case ST_END_BLOCK
+ case ST_END_BLOCK: case ST_END_ASSOCIATE
/* Push a new state onto the stack. */
p->sym = sym;
p->head = p->tail = NULL;
p->do_variable = NULL;
+
+ /* If this the state of a construct like BLOCK, DO or IF, the corresponding
+ construct statement was accepted right before pushing the state. Thus,
+ the construct's gfc_code is available as tail of the parent state. */
+ gcc_assert (gfc_state_stack);
+ p->construct = gfc_state_stack->tail;
+
gfc_state_stack = p;
}
case ST_ENDDO:
case ST_ENDIF:
case ST_END_SELECT:
+ case ST_END_CRITICAL:
case_executable:
case_exec_markers:
type = ST_LABEL_TARGET;
case ST_ALLOCATE:
p = "ALLOCATE";
break;
+ case ST_ASSOCIATE:
+ p = "ASSOCIATE";
+ break;
case ST_ATTR_DECL:
p = _("attribute declaration");
break;
case ST_CONTAINS:
p = "CONTAINS";
break;
+ case ST_CRITICAL:
+ p = "CRITICAL";
+ break;
case ST_CYCLE:
p = "CYCLE";
break;
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_END_ASSOCIATE:
+ p = "END ASSOCIATE";
+ break;
case ST_END_BLOCK:
p = "END BLOCK";
break;
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
+ case ST_END_CRITICAL:
+ p = "END CRITICAL";
+ break;
case ST_ENDDO:
p = "END DO";
break;
case ST_EQUIVALENCE:
p = "EQUIVALENCE";
break;
+ case ST_ERROR_STOP:
+ p = "ERROR STOP";
+ break;
case ST_EXIT:
p = "EXIT";
break;
case ST_STOP:
p = "STOP";
break;
+ case ST_SYNC_ALL:
+ p = "SYNC ALL";
+ break;
+ case ST_SYNC_IMAGES:
+ p = "SYNC IMAGES";
+ break;
+ case ST_SYNC_MEMORY:
+ p = "SYNC MEMORY";
+ break;
case ST_SUBROUTINE:
p = "SUBROUTINE";
break;
case ST_ENDIF:
case ST_END_SELECT:
+ case ST_END_CRITICAL:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_END_BLOCK;
gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
+ gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
+ gfc_current_ns->equiv = gfc_current_ns->old_equiv;
+
gfc_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
case ST_DATA_DECL:
gfc_error ("Components in TYPE at %C must precede CONTAINS");
- error_flag = true;
- break;
+ goto error;
case ST_PROCEDURE:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
" procedure at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_PROCEDURE);
seen_comps = true;
case ST_GENERIC:
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
" at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_GENERIC);
seen_comps = true;
if (gfc_notify_std (GFC_STD_F2003,
"Fortran 2003: FINAL procedure declaration"
" at %C") == FAILURE)
- error_flag = true;
+ goto error;
accept_statement (ST_FINAL);
seen_comps = true;
&& (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
"definition at %C with empty CONTAINS "
"section") == FAILURE))
- error_flag = true;
+ goto error;
/* ST_END_TYPE is accepted by parse_derived after return. */
break;
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
- error_flag = true;
- break;
+ goto error;
}
if (seen_comps)
{
gfc_error ("PRIVATE statement at %C must precede procedure"
" bindings");
- error_flag = true;
- break;
+ goto error;
}
if (seen_private)
{
gfc_error ("Duplicate PRIVATE statement at %C");
- error_flag = true;
+ goto error;
}
accept_statement (ST_PRIVATE);
case ST_SEQUENCE:
gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
- error_flag = true;
- break;
+ goto error;
case ST_CONTAINS:
gfc_error ("Already inside a CONTAINS block at %C");
- error_flag = true;
- break;
+ goto error;
default:
unexpected_statement (st);
break;
}
+
+ continue;
+
+error:
+ error_flag = true;
+ reject_statement ();
}
pop_state ();
static void
parse_derived (void)
{
- int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
+ int compiling_type, seen_private, seen_sequence, seen_component;
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
gfc_component *c;
- error_flag = 0;
-
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
case ST_FINAL:
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
- error_flag = 1;
break;
case ST_END_TYPE:
endType:
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_component)
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+ "definition at %C without components");
accept_statement (ST_END_TYPE);
break;
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
- error_flag = 1;
break;
}
{
gfc_error ("PRIVATE statement at %C must precede "
"structure components");
- error_flag = 1;
break;
}
if (seen_private)
- {
- gfc_error ("Duplicate PRIVATE statement at %C");
- error_flag = 1;
- }
+ gfc_error ("Duplicate PRIVATE statement at %C");
s.sym->component_access = ACCESS_PRIVATE;
{
gfc_error ("SEQUENCE statement at %C must precede "
"structure components");
- error_flag = 1;
break;
}
if (seen_sequence)
{
gfc_error ("Duplicate SEQUENCE statement at %C");
- error_flag = 1;
}
seen_sequence = 1;
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;
+ gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: CONTAINS block in derived type"
+ " definition at %C");
accept_statement (ST_CONTAINS);
- if (parse_derived_contains ())
- error_flag = 1;
+ parse_derived_contains ();
goto endType;
default:
{
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_CLASS
- && c->ts.u.derived->components->attr.allocatable)
+ || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
sym->attr.alloc_comp = 1;
/* Look for pointer components. */
if (c->attr.pointer
- || (c->ts.type == BT_CLASS
- && c->ts.u.derived->components->attr.pointer)
+ || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
sym->attr.pointer_comp = 1;
&& c->ts.u.derived->attr.proc_pointer_comp))
sym->attr.proc_pointer_comp = 1;
+ /* Looking for coarray components. */
+ if (c->attr.codimension
+ || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
+ sym->attr.coarray_comp = 1;
+
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE
static void
parse_enum (void)
{
- int error_flag;
gfc_statement st;
int compiling_enum;
gfc_state_data s;
int seen_enumerator = 0;
- error_flag = 0;
-
push_state (&s, COMP_ENUM, gfc_new_block);
compiling_enum = 1;
case ST_END_ENUM:
compiling_enum = 0;
if (!seen_enumerator)
- {
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
- error_flag = 1;
- }
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
accept_statement (st);
break;
}
- /* Make sure that a generic interface has only subroutines or
- functions and that the generic name has the right attribute. */
- if (current_interface.type == INTERFACE_GENERIC)
+ /* Make sure that the generic name has the right attribute. */
+ if (current_interface.type == INTERFACE_GENERIC
+ && current_state == COMP_NONE)
{
- 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 && sym)
+ gfc_add_function (&sym->attr, sym->name, NULL);
+ else if (new_state == COMP_SUBROUTINE && sym)
+ gfc_add_subroutine (&sym->attr, sym->name, NULL);
- if (new_state == COMP_FUNCTION)
- gfc_error ("FUNCTION at %C does not belong in a "
- "generic subroutine interface");
- }
- }
+ current_state = new_state;
}
if (current_interface.type == INTERFACE_ABSTRACT)
{
ts->kind = 0;
- if (!ts->u.derived || !ts->u.derived->components)
+ if (!ts->u.derived)
m = MATCH_ERROR;
}
gfc_commit_symbols ();
}
else
- gfc_error_check ();
+ {
+ gfc_error_check ();
+ gfc_undo_symbols ();
+ }
gfc_current_locus =loc;
return m;
case ST_STATEMENT_FUNCTION:
gfc_error ("%s statement is not allowed inside of BLOCK at %C",
gfc_ascii_statement (st));
+ reject_statement ();
break;
default:
{
gfc_error ("%s statement must appear in a MODULE",
gfc_ascii_statement (st));
+ reject_statement ();
break;
}
{
gfc_error ("%s statement at %C follows another accessibility "
"specification", gfc_ascii_statement (st));
+ reject_statement ();
break;
}
static void parse_progunit (gfc_statement);
+/* Parse a CRITICAL block. */
+
+static void
+parse_critical_block (void)
+{
+ gfc_code *top, *d;
+ gfc_state_data s;
+ gfc_statement st;
+
+ s.ext.end_do_label = new_st.label1;
+
+ accept_statement (ST_CRITICAL);
+ top = gfc_state_stack->tail;
+
+ push_state (&s, COMP_CRITICAL, gfc_new_block);
+
+ d = add_statement ();
+ d->op = EXEC_CRITICAL;
+ top->block = d;
+
+ do
+ {
+ st = parse_executable (ST_NONE);
+
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
+
+ case ST_END_CRITICAL:
+ if (s.ext.end_do_label != NULL
+ && s.ext.end_do_label != gfc_statement_label)
+ gfc_error_now ("Statement label in END CRITICAL at %C does not "
+ "match CRITIAL label");
+
+ if (gfc_statement_label != NULL)
+ {
+ new_st.op = EXEC_NOP;
+ add_statement ();
+ }
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+ while (st != ST_END_CRITICAL);
+
+ pop_state ();
+ accept_statement (st);
+}
+
+
/* Set up the local namespace for a BLOCK construct. */
gfc_namespace*
my_ns = gfc_build_block_ns (gfc_current_ns);
new_st.op = EXEC_BLOCK;
- new_st.ext.ns = my_ns;
+ new_st.ext.block.ns = my_ns;
+ new_st.ext.block.assoc = NULL;
accept_statement (ST_BLOCK);
push_state (&s, COMP_BLOCK, my_ns->proc_name);
}
+/* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
+ behind the scenes with compiler-generated variables. */
+
+static void
+parse_associate (void)
+{
+ gfc_namespace* my_ns;
+ gfc_state_data s;
+ gfc_statement st;
+ gfc_association_list* a;
+
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
+
+ my_ns = gfc_build_block_ns (gfc_current_ns);
+
+ new_st.op = EXEC_BLOCK;
+ new_st.ext.block.ns = my_ns;
+ gcc_assert (new_st.ext.block.assoc);
+
+ /* Add all associate-names as BLOCK variables. Creating them is enough
+ for now, they'll get their values during trans-* phase. */
+ gfc_current_ns = my_ns;
+ for (a = new_st.ext.block.assoc; a; a = a->next)
+ {
+ gfc_symbol* sym;
+
+ if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+ gcc_unreachable ();
+
+ sym = a->st->n.sym;
+ sym->attr.flavor = FL_VARIABLE;
+ sym->assoc = a;
+ sym->declared_at = a->where;
+ gfc_set_sym_referenced (sym);
+
+ /* Initialize the typespec. It is not available in all cases,
+ however, as it may only be set on the target during resolution.
+ Still, sometimes it helps to have it right now -- especially
+ for parsing component references on the associate-name
+ in case of assication to a derived-type. */
+ sym->ts = a->target->ts;
+ }
+
+ accept_statement (ST_ASSOCIATE);
+ push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
+
+loop:
+ st = parse_executable (ST_NONE);
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+
+ case_end:
+ accept_statement (st);
+ my_ns->code = gfc_state_stack->head;
+ break;
+
+ default:
+ unexpected_statement (st);
+ goto loop;
+ }
+
+ gfc_current_ns = gfc_current_ns->parent;
+ pop_state ();
+}
+
+
/* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
handled inside of parse_executable(), because they aren't really
loop statements. */
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
+ case ST_ERROR_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
parse_block_construct ();
break;
+ case ST_ASSOCIATE:
+ parse_associate ();
+ break;
+
case ST_IF_BLOCK:
parse_if_block ();
break;
return ST_IMPLIED_ENDDO;
break;
+ case ST_CRITICAL:
+ parse_critical_block ();
+ break;
+
case ST_WHERE_BLOCK:
parse_where_block ();
break;
|| (old_sym->ts.type != BT_UNKNOWN
&& !old_sym->attr.implicit_type)
|| old_sym->attr.flavor == FL_PARAMETER
+ || old_sym->attr.use_assoc
|| old_sym->attr.in_common
|| old_sym->attr.in_equivalence
|| old_sym->attr.data
st->n.sym = sym;
sym->refs++;
- /* Free the old (local) symbol. */
- old_sym->refs--;
- if (old_sym->refs == 0)
- gfc_free_symbol (old_sym);
+ gfc_release_symbol (old_sym);
}
fixup_contained:
sym->attr.contained = 1;
sym->attr.referenced = 1;
+ /* Set implicit_pure so that it can be reset if any of the
+ tests for purity fail. This is used for some optimisation
+ during translation. */
+ if (!sym->attr.pure)
+ sym->attr.implicit_pure = 1;
+
parse_progunit (ST_NONE);
/* Fix up any sibling functions that refer to this one. */
{
gfc_error ("CONTAINS statement at %C is already in a contained "
"program unit");
+ reject_statement ();
st = next_statement ();
goto loop;
}
gfc_current_ns = gfc_global_ns_list;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ if (gfc_current_ns->proc_name)
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_resolve (gfc_current_ns);
gfc_current_ns->derived_types = gfc_derived_types;
gfc_derived_types = NULL;
gfc_resolve (gfc_current_ns);
/* Dump the parse tree if requested. */
- if (gfc_option.dump_parse_tree)
+ if (gfc_option.dump_fortran_original)
gfc_dump_parse_tree (gfc_current_ns, stdout);
gfc_get_errors (NULL, &errors);
later and all their interfaces resolved. */
gfc_current_ns->code = s.head;
if (next)
- next->sibling = gfc_current_ns;
+ {
+ for (; next->sibling; next = next->sibling)
+ ;
+ next->sibling = gfc_current_ns;
+ }
else
gfc_global_ns_list = gfc_current_ns;
/* Do the parse tree dump. */
gfc_current_ns
- = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+ = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
OSDN Git Service
