/* Main parser.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009
Free Software Foundation, Inc.
Contributed by Andy Vaught
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
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 < 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 < 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 ((char) gfc_wide_tolower (c) == "$omp"[i]);
if (c != ' ' && c != '0')
{
/* If the statement is the end of a block, lay down a special code
that allows a branch to the end of the block from within the
- construct. */
+ construct. IF and SELECT are treated differently from DO
+ (where EXEC_NOP is added inside the loop) for two
+ reasons:
+ 1. END DO has a meaning in the sense that after a GOTO to
+ it, the loop counter must be increased.
+ 2. IF blocks and SELECT blocks can consist of multiple
+ parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
+ Putting the label before the END IF would make the jump
+ from, say, the ELSE IF block to the END IF illegal. */
case ST_ENDIF:
case ST_END_SELECT:
if (gfc_statement_label != NULL)
{
- new_st.op = EXEC_NOP;
+ new_st.op = EXEC_END_BLOCK;
add_statement ();
}
-
break;
/* The end-of-program unit statements do not get the special
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;
}
unexpected_eof ();
case ST_DATA_DECL:
+ case ST_PROCEDURE:
accept_statement (st);
seen_component = 1;
break;
- case ST_PROCEDURE:
- gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
- error_flag = 1;
- break;
-
case ST_FINAL:
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
error_flag = 1;
{
/* Look for allocatable components. */
if (c->attr.allocatable
- || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
- {
- sym->attr.alloc_comp = 1;
- break;
- }
+ || (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))
- {
- sym->attr.pointer_comp = 1;
- break;
- }
+ || (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.u.derived->attr.proc_pointer_comp))
+ sym->attr.proc_pointer_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))
- {
- sym->attr.private_comp = 1;
- break;
- }
+ || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
+ sym->attr.private_comp = 1;
}
if (!seen_component)
gfc_free_namespace (gfc_current_ns);
goto loop;
}
- if (current_interface.type != INTERFACE_ABSTRACT &&
- !gfc_new_block->attr.dummy &&
- gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
- {
- reject_statement ();
- gfc_free_namespace (gfc_current_ns);
- goto loop;
- }
break;
case ST_PROCEDURE:
goto decl;
}
+ /* Add EXTERNAL attribute to function or subroutine. */
+ if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
+ gfc_add_external (&prog_unit->attr, &gfc_current_locus);
+
current_interface = save;
gfc_add_interface (prog_unit);
pop_state ();
{
ts->kind = 0;
- if (!ts->derived || !ts->derived->components)
+ if (!ts->u.derived || !ts->u.derived->components)
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);
}
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);
if (p->ext.end_do_label == gfc_statement_label)
{
-
if (p == gfc_state_stack)
return 1;
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;
name, but in that case we must have seen ST_ENDDO first).
We only complain about this in pedantic mode. */
if (gfc_current_block () != NULL)
- gfc_error_now ("named block DO at %L requires matching ENDDO name",
+ gfc_error_now ("Named block DO at %L requires matching ENDDO name",
&gfc_current_block()->declared_at);
break;
sym->attr.referenced = 1;
for (ns = siblings; ns; ns = ns->sibling)
{
- gfc_find_sym_tree (sym->name, ns, 0, &st);
+ st = gfc_find_symtree (ns->sym_root, sym->name);
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
goto fixup_contained;
st = next_statement ();
goto loop;
}
+
+ s->ns = gfc_current_ns;
}
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
s->defined = 1;
+ 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_state_data top, s;
gfc_statement st;
locus prog_locus;
+ gfc_namespace *next;
gfc_start_source_files ();
if (setjmp (eof_buf))
return FAILURE; /* Come here on unexpected EOF */
+ /* Prepare the global namespace that will contain the
+ program units. */
+ gfc_global_ns_list = next = NULL;
+
seen_program = 0;
/* Exit early for empty files. */
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_SUBROUTINE:
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_FUNCTION:
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_BLOCK_DATA:
push_state (&s, COMP_PROGRAM, gfc_new_block);
main_program_symbol (gfc_current_ns, "MAIN__");
parse_progunit (st);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
}
+ /* Handle the non-program units. */
gfc_current_ns->code = s.head;
gfc_resolve (gfc_current_ns);
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 ();
}
+ goto loop;
+
+prog_units:
+ /* The main program and non-contained procedures are put
+ in the global namespace list, so that they can be processed
+ later and all their interfaces resolved. */
+ gfc_current_ns->code = s.head;
+ if (next)
+ next->sibling = gfc_current_ns;
+ else
+ gfc_global_ns_list = gfc_current_ns;
+
+ next = gfc_current_ns;
+
pop_state ();
- gfc_done_2 ();
goto loop;
-done:
+ done:
+
+ if (!gfc_option.flag_whole_file)
+ goto termination;
+
+ /* 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;
+
+ for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+ {
+ gfc_dump_parse_tree (gfc_current_ns, stdout);
+ fputs ("------------------------------------------\n\n", stdout);
+ }
+
+ /* Do the translation. */
+ translate_all_program_units (gfc_global_ns_list);
+
+termination:
+
gfc_end_source_files ();
return SUCCESS;
OSDN Git Service
