break;
case 'g':
+ match ("generic", gfc_match_generic, ST_GENERIC);
match ("go to", gfc_match_goto, ST_GOTO);
break;
locus old_locus;
gfc_new_block = NULL;
+ gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
for (;;)
{
gfc_statement_label = NULL;
/* Try to find the given state in the state stack. */
-try
+gfc_try
gfc_find_state (gfc_compile_state state)
{
gfc_state_data *p;
case ST_FUNCTION:
p = "FUNCTION";
break;
+ case ST_GENERIC:
+ p = "GENERIC";
+ break;
case ST_GOTO:
p = "GOTO";
break;
static void
reject_statement (void)
{
+ /* Revert to the previous charlen chain. */
+ 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_new_block = NULL;
gfc_undo_symbols ();
gfc_clear_warning ();
issue an error and return FAILURE. Otherwise we return SUCCESS.
Individual parsers need to verify that the statements seen are
- valid before calling here, ie ENTRY statements are not allowed in
+ valid before calling here, i.e., ENTRY statements are not allowed in
INTERFACE blocks. The following diagram is taken from the standard:
+---------------------------------------+
}
st_state;
-static try
-verify_st_order (st_state *p, gfc_statement st)
+static gfc_try
+verify_st_order (st_state *p, gfc_statement st, bool silent)
{
switch (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);
+ if (!silent)
+ 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;
}
}
+/* Parse the CONTAINS section of a derived type definition. */
+
+gfc_access gfc_typebound_default_access;
+
+static bool
+parse_derived_contains (void)
+{
+ gfc_state_data s;
+ bool seen_private = false;
+ bool seen_comps = false;
+ bool error_flag = false;
+ bool to_finish;
+
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+ gcc_assert (gfc_current_block ());
+
+ /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
+ section. */
+ if (gfc_current_block ()->attr.sequence)
+ gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
+ " section at %C", gfc_current_block ()->name);
+ if (gfc_current_block ()->attr.is_bind_c)
+ gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
+ " section at %C", gfc_current_block ()->name);
+
+ accept_statement (ST_CONTAINS);
+ push_state (&s, COMP_DERIVED_CONTAINS, NULL);
+
+ gfc_typebound_default_access = ACCESS_PUBLIC;
+
+ to_finish = false;
+ while (!to_finish)
+ {
+ gfc_statement st;
+ st = next_statement ();
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
+
+ case ST_DATA_DECL:
+ gfc_error ("Components in TYPE at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_PROCEDURE:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound"
+ " procedure at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_PROCEDURE);
+ seen_comps = true;
+ break;
+
+ case ST_GENERIC:
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_GENERIC);
+ seen_comps = true;
+ break;
+
+ case ST_FINAL:
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: FINAL procedure declaration"
+ " at %C") == FAILURE)
+ error_flag = true;
+
+ accept_statement (ST_FINAL);
+ seen_comps = true;
+ break;
+
+ case ST_END_TYPE:
+ to_finish = true;
+
+ if (!seen_comps
+ && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
+ "definition at %C with empty CONTAINS "
+ "section") == FAILURE))
+ error_flag = true;
+
+ /* ST_END_TYPE is accepted by parse_derived after return. */
+ 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 = true;
+ break;
+ }
+
+ if (seen_comps)
+ {
+ gfc_error ("PRIVATE statement at %C must precede procedure"
+ " bindings");
+ error_flag = true;
+ break;
+ }
+
+ if (seen_private)
+ {
+ gfc_error ("Duplicate PRIVATE statement at %C");
+ error_flag = true;
+ }
+
+ accept_statement (ST_PRIVATE);
+ gfc_typebound_default_access = ACCESS_PRIVATE;
+ seen_private = true;
+ break;
+
+ case ST_SEQUENCE:
+ gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
+ error_flag = true;
+ break;
+
+ case ST_CONTAINS:
+ gfc_error ("Already inside a CONTAINS block at %C");
+ error_flag = true;
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+
+ pop_state ();
+ gcc_assert (gfc_current_state () == COMP_DERIVED);
+
+ return error_flag;
+}
+
+
/* Parse a derived type. */
static void
parse_derived (void)
{
int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
- int seen_contains, seen_contains_comp;
gfc_statement st;
gfc_state_data s;
gfc_symbol *derived_sym = NULL;
seen_private = 0;
seen_sequence = 0;
seen_component = 0;
- seen_contains = 0;
- seen_contains_comp = 0;
compiling_type = 1;
unexpected_eof ();
case ST_DATA_DECL:
- case ST_PROCEDURE:
- if (seen_contains)
- {
- gfc_error ("Components in TYPE at %C must precede CONTAINS");
- error_flag = 1;
- }
-
accept_statement (st);
seen_component = 1;
break;
- case ST_FINAL:
- if (!seen_contains)
- {
- gfc_error ("FINAL declaration at %C must be inside CONTAINS");
- error_flag = 1;
- }
-
- if (gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: FINAL procedure declaration"
- " at %C") == FAILURE)
- error_flag = 1;
+ case ST_PROCEDURE:
+ gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
+ error_flag = 1;
+ break;
- accept_statement (ST_FINAL);
- seen_contains_comp = 1;
+ 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
== FAILURE))
error_flag = 1;
- if (seen_contains && !seen_contains_comp
- && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
- "definition at %C with empty CONTAINS "
- "section") == FAILURE))
- error_flag = 1;
-
accept_statement (ST_END_TYPE);
break;
case ST_PRIVATE:
- if (seen_contains)
- {
- gfc_error ("PRIVATE statement at %C must precede CONTAINS");
- error_flag = 1;
- }
-
if (gfc_find_state (COMP_MODULE) == FAILURE)
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
}
s.sym->component_access = ACCESS_PRIVATE;
+
accept_statement (ST_PRIVATE);
seen_private = 1;
break;
case ST_SEQUENCE:
- if (seen_contains)
- {
- gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
- error_flag = 1;
- }
-
if (seen_component)
{
gfc_error ("SEQUENCE statement at %C must precede "
" definition at %C") == FAILURE)
error_flag = 1;
- if (seen_contains)
- {
- gfc_error ("Already inside a CONTAINS block at %C");
- error_flag = 1;
- }
-
- seen_contains = 1;
accept_statement (ST_CONTAINS);
- break;
+ if (parse_derived_contains ())
+ error_flag = 1;
+ goto endType;
default:
unexpected_statement (st);
for (c = sym->components; c; c = c->next)
{
/* Look for allocatable components. */
- if (c->allocatable
+ if (c->attr.allocatable
|| (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
{
sym->attr.alloc_comp = 1;
}
/* Look for pointer components. */
- if (c->pointer
+ if (c->attr.pointer
|| (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
{
sym->attr.pointer_comp = 1;
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
- || c->access == ACCESS_PRIVATE
+ || c->attr.access == ACCESS_PRIVATE
|| (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
{
sym->attr.private_comp = 1;
static void
parse_interface (void)
{
- gfc_compile_state new_state, current_state;
+ gfc_compile_state new_state = COMP_NONE, current_state;
gfc_symbol *prog_unit, *sym;
gfc_interface_info save;
gfc_state_data s1, s2;
new_state = COMP_SUBROUTINE;
else if (st == ST_FUNCTION)
new_state = COMP_FUNCTION;
+ if (gfc_new_block->attr.pointer)
+ {
+ gfc_new_block->attr.pointer = 0;
+ gfc_new_block->attr.proc_pointer = 1;
+ }
if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL) == FAILURE)
{
if (current_interface.type == INTERFACE_ABSTRACT)
{
- gfc_new_block->attr.abstract = 1;
+ gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
if (gfc_is_intrinsic_typename (gfc_new_block->name))
gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
"cannot be the same as an intrinsic type",
/* Set the function locus correctly. If we have not found the
function name, there is an error. */
- gfc_match ("function% %n", name);
- if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
+ if (m == MATCH_YES
+ && gfc_match ("function% %n", name) == MATCH_YES
+ && strcmp (name, gfc_current_block ()->name) == 0)
{
gfc_current_block ()->declared_at = gfc_current_locus;
gfc_commit_symbols ();
}
+/* Check specification-expressions in the function result of the currently
+ parsed block and ensure they are typed (give an IMPLICIT type if necessary).
+ For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
+ scope are not yet parsed so this has to be delayed up to parse_spec. */
+
+static void
+check_function_result_typed (void)
+{
+ gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
+
+ gcc_assert (gfc_current_state () == COMP_FUNCTION);
+ gcc_assert (ts->type != BT_UNKNOWN);
+
+ /* 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);
+}
+
+
/* Parse a set of specification statements. Returns the statement
that doesn't fit. */
parse_spec (gfc_statement st)
{
st_state ss;
+ bool function_result_typed = false;
bool bad_characteristic = false;
gfc_typespec *ts;
- verify_st_order (&ss, ST_NONE);
+ verify_st_order (&ss, ST_NONE, false);
if (st == ST_NONE)
st = next_statement ();
+ /* If we are not inside a function or don't have a result specified so far,
+ do nothing special about it. */
+ if (gfc_current_state () != COMP_FUNCTION)
+ function_result_typed = true;
+ else
+ {
+ gfc_symbol* proc = gfc_current_ns->proc_name;
+ gcc_assert (proc);
+
+ if (proc->result->ts.type == BT_UNKNOWN)
+ function_result_typed = true;
+ }
+
loop:
+
+ /* 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
+ if it has not yet been typed. Be careful not to give the END statement
+ to verify_st_order! */
+ if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
+ {
+ bool verify_now = false;
+
+ if (st == ST_END_FUNCTION || st == ST_CONTAINS)
+ verify_now = true;
+ else
+ {
+ st_state dummyss;
+ verify_st_order (&dummyss, ST_NONE, false);
+ verify_st_order (&dummyss, st, false);
+
+ if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
+ verify_now = true;
+ }
+
+ if (verify_now)
+ {
+ check_function_result_typed ();
+ function_result_typed = true;
+ }
+ }
+
switch (st)
{
case ST_NONE:
unexpected_eof ();
+ case ST_IMPLICIT_NONE:
+ case ST_IMPLICIT:
+ if (!function_result_typed)
+ {
+ check_function_result_typed ();
+ function_result_typed = true;
+ }
+ goto declSt;
+
case ST_FORMAT:
case ST_ENTRY:
case ST_DATA: /* Not allowed in interfaces */
case ST_USE:
case ST_IMPORT:
- 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)
+declSt:
+ if (verify_st_order (&ss, st, false) == FAILURE)
{
reject_statement ();
st = next_statement ();
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))
- ts->type = BT_UNKNOWN;
+ ts->type = BT_UNKNOWN;
}
return st;
gfc_find_sym_tree (sym->name, ns, 0, &st);
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
- continue;
+ goto fixup_contained;
old_sym = st->n.sym;
if (old_sym->ns == ns
gfc_free_symbol (old_sym);
}
+fixup_contained:
/* Do the same for any contained procedures. */
gfc_fixup_sibling_symbols (sym, ns->contained);
}
name = "MODULE";
break;
default:
- gfc_internal_error ("gfc_gsymbol_type(): Bad type");
+ gfc_internal_error ("gfc_global_used(): Bad type");
name = NULL;
}
/* Top level parser. */
-try
+gfc_try
gfc_parse_file (void)
{
int seen_program, errors_before, errors;
duplicate_main:
/* If we see a duplicate main program, shut down. If the second
- instance is an implied main program, ie data decls or executable
+ instance is an implied main program, i.e. data decls or executable
statements, we're in for lots of errors. */
gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
reject_statement ();
OSDN Git Service
