/* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
- 2009
+ 2009, 2010
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);
break;
case 'd':
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- /* Check for the IF, DO, SELECT, WHERE and FORALL 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, 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
the matcher is called. */
if (gfc_match_if (&st) == MATCH_YES)
gfc_current_locus = old_locus;
match (NULL, gfc_match_do, ST_DO);
+ match (NULL, gfc_match_block, ST_BLOCK);
+ match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
+ match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
/* General statement matching: Instead of testing every possible
statement, we eliminate most possibilities by peeking at the
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 ("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':
match ("target", gfc_match_target, ST_ATTR_DECL);
match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+ match ("type is", gfc_match_type_is, ST_TYPE_IS);
break;
case 'u':
return ST_NONE;
}
+static gfc_statement
+decode_gcc_attribute (void)
+{
+ locus old_locus;
+
+#ifdef GFC_DEBUG
+ gfc_symbol_state ();
+#endif
+
+ gfc_clear_error (); /* Clear any pending errors. */
+ gfc_clear_warning (); /* Clear any pending warnings. */
+ old_locus = gfc_current_locus;
+
+ match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
+
+ /* All else has failed, so give up. See if any of the matchers has
+ stored an error message of some sort. */
+
+ if (gfc_error_check () == 0)
+ gfc_error_now ("Unclassifiable GCC directive at %C");
+
+ reject_statement ();
+
+ gfc_error_recovery ();
+
+ return ST_NONE;
+}
+
#undef match
if (gfc_match_eos () == MATCH_YES)
{
gfc_warning_now ("Ignoring statement label in empty statement "
- "at %C");
+ "at %L", &label_locus);
gfc_free_st_label (gfc_statement_label);
gfc_statement_label = NULL;
return ST_NONE;
else if (c == '!')
{
/* Comments have already been skipped by the time we get here,
- except for OpenMP directives. */
- if (gfc_option.flag_openmp)
+ except for GCC attributes and OpenMP directives. */
+
+ gfc_next_ascii_char (); /* Eat up the exclamation sign. */
+ c = gfc_peek_ascii_char ();
+
+ if (c == 'g')
{
int i;
c = gfc_next_ascii_char ();
- for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
- gcc_assert (c == "!$omp"[i]);
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "gcc$"[i]);
+
+ gfc_gobble_whitespace ();
+ return decode_gcc_attribute ();
+
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
+ {
+ int i;
+
+ c = gfc_next_ascii_char ();
+ for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
+ gcc_assert (c == "$omp"[i]);
gcc_assert (c == ' ' || c == '\t');
gfc_gobble_whitespace ();
return decode_omp_directive ();
}
- }
+ gcc_unreachable ();
+ }
+
if (at_bol && c == ';')
{
gfc_error_now ("Semicolon at %C needs to be preceded by statement");
break;
/* Comments have already been skipped by the time we get
- here, except for OpenMP directives. */
+ here, except for GCC attributes and OpenMP directives. */
+
case '*':
- if (gfc_option.flag_openmp)
+ c = gfc_next_char_literal (0);
+
+ if (TOLOWER (c) == 'g')
{
- for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
- gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert (TOLOWER (c) == "gcc$"[i]);
+
+ return decode_gcc_attribute ();
+ }
+ else if (c == '$' && gfc_option.flag_openmp)
+ {
+ for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
+ gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
{
blank_line:
if (digit_flag)
- gfc_warning ("Ignoring statement label in empty statement at %C");
+ gfc_warning_now ("Ignoring statement label in empty statement at %L",
+ &label_locus);
+
+ gfc_current_locus.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
}
{
gfc_statement st;
locus old_locus;
+
gfc_new_block = NULL;
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
gfc_buffer_error (1);
if (gfc_at_eol ())
- {
- if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
- && gfc_current_locus.lb
- && gfc_current_locus.lb->truncated)
- gfc_warning_now ("Line truncated at %C");
-
- gfc_advance_line ();
- }
+ gfc_advance_line ();
gfc_skip_comments ();
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_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
+#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
+ case ST_IF_BLOCK: case ST_BLOCK: \
+ 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 */
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: \
+ case ST_END_BLOCK
/* Push a new state onto the stack. */
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_BACKSPACE:
p = "BACKSPACE";
break;
+ case ST_BLOCK:
+ p = "BLOCK";
+ break;
case ST_BLOCK_DATA:
p = "BLOCK DATA";
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_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_SELECT_CASE:
p = "SELECT CASE";
break;
+ case ST_SELECT_TYPE:
+ p = "SELECT TYPE";
+ break;
+ case ST_TYPE_IS:
+ p = "TYPE IS";
+ break;
+ case ST_CLASS_IS:
+ p = "CLASS IS";
+ break;
case ST_SEQUENCE:
p = "SEQUENCE";
break;
case ST_ENDIF:
case ST_END_SELECT:
+ case ST_END_CRITICAL:
if (gfc_statement_label != NULL)
{
new_st.op = EXEC_END_BLOCK;
new_st.op = EXEC_RETURN;
add_statement ();
}
+ else
+ {
+ new_st.op = EXEC_END_PROCEDURE;
+ add_statement ();
+ }
break;
*/
+enum state_order
+{
+ ORDER_START,
+ ORDER_USE,
+ ORDER_IMPORT,
+ ORDER_IMPLICIT_NONE,
+ ORDER_IMPLICIT,
+ ORDER_SPEC,
+ ORDER_EXEC
+};
+
typedef struct
{
- enum
- { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
- ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
- }
- state;
+ enum state_order state;
gfc_statement last_statement;
locus where;
}
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 *derived_sym = NULL;
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:
/* need to verify that all fields of the derived type are
* interoperable with C if the type is declared to be bind(c)
*/
- derived_sym = gfc_current_block();
-
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
+ || (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->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_DERIVED && c->ts.derived->attr.pointer_comp))
+ || (c->ts.type == BT_CLASS
+ && c->ts.u.derived->components->attr.pointer)
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
sym->attr.pointer_comp = 1;
/* Look for procedure pointer components. */
if (c->attr.proc_pointer
|| (c->ts.type == BT_DERIVED
- && c->ts.derived->attr.proc_pointer_comp))
+ && 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
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
+ || (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)
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;
{
if (current_state == COMP_NONE)
{
- if (new_state == COMP_FUNCTION)
+ if (new_state == COMP_FUNCTION && sym)
gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE)
+ else if (new_state == COMP_SUBROUTINE && sym)
gfc_add_subroutine (&sym->attr, sym->name, NULL);
current_state = new_state;
{
ts->kind = 0;
- if (!ts->derived || !ts->derived->components)
+ if (!ts->u.derived)
m = MATCH_ERROR;
}
/* Check type-parameters, at the moment only CHARACTER lengths possible. */
/* TODO: Extend when KIND type parameters are implemented. */
- if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
- gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
+ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
+ gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
}
}
loop:
+
+ /* If we're inside a BLOCK construct, some statements are disallowed.
+ Check this here. Attribute declaration statements like INTENT, OPTIONAL
+ or VALUE are also disallowed, but they don't have a particular ST_*
+ key so we have to check for them individually in their matcher routine. */
+ if (gfc_current_state () == COMP_BLOCK)
+ switch (st)
+ {
+ case ST_IMPLICIT:
+ case ST_IMPLICIT_NONE:
+ case ST_NAMELIST:
+ case ST_COMMON:
+ case ST_EQUIVALENCE:
+ case ST_STATEMENT_FUNCTION:
+ gfc_error ("%s statement is not allowed inside of BLOCK at %C",
+ gfc_ascii_statement (st));
+ break;
+
+ default:
+ break;
+ }
/* If we find a statement that can not be followed by an IMPLICIT statement
(and thus we can expect to see none any further), type the function result
gfc_current_block ()->ts.kind = 0;
/* Keep the derived type; if it's bad, it will be discovered later. */
- if (!(ts->type == BT_DERIVED && ts->derived))
+ if (!(ts->type == BT_DERIVED && ts->u.derived))
ts->type = BT_UNKNOWN;
}
push_state (&s, COMP_WHERE, gfc_new_block);
d = add_statement ();
- d->expr = top->expr;
+ d->expr1 = top->expr1;
d->op = EXEC_WHERE;
- top->expr = NULL;
+ top->expr1 = NULL;
top->block = d;
seen_empty_else = 0;
break;
}
- if (new_st.expr == NULL)
+ if (new_st.expr1 == NULL)
seen_empty_else = 1;
d = new_level (gfc_state_stack->head);
d->op = EXEC_WHERE;
- d->expr = new_st.expr;
+ d->expr1 = new_st.expr1;
accept_statement (st);
new_st.op = EXEC_IF;
d = add_statement ();
- d->expr = top->expr;
- top->expr = NULL;
+ d->expr1 = top->expr1;
+ top->expr1 = NULL;
top->block = d;
do
d = new_level (gfc_state_stack->head);
d->op = EXEC_IF;
- d->expr = new_st.expr;
+ d->expr1 = new_st.expr1;
accept_statement (st);
}
+/* Pop the current selector from the SELECT TYPE stack. */
+
+static void
+select_type_pop (void)
+{
+ gfc_select_type_stack *old = select_type_stack;
+ select_type_stack = old->prev;
+ gfc_free (old);
+}
+
+
+/* Parse a SELECT TYPE construct (F03:R821). */
+
+static void
+parse_select_type_block (void)
+{
+ gfc_statement st;
+ gfc_code *cp;
+ gfc_state_data s;
+
+ accept_statement (ST_SELECT_TYPE);
+
+ cp = gfc_state_stack->tail;
+ push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
+
+ /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
+ or END SELECT. */
+ for (;;)
+ {
+ st = next_statement ();
+ if (st == ST_NONE)
+ unexpected_eof ();
+ if (st == ST_END_SELECT)
+ /* Empty SELECT CASE is OK. */
+ goto done;
+ if (st == ST_TYPE_IS || st == ST_CLASS_IS)
+ break;
+
+ gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
+ "following SELECT TYPE at %C");
+
+ reject_statement ();
+ }
+
+ /* At this point, we're got a nonempty select block. */
+ 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_TYPE_IS:
+ case ST_CLASS_IS:
+ cp = new_level (gfc_state_stack->head);
+ *cp = new_st;
+ gfc_clear_new_st ();
+
+ accept_statement (st);
+ /* Fall through */
+
+ case ST_END_SELECT:
+ break;
+
+ /* Can't have an executable statement because of
+ parse_executable(). */
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+ while (st != ST_END_SELECT);
+
+done:
+ pop_state ();
+ accept_statement (st);
+ gfc_current_ns = gfc_current_ns->parent;
+ select_type_pop ();
+}
+
+
/* 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
}
+/* Parse a series of contained program units. */
+
+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*
+gfc_build_block_ns (gfc_namespace *parent_ns)
+{
+ gfc_namespace* my_ns;
+
+ my_ns = gfc_get_namespace (parent_ns, 1);
+ my_ns->construct_entities = 1;
+
+ /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
+ code generation (so it must not be NULL).
+ We set its recursive argument if our container procedure is recursive, so
+ that local variables are accordingly placed on the stack when it
+ will be necessary. */
+ if (gfc_new_block)
+ my_ns->proc_name = gfc_new_block;
+ else
+ {
+ gfc_try t;
+
+ gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
+ t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
+ my_ns->proc_name->name, NULL);
+ gcc_assert (t == SUCCESS);
+ }
+
+ if (parent_ns->proc_name)
+ my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
+
+ return my_ns;
+}
+
+
+/* Parse a BLOCK construct. */
+
+static void
+parse_block_construct (void)
+{
+ gfc_namespace* my_ns;
+ gfc_state_data s;
+
+ gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
+
+ my_ns = gfc_build_block_ns (gfc_current_ns);
+
+ new_st.op = EXEC_BLOCK;
+ new_st.ext.ns = my_ns;
+ accept_statement (ST_BLOCK);
+
+ push_state (&s, COMP_BLOCK, my_ns->proc_name);
+ gfc_current_ns = my_ns;
+
+ parse_progunit (ST_NONE);
+
+ 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. */
gfc_state_data s;
gfc_symtree *stree;
- s.ext.end_do_label = new_st.label;
+ s.ext.end_do_label = new_st.label1;
if (new_st.ext.iterator != NULL)
stree = new_st.ext.iterator->var->symtree;
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
+ case ST_ERROR_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
+ case ST_CRITICAL:
+ case ST_BLOCK:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
return ST_IMPLIED_ENDDO;
break;
+ case ST_BLOCK:
+ parse_block_construct ();
+ break;
+
case ST_IF_BLOCK:
parse_if_block ();
break;
parse_select_block ();
break;
+ case ST_SELECT_TYPE:
+ parse_select_type_block();
+ break;
+
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
return ST_IMPLIED_ENDDO;
break;
+ case ST_CRITICAL:
+ parse_critical_block ();
+ break;
+
case ST_WHERE_BLOCK:
parse_where_block ();
break;
}
-/* Parse a series of contained program units. */
-
-static void parse_progunit (gfc_statement);
-
-
/* Fix the symbols for sibling functions. These are incorrectly added to
the child namespace as the parser didn't know about this procedure. */
}
-/* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
+/* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
static void
parse_progunit (gfc_statement st)
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
unexpected_eof ();
case ST_CONTAINS:
- goto contains;
+ /* This is not allowed within BLOCK! */
+ if (gfc_current_state () != COMP_BLOCK)
+ goto contains;
+ break;
case_end:
accept_statement (st);
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
}
+/* Resolve all the program units when whole file scope option
+ is active. */
+static void
+resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+ gfc_free_dt_list ();
+ 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;
+ gfc_resolve (gfc_current_ns);
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ }
+}
+
+
+static void
+clean_up_modules (gfc_gsymbol *gsym)
+{
+ if (gsym == NULL)
+ return;
+
+ clean_up_modules (gsym->left);
+ clean_up_modules (gsym->right);
+
+ if (gsym->type != GSYM_MODULE || !gsym->ns)
+ return;
+
+ gfc_current_ns = gsym->ns;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_done_2 ();
+ gsym->ns = NULL;
+ return;
+}
+
+
+/* Translate all the program units when whole file scope option
+ is active. This could be in a different order to resolution if
+ there are forward references in the file. */
+static void
+translate_all_program_units (gfc_namespace *gfc_global_ns_list)
+{
+ int errors;
+
+ gfc_current_ns = gfc_global_ns_list;
+ gfc_get_errors (NULL, &errors);
+
+ for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_generate_code (gfc_current_ns);
+ gfc_current_ns->translated = 1;
+ }
+
+ /* Clean up all the namespaces after translation. */
+ gfc_current_ns = gfc_global_ns_list;
+ for (;gfc_current_ns;)
+ {
+ gfc_namespace *ns = gfc_current_ns->sibling;
+ gfc_derived_types = gfc_current_ns->derived_types;
+ gfc_done_2 ();
+ gfc_current_ns = ns;
+ }
+
+ clean_up_modules (gfc_gsym_root);
+}
+
+
/* Top level parser. */
gfc_try
gfc_dump_module (s.sym->name, errors_before == errors);
if (errors == 0)
gfc_generate_module_code (gfc_current_ns);
+ pop_state ();
+ if (!gfc_option.flag_whole_file)
+ gfc_done_2 ();
+ else
+ {
+ gfc_current_ns->derived_types = gfc_derived_types;
+ gfc_derived_types = NULL;
+ gfc_current_ns = NULL;
+ }
}
else
{
if (errors == 0)
gfc_generate_code (gfc_current_ns);
+ pop_state ();
+ gfc_done_2 ();
}
- pop_state ();
- gfc_done_2 ();
goto loop;
prog_units:
if (!gfc_option.flag_whole_file)
goto termination;
- /* Do the resolution. */
- 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;
- gfc_resolve (gfc_current_ns);
- }
+ /* Do the resolution. */
+ resolve_all_program_units (gfc_global_ns_list);
/* Do the parse tree dump. */
- gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+ gfc_current_ns
+ = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
gfc_dump_parse_tree (gfc_current_ns, stdout);
- fputs ("-----------------------------------------\n\n", stdout);
+ fputs ("------------------------------------------\n\n", stdout);
}
- gfc_current_ns = gfc_global_ns_list;
- gfc_get_errors (NULL, &errors);
-
- /* Do the translation. This could be in a different order to
- resolution if there are forward references in the file. */
- for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
- {
- gfc_current_locus = gfc_current_ns->proc_name->declared_at;
- gfc_generate_code (gfc_current_ns);
- }
+ /* Do the translation. */
+ translate_all_program_units (gfc_global_ns_list);
termination:
- gfc_free_dt_list ();
gfc_end_source_files ();
return SUCCESS;
OSDN Git Service
