/* 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':
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;
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_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_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;
&& 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.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->u.derived || !ts->u.derived->components)
+ if (!ts->u.derived)
m = MATCH_ERROR;
}
}
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
}
+/* 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. */
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);