/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009, 2010
+ 2009, 2010, 2011
Free Software Foundation, Inc.
Contributed by Andy Vaught
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, CRITICAL, and BLOCK
+ /* 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. */
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 ("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);
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;
/* 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: \
#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_ALLOCATE:
p = "ALLOCATE";
break;
+ case ST_ASSOCIATE:
+ p = "ASSOCIATE";
+ break;
case ST_ATTR_DECL:
p = _("attribute declaration");
break;
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
+ case ST_END_ASSOCIATE:
+ p = "END ASSOCIATE";
+ break;
case ST_END_BLOCK:
p = "END BLOCK";
break;
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 ();
{
/* 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->attr.access == ACCESS_PRIVATE
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
sym->attr.private_comp = 1;
-
- /* Fix up incomplete CLASS components. */
- if (c->ts.type == BT_CLASS)
- {
- gfc_component *data;
- gfc_component *vptr;
- gfc_symbol *vtab;
- data = gfc_find_component (c->ts.u.derived, "$data", true, true);
- vptr = gfc_find_component (c->ts.u.derived, "$vptr", true, true);
- if (vptr->ts.u.derived == NULL)
- {
- vtab = gfc_find_derived_vtab (data->ts.u.derived, false);
- gcc_assert (vtab);
- vptr->ts.u.derived = vtab->ts.u.derived;
- }
- }
}
if (!seen_component)
}
- /* 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 && sym)
- gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE && sym)
- 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)
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;
}
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_END_SUBROUTINE:
case ST_DO:
- case ST_CRITICAL:
- case ST_BLOCK:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
parse_block_construct ();
break;
+ case ST_ASSOCIATE:
+ parse_associate ();
+ break;
+
case ST_IF_BLOCK:
parse_if_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)
{